;;;; reader.test --- Reader test. -*- coding: iso-8859-1; mode: scheme -*-
;;;;
-;;;; Copyright (C) 1999, 2001, 2002, 2003, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001-2003, 2007-2011, 2013-2015
+;;;; Free Software Foundation, Inc.
+;;;;
;;;; Jim Blandy <jimb@red-bean.com>
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
-;;;;
+;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
-;;;;
+;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(cons 'read-error "end of file$"))
(define exception:unexpected-rparen
(cons 'read-error "unexpected \")\"$"))
+(define exception:unexpected-rsqbracket
+ (cons 'read-error "unexpected \"]\"$"))
(define exception:unterminated-block-comment
(cons 'read-error "unterminated `#. \\.\\.\\. .#' comment$"))
(define exception:unknown-character-name
(cons 'read-error "Unknown # object: .*$"))
(define exception:eof-in-string
(cons 'read-error "end of file in string constant$"))
+(define exception:eof-in-symbol
+ (cons 'read-error "end of file while reading symbol$"))
(define exception:illegal-escape
(cons 'read-error "illegal character in escape sequence: .*$"))
(define exception:missing-expression
(cons 'read-error "no expression after #;"))
+(define exception:mismatched-paren
+ (cons 'read-error "mismatched close paren"))
(define (read-string s)
- (with-fluids ((%default-port-encoding #f))
- (with-input-from-string s (lambda () (read)))))
+ (with-input-from-string s (lambda () (read))))
(define (with-read-options opts thunk)
(let ((saved-options (read-options)))
(equal? (read-string "1+i+i") '1+i+i))
(pass-if "1+e10000i"
(equal? (read-string "1+e10000i") '1+e10000i))
+ (pass-if "-nan.0-1i"
+ (not (equal? (imag-part (read-string "-nan.0-1i"))
+ (imag-part (read-string "-nan.0+1i")))))
+
+ (pass-if-equal "'\|' in string literals"
+ "a|b"
+ (read-string "\"a\\|b\""))
+
+ (pass-if-equal "'(' in string literals"
+ "a(b"
+ (read-string "\"a\\(b\""))
+
+ (pass-if-equal "#\\escape"
+ '(a #\esc b)
+ (read-string "(a #\\escape b)"))
+
+ (pass-if-equal "#true"
+ '(a #t b)
+ (read-string "(a #true b)"))
+
+ (pass-if-equal "#false"
+ '(a #f b)
+ (read-string "(a #false b)"))
;; At one time the arg list for "Unknown # object: ~S" didn't make it out
;; of read.c. Check that `format' can be applied to this error.
(equal? '(+ 2)
(read-string "(+ 2 #! a comment\n!#\n) ")))
+ (pass-if "R6RS lexeme comment"
+ (equal? '(+ 1 2 3)
+ (read-string "(+ 1 #!r6rs 2 3)")))
+
+ (pass-if "partial R6RS lexeme comment"
+ (equal? '(+ 1 2 3)
+ (read-string "(+ 1 #!r6r !# 2 3)")))
+
(pass-if "R6RS/SRFI-30 block comment"
(equal? '(+ 1 2 3)
(read-string "(+ 1 #| this is a\ncomment |# 2 3)")))
(equal? '(a b c)
(read-string "(a b c #| d #| e |# f |#)")))
+ (pass-if "R6RS/SRFI-30 nested block comment (2)"
+ (equal? '(a b c)
+ (read-string "(a b c #|||||||#)")))
+
+ (pass-if "R6RS/SRFI-30 nested block comment (3)"
+ (equal? '(a b c)
+ (read-string "(a b c #||||||||#)")))
+
(pass-if "R6RS/SRFI-30 block comment syntax overridden"
;; To be compatible with 1.8 and earlier, we should be able to override
;; this syntax.
- (let ((rhp read-hash-procedures))
- (dynamic-wind
- (lambda ()
- (read-hash-extend #\| (lambda args 'not)))
- (lambda ()
- (fold (lambda (x y result)
- (and result (eq? x y)))
- #t
- (read-string "(this is #| a comment)")
- `(this is not a comment)))
- (lambda ()
- (set! read-hash-procedures rhp)))))
-
+ (with-fluids ((%read-hash-procedures (fluid-ref %read-hash-procedures)))
+ (read-hash-extend #\| (lambda args 'not))
+ (fold (lambda (x y result)
+ (and result (eq? x y)))
+ #t
+ (read-string "(this is #| a comment)")
+ `(this is not a comment))))
+
(pass-if "unprintable symbol"
;; The reader tolerates unprintable characters for symbols.
(equal? (string->symbol "\x01\x02\x03")
;; mutable objects.
(let ((str (with-input-from-string "\"hello, world\"" read)))
(string-set! str 0 #\H)
- (string=? str "Hello, world"))))
+ (string=? str "Hello, world")))
+
+ (pass-if "square brackets are parens"
+ (equal? '() (read-string "[]")))
+
+ (pass-if-exception "paren mismatch" exception:unexpected-rparen
+ (read-string "'[)"))
+
+ (pass-if-exception "paren mismatch (2)" exception:unexpected-rsqbracket
+ (read-string "'(]"))
+
+ (pass-if-exception "paren mismatch (3)" exception:mismatched-paren
+ (read-string "'(foo bar]"))
+
+ (pass-if-exception "paren mismatch (4)" exception:mismatched-paren
+ (read-string "'[foo bar)")))
+
\f
(pass-if-exception "radix passed to number->string can't be zero"
(pass-if-exception "closing parenthesis following mismatched opening"
exception:unexpected-rparen
(read-string ")"))
+ (pass-if-exception "closing square bracket following mismatched opening"
+ exception:unexpected-rsqbracket
+ (read-string "]"))
(pass-if-exception "opening vector parenthesis"
exception:eof
(read-string "#("))
(with-read-options '(case-insensitive)
(lambda ()
(read-string "GuiLe")))))
+ (pass-if-equal "r7rs-symbols"
+ (list 'a (string->symbol "Hello, this is | a \"test\"") 'b)
+ (with-read-options '(r7rs-symbols)
+ (lambda ()
+ (read-string "(a |H\\x65;llo, this is \\| a \"test\"| b)"))))
(pass-if "prefix keywords"
(eq? #:keyword
(with-read-options '(keywords prefix case-insensitive)
(equal? (source-property sexp 'column) 0))))
(pass-if "positions on quote"
(let ((sexp (with-read-options '(positions)
- (lambda ()
+ (lambda ()
(read-string "'abcde")))))
(and (equal? (source-property sexp 'line) 0)
- (equal? (source-property sexp 'column) 0)))))
+ (equal? (source-property sexp 'column) 0))))
+ (pass-if "position of SCSH block comment"
+ ;; In Guile 2.0.0 the reader would not update the port's position
+ ;; when reading an SCSH block comment.
+ (let ((sexp (with-read-options '(positions)
+ (lambda ()
+ (read-string "#!foo\nbar\nbaz\n!#\n(hello world)\n")))))
+ (= 4 (source-property sexp 'line))))
+
+ (with-test-prefix "r6rs-hex-escapes"
+ (pass-if-exception "non-hex char in two-digit hex-escape"
+ exception:illegal-escape
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (with-input-from-string "\"\\x0g;\"" read))))
+
+ (pass-if-exception "non-hex char in four-digit hex-escape"
+ exception:illegal-escape
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (with-input-from-string "\"\\x000g;\"" read))))
+
+ (pass-if-exception "non-hex char in six-digit hex-escape"
+ exception:illegal-escape
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (with-input-from-string "\"\\x00000g;\"" read))))
+
+ (pass-if-exception "no semicolon at termination of one-digit hex-escape"
+ exception:illegal-escape
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (with-input-from-string "\"\\x0\"" read))))
+
+ (pass-if-exception "no semicolon at termination of three-digit hex-escape"
+ exception:illegal-escape
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (with-input-from-string "\"\\x000\"" read))))
+
+ (pass-if "two-digit hex escape"
+ (eqv?
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (string-ref (with-input-from-string "\"--\\xff;--\"" read) 2)))
+ (integer->char #xff)))
+
+ (pass-if "four-digit hex escape"
+ (eqv?
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (string-ref (with-input-from-string "\"--\\x0100;--\"" read) 2)))
+ (integer->char #x0100)))
+
+ (pass-if "six-digit hex escape"
+ (eqv?
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (string-ref (with-input-from-string "\"--\\x010300;--\"" read) 2)))
+ (integer->char #x010300)))
+
+ (pass-if "escaped characters match non-escaped ASCII characters"
+ (string=?
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (with-input-from-string "\"\\x41;\\x0042;\\x000043;\"" read)))
+ "ABC"))
+
+ (pass-if "write R6RS string escapes"
+ (let* ((s1 (apply string
+ (map integer->char '(#x8 ; backspace
+ #x18 ; cancel
+ #x20 ; space
+ #x30 ; zero
+ #x40 ; at sign
+ ))))
+ (s2 (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (with-output-to-string
+ (lambda () (write s1)))))))
+ (lset= eqv?
+ (string->list s2)
+ (list #\" #\\ #\b #\\ #\x #\1 #\8 #\; #\space #\0 #\@ #\"))))
+
+ (pass-if "display R6RS string escapes"
+ (string=?
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (let ((pt (open-output-string))
+ (s1 (apply string (map integer->char
+ '(#xFF #x100 #xFFF #x1000 #xFFFF #x10000)))))
+ (set-port-encoding! pt "ASCII")
+ (set-port-conversion-strategy! pt 'escape)
+ (display s1 pt)
+ (get-output-string pt))))
+ "\\xff;\\x100;\\xfff;\\x1000;\\xffff;\\x10000;"))
+
+ (pass-if "one-digit hex escape"
+ (eqv? (with-input-from-string "#\\xA" read)
+ (integer->char #x0A)))
+
+ (pass-if "two-digit hex escape"
+ (eqv? (with-input-from-string "#\\xFF" read)
+ (integer->char #xFF)))
+
+ (pass-if "four-digit hex escape"
+ (eqv? (with-input-from-string "#\\x00FF" read)
+ (integer->char #xFF)))
+
+ (pass-if "eight-digit hex escape"
+ (eqv? (with-input-from-string "#\\x00006587" read)
+ (integer->char #x6587)))
+
+ (pass-if "write R6RS escapes"
+ (string=?
+ (with-read-options '(r6rs-hex-escapes)
+ (lambda ()
+ (with-output-to-string
+ (lambda ()
+ (write (integer->char #x80))))))
+ "#\\x80")))
+
+ (with-test-prefix "hungry escapes"
+ (pass-if "default not hungry"
+ ;; Assume default setting of not hungry.
+ (equal? (with-input-from-string "\"foo\\\n bar\""
+ read)
+ "foo bar"))
+ (pass-if "hungry"
+ (dynamic-wind
+ (lambda ()
+ (read-enable 'hungry-eol-escapes))
+ (lambda ()
+ (equal? (with-input-from-string "\"foo\\\n bar\""
+ read)
+ "foobar"))
+ (lambda ()
+ (read-disable 'hungry-eol-escapes))))))
+
+(with-test-prefix "per-port-read-options"
+ (pass-if "case-sensitive"
+ (equal? '(guile GuiLe gUIle)
+ (with-read-options '(case-insensitive)
+ (lambda ()
+ (with-input-from-string "GUIle #!no-fold-case GuiLe gUIle"
+ (lambda ()
+ (list (read) (read) (read))))))))
+ (pass-if "case-insensitive"
+ (equal? '(GUIle guile guile)
+ (with-input-from-string "GUIle #!fold-case GuiLe gUIle"
+ (lambda ()
+ (list (read) (read) (read)))))))
(with-test-prefix "#;"
(for-each
("#;(10 20 30) foo" . foo)
("#; (10 20 30) foo" . foo)
("#;\n10\n20" . 20)))
-
+
(pass-if "#;foo"
(eof-object? (with-input-from-string "#;foo" read)))
-
+
(pass-if-exception "#;"
exception:missing-expression
(with-input-from-string "#;" read))
("#,foo" . (unsyntax foo))
("#,@foo" . (unsyntax-splicing foo)))))
+(with-test-prefix "#{}#"
+ (pass-if (equal? (read-string "#{}#") '#{}#))
+ (pass-if (not (equal? (read-string "(a #{.}# b)") '(a . b))))
+ (pass-if (equal? (read-string "#{a}#") 'a))
+ (pass-if (equal? (read-string "#{a b}#") '#{a b}#))
+ (pass-if-exception "#{" exception:eof-in-symbol
+ (read-string "#{"))
+ (pass-if (equal? (read-string "#{a\\x20;b}#") '#{a b}#)))
+
+(begin-deprecated
+ (with-test-prefix "deprecated #{}# escapes"
+ (pass-if (equal? (read-string "#{a\\ b}#") '#{a b}#))))
+;;; Local Variables:
+;;; eval: (put 'with-read-options 'scheme-indent-function 1)
+;;; End:
HCoop / bpt / guile.git / blobdiff