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