summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/read-print.scm33
-rw-r--r--tests/read-print.scm7
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)"