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