test-suite/tests/reader.test

   1 ;;;; reader.test --- Exercise the reader.               -*- Scheme -*-
   2 ;;;;
   3 ;;;; Copyright (C) 1999, 2001, 2002, 2003, 2007, 2008, 2009 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
  42
  43 (define (read-string s)
  44   (with-input-from-string s (lambda () (read))))
  45
  46 (define (with-read-options opts thunk)
  47   (let ((saved-options (read-options)))
  48     (dynamic-wind
  49         (lambda ()
  50           (read-options opts))
  51         thunk
  52         (lambda ()
  53           (read-options saved-options)))))
  54
  55 \f
  56 (with-test-prefix "reading"
  57   (pass-if "0"
  58     (equal? (read-string "0") 0))
  59   (pass-if "1++i"
  60     (equal? (read-string "1++i") '1++i))
  61   (pass-if "1+i+i"
  62     (equal? (read-string "1+i+i") '1+i+i))
  63   (pass-if "1+e10000i"
  64     (equal? (read-string "1+e10000i") '1+e10000i))
  65
  66   ;; At one time the arg list for "Unknown # object: ~S" didn't make it out
  67   ;; of read.c.  Check that `format' can be applied to this error.
  68   (pass-if "error message on bad #"
  69     (catch #t
  70            (lambda ()
  71              (read-string "#ZZZ")
  72              ;; oops, this # is supposed to be unrecognised
  73              #f)
  74            (lambda (key subr message args rest)
  75              (apply format #f message args)
  76              ;; message and args are ok
  77              #t)))
  78
  79   (pass-if "block comment"
  80     (equal? '(+ 1 2 3)
  81             (read-string "(+ 1 #! this is a\ncomment !# 2 3)")))
  82
  83   (pass-if "block comment finishing s-exp"
  84     (equal? '(+ 2)
  85             (read-string "(+ 2 #! a comment\n!#\n) ")))
  86
  87   (pass-if "R6RS/SRFI-30 block comment"
  88     (equal? '(+ 1 2 3)
  89             (read-string "(+ 1 #| this is a\ncomment |# 2 3)")))
  90
  91   (pass-if "R6RS/SRFI-30 nested block comment"
  92     (equal? '(a b c)
  93             (read-string "(a b c #| d #| e |# f |#)")))
  94
  95   (pass-if "R6RS/SRFI-30 block comment syntax overridden"
  96     ;; To be compatible with 1.8 and earlier, we should be able to override
  97     ;; this syntax.
  98     (let ((rhp read-hash-procedures))
  99       (dynamic-wind
 100         (lambda ()
 101           (read-hash-extend #\| (lambda args 'not)))
 102         (lambda ()
 103           (fold (lambda (x y result)
 104                   (and result (eq? x y)))
 105                 #t
 106                 (read-string "(this is #| a comment)")
 107                 `(this is not a comment)))
 108         (lambda ()
 109           (set! read-hash-procedures rhp)))))
 110
 111   (pass-if "unprintable symbol"
 112     ;; The reader tolerates unprintable characters for symbols.
 113     (equal? (string->symbol "\001\002\003")
 114             (read-string "\001\002\003")))
 115
 116   (pass-if "CR recognized as a token delimiter"
 117     ;; In 1.8.3, character 0x0d was not recognized as a delimiter.
 118     (equal? (read-string "one\x0dtwo") 'one))
 119
 120   (pass-if "returned strings are mutable"
 121     ;; Per R5RS Section 3.4, "Storage Model", `read' is supposed to return
 122     ;; mutable objects.
 123     (let ((str (with-input-from-string "\"hello, world\"" read)))
 124       (string-set! str 0 #\H)
 125       (string=? str "Hello, world"))))
 126
 127 \f
 128 (pass-if-exception "radix passed to number->string can't be zero"
 129   exception:out-of-range
 130   (number->string 10 0))
 131 (pass-if-exception "radix passed to number->string can't be one either"
 132   exception:out-of-range
 133   (number->string 10 1))
 134
 135 \f
 136 (with-test-prefix "mismatching parentheses"
 137   (pass-if-exception "opening parenthesis"
 138     exception:eof
 139     (read-string "("))
 140   (pass-if-exception "closing parenthesis following mismatched opening"
 141     exception:unexpected-rparen
 142     (read-string ")"))
 143   (pass-if-exception "opening vector parenthesis"
 144     exception:eof
 145     (read-string "#("))
 146   (pass-if-exception "closing parenthesis following mismatched vector opening"
 147      exception:unexpected-rparen
 148      (read-string ")")))
 149
 150 \f
 151 (with-test-prefix "exceptions"
 152
 153   ;; Reader exceptions: although they are not documented, they may be relied
 154   ;; on by some programs, hence these tests.
 155
 156   (pass-if-exception "unterminated block comment"
 157     exception:unterminated-block-comment
 158     (read-string "(+ 1 #! comment\n..."))
 159   (pass-if-exception "R6RS/SRFI-30 unterminated nested block comment"
 160     exception:unterminated-block-comment
 161     (read-string "(foo #| bar #| |#)"))
 162   (pass-if-exception "unknown character name"
 163     exception:unknown-character-name
 164     (read-string "#\\theunknowncharacter"))
 165   (pass-if-exception "unknown sharp object"
 166     exception:unknown-sharp-object
 167     (read-string "#?"))
 168   (pass-if-exception "eof in string"
 169     exception:eof-in-string
 170     (read-string "\"the string that never ends"))
 171   (pass-if-exception "illegal escape in string"
 172     exception:illegal-escape
 173     (read-string "\"some string \\???\"")))
 174
 175 \f
 176 (with-test-prefix "read-options"
 177   (pass-if "case-sensitive"
 178     (not (eq? 'guile 'GuiLe)))
 179   (pass-if "case-insensitive"
 180     (eq? 'guile
 181          (with-read-options '(case-insensitive)
 182            (lambda ()
 183              (read-string "GuiLe")))))
 184   (pass-if "prefix keywords"
 185     (eq? #:keyword
 186          (with-read-options '(keywords prefix case-insensitive)
 187            (lambda ()
 188              (read-string ":KeyWord")))))
 189   (pass-if "prefix non-keywords"
 190     (symbol? (with-read-options '(keywords prefix)
 191                (lambda ()
 192                  (read-string "srfi88-keyword:")))))
 193   (pass-if "postfix keywords"
 194     (eq? #:keyword
 195          (with-read-options '(keywords postfix)
 196            (lambda ()
 197              (read-string "keyword:")))))
 198   (pass-if "long postfix keywords"
 199     (eq? #:keyword0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789
 200          (with-read-options '(keywords postfix)
 201            (lambda ()
 202              (read-string "keyword0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789:")))))
 203   (pass-if "`:' is not a postfix keyword (per SRFI-88)"
 204     (eq? ':
 205          (with-read-options '(keywords postfix)
 206            (lambda ()
 207              (read-string ":")))))
 208   (pass-if "no positions"
 209     (let ((sexp (with-read-options '()
 210                   (lambda ()
 211                     (read-string "(+ 1 2 3)")))))
 212       (and (not (source-property sexp 'line))
 213            (not (source-property sexp 'column)))))
 214   (pass-if "positions"
 215     (let ((sexp (with-read-options '(positions)
 216                   (lambda ()
 217                     (read-string "(+ 1 2 3)")))))
 218       (and (equal? (source-property sexp 'line) 0)
 219            (equal? (source-property sexp 'column) 0))))
 220   (pass-if "positions on quote"
 221     (let ((sexp (with-read-options '(positions)
 222                   (lambda ()
 223                     (read-string "'abcde")))))
 224       (and (equal? (source-property sexp 'line) 0)
 225            (equal? (source-property sexp 'column) 0)))))
 226
 227 (with-test-prefix "#;"
 228   (for-each
 229    (lambda (pair)
 230      (pass-if (car pair)
 231        (equal? (with-input-from-string (car pair) read) (cdr pair))))
 232
 233    '(("#;foo 10". 10)
 234      ("#;(10 20 30) foo" . foo)
 235      ("#;   (10 20 30) foo" . foo)
 236      ("#;\n10\n20" . 20)))
 237
 238   (pass-if "#;foo"
 239     (eof-object? (with-input-from-string "#;foo" read)))
 240
 241   (pass-if-exception "#;"
 242     exception:missing-expression
 243     (with-input-from-string "#;" read))
 244   (pass-if-exception "#;("
 245     exception:eof
 246     (with-input-from-string "#;(" read)))
 247
 248 (with-test-prefix "#'"
 249   (for-each
 250    (lambda (pair)
 251      (pass-if (car pair)
 252        (equal? (with-input-from-string (car pair) read) (cdr pair))))
 253
 254    '(("#'foo". (syntax foo))
 255      ("#`foo" . (quasisyntax foo))
 256      ("#,foo" . (unsyntax foo))
 257      ("#,@foo" . (unsyntax-splicing foo)))))
 258
 259