test-suite/tests/reader.test

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