1;;;; reader.test --- Reader test.    -*- coding: iso-8859-1; mode: scheme -*-
2;;;;
3;;;; Copyright (C) 1999,2001-2003,2007-2011,2013-2015,2020,2021
4;;;;   Free Software Foundation, Inc.
5;;;;
6;;;; Jim Blandy <jimb@red-bean.com>
7;;;;
8;;;; This library is free software; you can redistribute it and/or
9;;;; modify it under the terms of the GNU Lesser General Public
10;;;; License as published by the Free Software Foundation; either
11;;;; version 3 of the License, or (at your option) any later version.
12;;;;
13;;;; This library is distributed in the hope that it will be useful,
14;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16;;;; Lesser General Public License for more details.
17;;;;
18;;;; You should have received a copy of the GNU Lesser General Public
19;;;; License along with this library; if not, write to the Free Software
20;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21
22(define-module (test-suite reader)
23  #:use-module (srfi srfi-1)
24  #:use-module (test-suite lib)
25  #:use-module (system syntax internal))
26
27
28(define exception:eof
29  (cons 'read-error "unexpected end of input"))
30(define exception:unexpected-rparen
31  (cons 'read-error "unexpected \")\"$"))
32(define exception:unexpected-rsqbracket
33  (cons 'read-error "unexpected \"]\"$"))
34(define exception:unterminated-block-comment
35  (cons 'read-error "unterminated `#. \\.\\.\\. .#' comment$"))
36(define exception:unknown-character-name
37  (cons 'read-error "unknown character name .*$"))
38(define exception:unknown-sharp-object
39  (cons 'read-error "Unknown # object: .*$"))
40(define exception:eof-in-string
41  (cons 'read-error "end of input while reading string$"))
42(define exception:eof-in-symbol
43  (cons 'read-error "end of input while reading symbol$"))
44(define exception:invalid-escape
45  (cons 'read-error "invalid character in escape sequence: .*$"))
46(define exception:missing-expression
47  (cons 'read-error "no expression after #;"))
48(define exception:mismatched-paren
49  (cons 'read-error "mismatched close paren"))
50
51
52(define (read-string s)
53  (with-input-from-string s (lambda () (read))))
54
55(define (with-read-options opts thunk)
56  (let ((saved-options (read-options)))
57    (dynamic-wind
58        (lambda ()
59          (read-options opts))
60        thunk
61        (lambda ()
62          (read-options saved-options)))))
63
64(define (read-string-as-list s)
65  (with-input-from-string s
66    (lambda ()
67      (unfold eof-object? values (lambda (x) (read)) (read)))))
68
69
70(with-test-prefix "reading"
71  (pass-if "0"
72    (equal? (read-string "0") 0))
73  (pass-if "1++i"
74    (equal? (read-string "1++i") '1++i))
75  (pass-if "1+i+i"
76    (equal? (read-string "1+i+i") '1+i+i))
77  (pass-if "1+e10000i"
78    (equal? (read-string "1+e10000i") '1+e10000i))
79  (pass-if "-nan.0-1i"
80    (not (equal? (imag-part (read-string "-nan.0-1i"))
81                 (imag-part (read-string "-nan.0+1i")))))
82
83  (pass-if-equal "'\|' in string literals"
84      "a|b"
85    (read-string "\"a\\|b\""))
86
87  (pass-if-equal "'(' in string literals"
88      "a(b"
89    (read-string "\"a\\(b\""))
90
91  (pass-if-equal "#\\escape"
92      '(a #\esc b)
93    (read-string "(a #\\escape b)"))
94
95  (pass-if-equal "#true"
96      '(a #t b)
97    (read-string "(a #true b)"))
98
99  (pass-if-equal "#false"
100      '(a #f b)
101    (read-string "(a #false b)"))
102
103  ;; At one time the arg list for "Unknown # object: ~S" didn't make it out
104  ;; of read.c.  Check that `format' can be applied to this error.
105  (pass-if "error message on bad #"
106    (catch #t
107	   (lambda ()
108	     (read-string "#ZZZ")
109	     ;; oops, this # is supposed to be unrecognised
110	     #f)
111	   (lambda (key subr message args rest)
112	     (apply format #f message args)
113	     ;; message and args are ok
114	     #t)))
115
116  (pass-if "block comment"
117    (equal? '(+ 1 2 3)
118            (read-string "(+ 1 #! this is a\ncomment !# 2 3)")))
119
120  (pass-if "block comment finishing s-exp"
121    (equal? '(+ 2)
122            (read-string "(+ 2 #! a comment\n!#\n) ")))
123
124  (pass-if "R6RS lexeme comment"
125    (equal? '(+ 1 2 3)
126            (read-string "(+ 1 #!r6rs 2 3)")))
127
128  (pass-if "partial R6RS lexeme comment"
129    (equal? '(+ 1 2 3)
130            (read-string "(+ 1 #!r6r !# 2 3)")))
131
132  (pass-if "R6RS/SRFI-30 block comment"
133    (equal? '(+ 1 2 3)
134            (read-string "(+ 1 #| this is a\ncomment |# 2 3)")))
135
136  (pass-if "R6RS/SRFI-30 nested block comment"
137    (equal? '(a b c)
138            (read-string "(a b c #| d #| e |# f |#)")))
139
140  (pass-if "R6RS/SRFI-30 nested block comment (2)"
141    (equal? '(a b c)
142            (read-string "(a b c #|||||||#)")))
143
144  (pass-if "R6RS/SRFI-30 nested block comment (3)"
145    (equal? '(a b c)
146            (read-string "(a b c #||||||||#)")))
147
148  (pass-if "R6RS/SRFI-30 block comment syntax overridden"
149    ;; To be compatible with 1.8 and earlier, we should be able to override
150    ;; this syntax.
151    (with-fluids ((%read-hash-procedures (fluid-ref %read-hash-procedures)))
152      (read-hash-extend #\| (lambda args 'not))
153      (fold (lambda (x y result)
154              (and result (eq? x y)))
155            #t
156            (read-string "(this is #| a comment)")
157            `(this is not a comment))))
158
159  (pass-if "unprintable symbol"
160    ;; The reader tolerates unprintable characters for symbols.
161    (equal? (string->symbol "\x01\x02\x03")
162            (read-string "\x01\x02\x03")))
163
164  (pass-if "CR recognized as a token delimiter"
165    ;; In 1.8.3, character 0x0d was not recognized as a delimiter.
166    (equal? (read-string "one\x0dtwo") 'one))
167
168  (pass-if "returned strings are mutable"
169    ;; Per R5RS Section 3.4, "Storage Model", `read' is supposed to return
170    ;; mutable objects.
171    (let ((str (with-input-from-string "\"hello, world\"" read)))
172      (string-set! str 0 #\H)
173      (string=? str "Hello, world")))
174
175  (pass-if "square brackets are parens"
176    (equal? '() (read-string "[]")))
177
178  (pass-if-exception "paren mismatch" exception:mismatched-paren
179                     (read-string "'[)"))
180
181  (pass-if-exception "paren mismatch (2)" exception:mismatched-paren
182                     (read-string "'(]"))
183
184  (pass-if-exception "paren mismatch (3)" exception:mismatched-paren
185                     (read-string "'(foo bar]"))
186
187  (pass-if-exception "paren mismatch (4)" exception:mismatched-paren
188    (read-string "'[foo bar)"))
189
190  (pass-if-equal '(#f 1) (read-string "(#f1)"))
191  (pass-if-equal '(#f a) (read-string "(#fa)"))
192  (pass-if-equal '(#f a) (read-string "(#Fa)"))
193  (pass-if-equal '(#t 1) (read-string "(#t1)"))
194  (pass-if-equal '(#t r) (read-string "(#tr)"))
195  (pass-if-equal '(#t r) (read-string "(#Tr)"))
196  (pass-if-equal '(#t) (read-string "(#TrUe)"))
197  (pass-if-equal '(#t) (read-string "(#TRUE)"))
198  (pass-if-equal '(#t) (read-string "(#true)"))
199  (pass-if-equal '(#f) (read-string "(#false)"))
200  (pass-if-equal '(#f) (read-string "(#FALSE)"))
201  (pass-if-equal '(#f) (read-string "(#FaLsE)"))
202
203  (pass-if (eof-object? (read-string "#!!#"))))
204
205
206
207(pass-if-exception "radix passed to number->string can't be zero"
208  exception:out-of-range
209  (number->string 10 0))
210(pass-if-exception "radix passed to number->string can't be one either"
211  exception:out-of-range
212  (number->string 10 1))
213
214
215(with-test-prefix "mismatching parentheses"
216  (pass-if-equal "read-error location"
217      '("foo.scm:3:1: unexpected end of input while searching for: ~A" #\))
218    (catch 'read-error
219      (lambda ()
220        ;; The missing closing paren error should be located on line 3,
221        ;; column 1 (one-indexed).
222        (call-with-input-string "\n    (hi there!\n"
223          (lambda (port)
224            (set-port-filename! port "foo.scm")
225            (read port))))
226      (lambda (key proc message args . _)
227        (cons message args))))
228  (pass-if-exception "opening parenthesis"
229    exception:eof
230    (read-string "("))
231  (pass-if-exception "closing parenthesis following mismatched opening"
232    exception:unexpected-rparen
233    (read-string ")"))
234  (pass-if-exception "closing square bracket following mismatched opening"
235    exception:unexpected-rsqbracket
236    (read-string "]"))
237  (pass-if-exception "opening vector parenthesis"
238    exception:eof
239    (read-string "#("))
240  (pass-if-exception "closing parenthesis following mismatched vector opening"
241     exception:unexpected-rparen
242     (read-string ")")))
243
244
245(with-test-prefix "exceptions"
246
247  ;; Reader exceptions: although they are not documented, they may be relied
248  ;; on by some programs, hence these tests.
249
250  (pass-if-exception "unterminated block comment"
251    exception:unterminated-block-comment
252    (read-string "(+ 1 #! comment\n..."))
253  (pass-if-exception "R6RS/SRFI-30 unterminated nested block comment"
254    exception:unterminated-block-comment
255    (read-string "(foo #| bar #| |#)"))
256  (pass-if-exception "unknown character name"
257    exception:unknown-character-name
258    (read-string "#\\theunknowncharacter"))
259  (pass-if-exception "unknown sharp object"
260    exception:unknown-sharp-object
261    (read-string "#?"))
262  (pass-if-exception "eof in string"
263    exception:eof-in-string
264    (read-string "\"the string that never ends"))
265  (pass-if-exception "invalid escape in string"
266    exception:invalid-escape
267    (read-string "\"some string \\???\"")))
268
269
270(with-test-prefix "read-options"
271  (pass-if "case-sensitive"
272    (not (eq? 'guile 'GuiLe)))
273  (pass-if "case-insensitive"
274    (eq? 'guile
275         (with-read-options '(case-insensitive)
276           (lambda ()
277             (read-string "GuiLe")))))
278  (pass-if-equal "r7rs-symbols"
279      (list 'a (string->symbol "Hello, this is | a \"test\"") 'b)
280    (with-read-options '(r7rs-symbols)
281      (lambda ()
282        (read-string "(a |H\\x65;llo, this is \\| a \"test\"| b)"))))
283  (pass-if "prefix keywords"
284    (eq? #:keyword
285         (with-read-options '(keywords prefix case-insensitive)
286           (lambda ()
287             (read-string ":KeyWord")))))
288  (pass-if "prefix non-keywords"
289    (symbol? (with-read-options '(keywords prefix)
290               (lambda ()
291                 (read-string "srfi88-keyword:")))))
292  (pass-if "postfix keywords"
293    (eq? #:keyword
294         (with-read-options '(keywords postfix)
295           (lambda ()
296             (read-string "keyword:")))))
297  (pass-if "long postfix keywords"
298    (eq? #:keyword0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789
299         (with-read-options '(keywords postfix)
300           (lambda ()
301             (read-string "keyword0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789:")))))
302  (pass-if "`:' is not a postfix keyword (per SRFI-88)"
303    (eq? ':
304         (with-read-options '(keywords postfix)
305           (lambda ()
306             (read-string ":")))))
307  (pass-if "no positions"
308    (let ((sexp (with-read-options '()
309                  (lambda ()
310                    (read-string "(+ 1 2 3)")))))
311      (and (not (source-property sexp 'line))
312           (not (source-property sexp 'column)))))
313  (pass-if "positions"
314    (let ((sexp (with-read-options '(positions)
315                  (lambda ()
316                    (read-string "(+ 1 2 3)")))))
317      (and (equal? (source-property sexp 'line) 0)
318           (equal? (source-property sexp 'column) 0))))
319  (pass-if "positions on quote"
320    (let ((sexp (with-read-options '(positions)
321                   (lambda ()
322                    (read-string "'abcde")))))
323      (and (equal? (source-property sexp 'line) 0)
324           (equal? (source-property sexp 'column) 0))))
325  (pass-if "position of SCSH block comment"
326    ;; In Guile 2.0.0 the reader would not update the port's position
327    ;; when reading an SCSH block comment.
328    (let ((sexp (with-read-options '(positions)
329                  (lambda ()
330                    (read-string "#!foo\nbar\nbaz\n!#\n(hello world)\n")))))
331      (= 4 (source-property sexp 'line))))
332
333  (with-test-prefix "r6rs-hex-escapes"
334      (pass-if-exception "non-hex char in two-digit hex-escape"
335      exception:invalid-escape
336      (with-read-options '(r6rs-hex-escapes)
337        (lambda ()
338          (with-input-from-string "\"\\x0g;\"" read))))
339
340    (pass-if-exception "non-hex char in four-digit hex-escape"
341      exception:invalid-escape
342      (with-read-options '(r6rs-hex-escapes)
343        (lambda ()
344          (with-input-from-string "\"\\x000g;\"" read))))
345
346    (pass-if-exception "non-hex char in six-digit hex-escape"
347      exception:invalid-escape
348      (with-read-options '(r6rs-hex-escapes)
349        (lambda ()
350          (with-input-from-string "\"\\x00000g;\"" read))))
351
352    (pass-if-exception "no semicolon at termination of one-digit hex-escape"
353      exception:invalid-escape
354      (with-read-options '(r6rs-hex-escapes)
355        (lambda ()
356          (with-input-from-string "\"\\x0\"" read))))
357
358    (pass-if-exception "no semicolon at termination of three-digit hex-escape"
359      exception:invalid-escape
360      (with-read-options '(r6rs-hex-escapes)
361        (lambda ()
362          (with-input-from-string "\"\\x000\"" read))))
363
364    (pass-if "two-digit hex escape"
365      (eqv?
366       (with-read-options '(r6rs-hex-escapes)
367         (lambda ()
368           (string-ref (with-input-from-string "\"--\\xff;--\"" read) 2)))
369       (integer->char #xff)))
370
371    (pass-if "four-digit hex escape"
372      (eqv?
373       (with-read-options '(r6rs-hex-escapes)
374         (lambda ()
375           (string-ref (with-input-from-string "\"--\\x0100;--\"" read) 2)))
376       (integer->char #x0100)))
377
378    (pass-if "six-digit hex escape"
379      (eqv?
380       (with-read-options '(r6rs-hex-escapes)
381         (lambda ()
382           (string-ref (with-input-from-string "\"--\\x010300;--\"" read) 2)))
383       (integer->char #x010300)))
384
385    (pass-if "escaped characters match non-escaped ASCII characters"
386      (string=?
387       (with-read-options '(r6rs-hex-escapes)
388         (lambda ()
389           (with-input-from-string "\"\\x41;\\x0042;\\x000043;\"" read)))
390       "ABC"))
391
392    (pass-if "write R6RS string escapes"
393       (let* ((s1 (apply string
394                         (map integer->char '(#x8 ; backspace
395                                              #x18 ; cancel
396                                              #x20 ; space
397                                              #x30 ; zero
398                                              #x40 ; at sign
399                                              ))))
400              (s2 (with-read-options '(r6rs-hex-escapes)
401                     (lambda ()
402                      (with-output-to-string
403                        (lambda () (write s1)))))))
404         (lset= eqv?
405                (string->list s2)
406                (list #\" #\\ #\b #\\ #\x #\1 #\8 #\; #\space #\0 #\@ #\"))))
407
408    (pass-if "display R6RS string escapes"
409      (string=?
410       (with-read-options '(r6rs-hex-escapes)
411         (lambda ()
412           (let ((pt (open-output-string))
413                 (s1 (apply string (map integer->char
414                                        '(#xFF #x100 #xFFF #x1000 #xFFFF #x10000)))))
415             (set-port-encoding! pt "ASCII")
416             (set-port-conversion-strategy! pt 'escape)
417             (display s1 pt)
418             (get-output-string pt))))
419       "\\xff;\\x100;\\xfff;\\x1000;\\xffff;\\x10000;"))
420
421    (pass-if "one-digit hex escape"
422      (eqv? (with-input-from-string "#\\xA" read)
423            (integer->char #x0A)))
424
425    (pass-if "two-digit hex escape"
426      (eqv? (with-input-from-string "#\\xFF" read)
427            (integer->char #xFF)))
428
429    (pass-if "four-digit hex escape"
430      (eqv? (with-input-from-string "#\\x00FF" read)
431            (integer->char #xFF)))
432
433    (pass-if "eight-digit hex escape"
434      (eqv? (with-input-from-string "#\\x00006587" read)
435            (integer->char #x6587)))
436
437    (pass-if "write R6RS escapes"
438      (string=?
439       (with-read-options '(r6rs-hex-escapes)
440         (lambda ()
441           (with-output-to-string
442             (lambda ()
443               (write (integer->char #x80))))))
444       "#\\x80")))
445
446  (with-test-prefix "hungry escapes"
447    (pass-if "default not hungry"
448      ;; Assume default setting of not hungry.
449      (equal? (with-input-from-string "\"foo\\\n  bar\""
450                read)
451              "foo  bar"))
452    (pass-if "hungry"
453      (dynamic-wind
454        (lambda ()
455          (read-enable 'hungry-eol-escapes))
456        (lambda ()
457          (equal? (with-input-from-string "\"foo\\\n  bar\""
458                    read)
459                  "foobar"))
460        (lambda ()
461          (read-disable 'hungry-eol-escapes))))))
462
463(with-test-prefix "per-port-read-options"
464  (pass-if "case-sensitive"
465    (equal? '(guile GuiLe gUIle)
466            (with-read-options '(case-insensitive)
467              (lambda ()
468                (read-string-as-list "GUIle #!no-fold-case GuiLe gUIle")))))
469  (pass-if "case-insensitive"
470    (equal? '(GUIle guile guile)
471            (read-string-as-list "GUIle #!fold-case GuiLe gUIle")))
472  (with-test-prefix "r6rs"
473    (pass-if-equal "case sensitive"
474        '(guile GuiLe gUIle)
475      (with-read-options '(case-insensitive)
476        (lambda ()
477          (read-string-as-list "GUIle #!r6rs GuiLe gUIle"))))
478    (pass-if-equal "square brackets"
479        '((a b c) (foo 42 bar) (x . y))
480      (read-string-as-list "(a b c) #!r6rs [foo 42 bar] [x . y]"))
481    (pass-if-equal "hex string escapes"
482        '("native\x7fsyntax"
483          "\0"
484          "ascii\x7fcontrol"
485          "U\u0100BMP"
486          "U\U010402SMP")
487      (read-string-as-list (string-append "\"native\\x7fsyntax\" "
488                                          "#!r6rs "
489                                          "\"\\x0;\" "
490                                          "\"ascii\\x7f;control\" "
491                                          "\"U\\x100;BMP\" "
492                                          "\"U\\x10402;SMP\"")))
493    (with-test-prefix "keyword style"
494      (pass-if-equal "postfix disabled"
495          '(#:regular #:postfix postfix: #:regular2)
496        (with-read-options '(keywords postfix)
497          (lambda ()
498            (read-string-as-list "#:regular postfix: #!r6rs postfix: #:regular2"))))
499      (pass-if-equal "prefix disabled"
500          '(#:regular #:prefix :prefix #:regular2)
501        (with-read-options '(keywords prefix)
502          (lambda ()
503            (read-string-as-list "#:regular :prefix #!r6rs :prefix #:regular2")))))))
504
505(with-test-prefix "#;"
506  (for-each
507   (lambda (pair)
508     (pass-if (car pair)
509       (equal? (with-input-from-string (car pair) read) (cdr pair))))
510
511   '(("#;foo 10". 10)
512     ("#;(10 20 30) foo" . foo)
513     ("#;   (10 20 30) foo" . foo)
514     ("#;\n10\n20" . 20)))
515
516  (pass-if "#;foo"
517    (eof-object? (with-input-from-string "#;foo" read)))
518
519  (pass-if-exception "#;"
520    exception:eof
521    (with-input-from-string "#;" read))
522  (pass-if-exception "#;("
523    exception:eof
524    (with-input-from-string "#;(" read)))
525
526(with-test-prefix "#'"
527  (for-each
528   (lambda (pair)
529     (pass-if (car pair)
530       (equal? (with-input-from-string (car pair) read) (cdr pair))))
531
532   '(("#'foo". (syntax foo))
533     ("#`foo" . (quasisyntax foo))
534     ("#,foo" . (unsyntax foo))
535     ("#,@foo" . (unsyntax-splicing foo)))))
536
537(with-test-prefix "#{}#"
538  (pass-if (equal? (read-string "#{}#") '#{}#))
539  (pass-if (not (equal? (read-string "(a #{.}# b)") '(a . b))))
540  (pass-if (equal? (read-string "#{a}#") 'a))
541  (pass-if (equal? (read-string "#{a b}#") '#{a b}#))
542  (pass-if-exception "#{" exception:eof-in-symbol
543                     (read-string "#{"))
544  (pass-if (equal? (read-string "#{a\\x20;b}#") '#{a b}#)))
545
546(begin-deprecated
547 (with-test-prefix "deprecated #{}# escapes"
548   (pass-if (equal? (read-string "#{a\\ b}#") '#{a b}#))))
549
550(with-test-prefix "read-syntax"
551  (pass-if-equal "annotations" 'args
552    (syntax-expression (call-with-input-string "( . args)" read-syntax))))
553
554;;; Local Variables:
555;;; eval: (put 'with-read-options 'scheme-indent-function 1)
556;;; End:
557