;;;; reader.test --- Exercise the reader.               -*- Scheme -*-
;;;;
;;;; Copyright (C) 1999, 2001, 2002, 2003, 2007, 2008 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 2.1 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

(define-module (test-suite reader)
  :use-module (test-suite lib))


(define exception:eof
  (cons 'read-error "end of file$"))
(define exception:unexpected-rparen
  (cons 'read-error "unexpected \")\"$"))
(define exception:unterminated-block-comment
  (cons 'read-error "unterminated `#! ... !#' comment$"))
(define exception:unknown-character-name
  (cons 'read-error "unknown character name .*$"))
(define exception:unknown-sharp-object
  (cons 'read-error "Unknown # object: .*$"))
(define exception:eof-in-string
  (cons 'read-error "end of file in string constant$"))
(define exception:illegal-escape
  (cons 'read-error "illegal character in escape sequence: .*$"))
(define exception:missing-expression
  (cons 'read-error "no expression after #;"))


(define (read-string s)
  (with-input-from-string s (lambda () (read))))

(define (with-read-options opts thunk)
  (let ((saved-options (read-options)))
    (dynamic-wind
        (lambda ()
          (read-options opts))
        thunk
        (lambda ()
          (read-options saved-options)))))


(with-test-prefix "reading"
  (pass-if "0"
    (equal? (read-string "0") 0))
  (pass-if "1++i"
    (equal? (read-string "1++i") '1++i))
  (pass-if "1+i+i"
    (equal? (read-string "1+i+i") '1+i+i))
  (pass-if "1+e10000i"
    (equal? (read-string "1+e10000i") '1+e10000i))

  ;; 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.
  (pass-if "error message on bad #"
    (catch #t
	   (lambda ()
	     (read-string "#ZZZ")
	     ;; oops, this # is supposed to be unrecognised
	     #f)
	   (lambda (key subr message args rest)
	     (apply format #f message args)
	     ;; message and args are ok
	     #t)))

  (pass-if "block comment"
    (equal? '(+ 1 2 3)
            (read-string "(+ 1 #! this is a\ncomment !# 2 3)")))

  (pass-if "block comment finishing s-exp"
    (equal? '(+ 2)
            (read-string "(+ 2 #! a comment\n!#\n) ")))

  (pass-if "unprintable symbol"
    ;; The reader tolerates unprintable characters for symbols.
    (equal? (string->symbol "\001\002\003")
            (read-string "\001\002\003")))

  (pass-if "CR recognized as a token delimiter"
    ;; In 1.8.3, character 0x0d was not recognized as a delimiter.
    (equal? (read-string "one\x0dtwo") 'one))

  (pass-if "returned strings are mutable"
    ;; Per R5RS Section 3.4, "Storage Model", `read' is supposed to return
    ;; mutable objects.
    (let ((str (with-input-from-string "\"hello, world\"" read)))
      (string-set! str 0 #\H)
      (string=? str "Hello, world"))))


(pass-if-exception "radix passed to number->string can't be zero"
  exception:out-of-range
  (number->string 10 0))
(pass-if-exception "radix passed to number->string can't be one either"
  exception:out-of-range
  (number->string 10 1))


(with-test-prefix "mismatching parentheses"
  (pass-if-exception "opening parenthesis"
    exception:eof
    (read-string "("))
  (pass-if-exception "closing parenthesis following mismatched opening"
    exception:unexpected-rparen
    (read-string ")"))
  (pass-if-exception "opening vector parenthesis"
    exception:eof
    (read-string "#("))
  (pass-if-exception "closing parenthesis following mismatched vector opening"
     exception:unexpected-rparen
     (read-string ")")))


(with-test-prefix "exceptions"

  ;; Reader exceptions: although they are not documented, they may be relied
  ;; on by some programs, hence these tests.

  (pass-if-exception "unterminated block comment"
    exception:unterminated-block-comment
    (read-string "(+ 1 #! comment\n..."))
  (pass-if-exception "unknown character name"
    exception:unknown-character-name
    (read-string "#\\theunknowncharacter"))
  (pass-if-exception "unknown sharp object"
    exception:unknown-sharp-object
    (read-string "#?"))
  (pass-if-exception "eof in string"
    exception:eof-in-string
    (read-string "\"the string that never ends"))
  (pass-if-exception "illegal escape in string"
    exception:illegal-escape
    (read-string "\"some string \\???\"")))


(with-test-prefix "read-options"
  (pass-if "case-sensitive"
    (not (eq? 'guile 'GuiLe)))
  (pass-if "case-insensitive"
    (eq? 'guile
         (with-read-options '(case-insensitive)
           (lambda ()
             (read-string "GuiLe")))))
  (pass-if "prefix keywords"
    (eq? #:keyword
         (with-read-options '(keywords prefix case-insensitive)
           (lambda ()
             (read-string ":KeyWord")))))
  (pass-if "prefix non-keywords"
    (symbol? (with-read-options '(keywords prefix)
               (lambda ()
                 (read-string "srfi88-keyword:")))))
  (pass-if "postfix keywords"
    (eq? #:keyword
         (with-read-options '(keywords postfix)
           (lambda ()
             (read-string "keyword:")))))
  (pass-if "long postfix keywords"
    (eq? #:keyword0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789
         (with-read-options '(keywords postfix)
           (lambda ()
             (read-string "keyword0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789:")))))
  (pass-if "`:' is not a postfix keyword (per SRFI-88)"
    (eq? ':
         (with-read-options '(keywords postfix)
           (lambda ()
             (read-string ":")))))
  (pass-if "no positions"
    (let ((sexp (with-read-options '()
                  (lambda ()
                    (read-string "(+ 1 2 3)")))))
      (and (not (source-property sexp 'line))
           (not (source-property sexp 'column)))))
  (pass-if "positions"
    (let ((sexp (with-read-options '(positions)
                  (lambda ()
                    (read-string "(+ 1 2 3)")))))
      (and (equal? (source-property sexp 'line) 0)
           (equal? (source-property sexp 'column) 0))))
  (pass-if "positions on quote"
    (let ((sexp (with-read-options '(positions)
                  (lambda ()
                    (read-string "'abcde")))))
      (and (equal? (source-property sexp 'line) 0)
           (equal? (source-property sexp 'column) 0)))))

(with-test-prefix "#;"
  (for-each
   (lambda (pair)
     (pass-if (car pair)
       (equal? (with-input-from-string (car pair) read) (cdr pair))))

   '(("#;foo 10". 10)
     ("#;(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))
  (pass-if-exception "#;("
    exception:eof
    (with-input-from-string "#;(" read)))

(with-test-prefix "#'"
  (for-each
   (lambda (pair)
     (pass-if (car pair)
       (equal? (with-input-from-string (car pair) read) (cdr pair))))

   '(("#'foo". (syntax foo))
     ("#`foo" . (quasisyntax foo))
     ("#,foo" . (unsyntax foo))
     ("#,@foo" . (unsyntax-splicing foo)))))