diff options
| -rw-r--r-- | guix/read-print.scm | 33 | ||||
| -rw-r--r-- | tests/read-print.scm | 7 |
2 files changed, 34 insertions, 6 deletions
diff --git a/guix/read-print.scm b/guix/read-print.scm index 9d666d7f70c..08e219e2044 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm | |||
| @@ -24,6 +24,11 @@ | |||
| 24 | #:use-module (srfi srfi-1) | 24 | #:use-module (srfi srfi-1) |
| 25 | #:use-module (srfi srfi-34) | 25 | #:use-module (srfi srfi-34) |
| 26 | #:use-module (srfi srfi-35) | 26 | #:use-module (srfi srfi-35) |
| 27 | #:use-module (guix i18n) | ||
| 28 | #:use-module ((guix diagnostics) | ||
| 29 | #:select (formatted-message | ||
| 30 | &fix-hint &error-location | ||
| 31 | location)) | ||
| 27 | #:export (pretty-print-with-comments | 32 | #:export (pretty-print-with-comments |
| 28 | pretty-print-with-comments/splice | 33 | pretty-print-with-comments/splice |
| 29 | read-with-comments | 34 | read-with-comments |
| @@ -158,6 +163,19 @@ BLANK-LINE? is true, assume PORT is at the beginning of a new line." | |||
| 158 | (define dot (list 'dot)) | 163 | (define dot (list 'dot)) |
| 159 | (define (dot? x) (eq? x dot)) | 164 | (define (dot? x) (eq? x dot)) |
| 160 | 165 | ||
| 166 | (define (missing-closing-paren-error) | ||
| 167 | (raise (make-compound-condition | ||
| 168 | (formatted-message (G_ "unexpected end of file")) | ||
| 169 | (condition | ||
| 170 | (&error-location | ||
| 171 | (location (match (port-filename port) | ||
| 172 | (#f #f) | ||
| 173 | (file (location file | ||
| 174 | (port-line port) | ||
| 175 | (port-column port)))))) | ||
| 176 | (&fix-hint | ||
| 177 | (hint (G_ "Did you forget a closing parenthesis?"))))))) | ||
| 178 | |||
| 161 | (define (reverse/dot lst) | 179 | (define (reverse/dot lst) |
| 162 | ;; Reverse LST and make it an improper list if it contains DOT. | 180 | ;; Reverse LST and make it an improper list if it contains DOT. |
| 163 | (let loop ((result '()) | 181 | (let loop ((result '()) |
| @@ -190,12 +208,15 @@ BLANK-LINE? is true, assume PORT is at the beginning of a new line." | |||
| 190 | ((memv chr '(#\( #\[)) | 208 | ((memv chr '(#\( #\[)) |
| 191 | (let/ec return | 209 | (let/ec return |
| 192 | (let liip ((lst '())) | 210 | (let liip ((lst '())) |
| 193 | (liip (cons (loop (match lst | 211 | (define item |
| 194 | (((? blank?) . _) #t) | 212 | (loop (match lst |
| 195 | (_ #f)) | 213 | (((? blank?) . _) #t) |
| 196 | (lambda () | 214 | (_ #f)) |
| 197 | (return (reverse/dot lst)))) | 215 | (lambda () |
| 198 | lst))))) | 216 | (return (reverse/dot lst))))) |
| 217 | (if (eof-object? item) | ||
| 218 | (missing-closing-paren-error) | ||
| 219 | (liip (cons item lst)))))) | ||
| 199 | ((memv chr '(#\) #\])) | 220 | ((memv chr '(#\) #\])) |
| 200 | (return)) | 221 | (return)) |
| 201 | ((eq? chr #\') | 222 | ((eq? chr #\') |
diff --git a/tests/read-print.scm b/tests/read-print.scm index b484e280227..4dabcc1e64c 100644 --- a/tests/read-print.scm +++ b/tests/read-print.scm | |||
| @@ -19,6 +19,8 @@ | |||
| 19 | (define-module (tests-style) | 19 | (define-module (tests-style) |
| 20 | #:use-module (guix read-print) | 20 | #:use-module (guix read-print) |
| 21 | #:use-module (guix gexp) ;for the reader extensions | 21 | #:use-module (guix gexp) ;for the reader extensions |
| 22 | #:use-module (srfi srfi-34) | ||
| 23 | #:use-module (srfi srfi-35) | ||
| 22 | #:use-module (srfi srfi-64) | 24 | #:use-module (srfi srfi-64) |
| 23 | #:use-module (ice-9 match)) | 25 | #:use-module (ice-9 match)) |
| 24 | 26 | ||
| @@ -46,6 +48,11 @@ expressions." | |||
| 46 | 48 | ||
| 47 | (test-begin "read-print") | 49 | (test-begin "read-print") |
| 48 | 50 | ||
| 51 | (test-assert "read-with-comments: missing closing paren" | ||
| 52 | (guard (c ((error? c) #t)) | ||
| 53 | (call-with-input-string "(what is going on?" | ||
| 54 | read-with-comments))) | ||
| 55 | |||
| 49 | (test-equal "read-with-comments: dot notation" | 56 | (test-equal "read-with-comments: dot notation" |
| 50 | (cons 'a 'b) | 57 | (cons 'a 'b) |
| 51 | (call-with-input-string "(a . b)" | 58 | (call-with-input-string "(a . b)" |
