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