
(load-relative "loadtest.ss")

(SECTION 'READTABLE)

(require (rename (lib "port.ss") relocate-input-port relocate-input-port))
(define (shift-rt-port p deltas)
  (let ([p (relocate-input-port p 
				(add1 (car deltas))
				(cadr deltas)
				(add1 (caddr deltas)))])
    (port-count-lines! p)
    p))
	
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Basic readtable tests

(arity-test make-readtable 1 -1)
(arity-test readtable? 1 1)
(arity-test readtable-mapping 2 2)

(err/rt-test (make-readtable 5))
(err/rt-test (make-readtable #f 5))
(err/rt-test (make-readtable #f #\a))
(err/rt-test (make-readtable #f #\a 5))
(err/rt-test (make-readtable #f #\a #\b))
(err/rt-test (make-readtable #f #\a 'terkminating-macro))

(test #f current-readtable)
(test #t readtable? (make-readtable #f))
(test #t readtable? (make-readtable (make-readtable #f)))

(let ([plain-dollar
       (case-lambda
	[(ch port)
	 (test #t ormap (lambda (x) (char=? ch x)) '(#\$ #\&))
	 `dollar]
	[(ch port src line col pos)
	 (test #t ormap (lambda (x) (char=? ch x)) '(#\$ #\&))
	 `dollar])]
      [plain-percent
       (case-lambda
	[(ch port)
	 (test #\% values ch)
	 `(percent ,(read/recursive port))]
	[(ch port src line col pos)
	 (test #\% values ch)
	 (test 'string values src)
	 `(percent ,(read-syntax/recursive src port))])]
      [hash-dollar
       (case-lambda
	[(ch port)
	 (test #\$ values ch)
	 `(dollar . ,(read/recursive port))]
	[(ch port src line col pos)
	 (test #\$ values ch)
	 `(dollar . ,(read-syntax/recursive src port))])]
      [comment3
       (case-lambda
	[(ch port src line col pos)
	 (test #\_ values ch)
	 (read-char port) (read-char port) (read-char port)
	 (make-special-comment #f)])])
  (let ([t (make-readtable #f 
			   #\$ 'terminating-macro plain-dollar
			   #\% 'non-terminating-macro plain-percent
			   #\^ #\| #f
			   #\< #\( #f
			   #\= #\\ #f
			   #\~ #\space #f
			   #\_ 'terminating-macro comment3
			   #\$ 'dispatch-macro  hash-dollar)])
    (test-values '(#\a #f #f) (lambda () (readtable-mapping t #\a)))
    (test-values '(#\| #f #f) (lambda () (readtable-mapping t #\^)))
    (test-values '(#\( #f #f) (lambda () (readtable-mapping t #\<)))
    (test-values '(#\\ #f #f) (lambda () (readtable-mapping t #\=)))
    (test-values '(#\space #f #f) (lambda () (readtable-mapping t #\~)))
    (test-values (list 'terminating-macro plain-dollar hash-dollar) (lambda () (readtable-mapping t #\$)))
    (test-values (list 'terminating-macro comment3 #f) (lambda () (readtable-mapping t #\_)))
    (test-values (list 'non-terminating-macro plain-percent #f) (lambda () (readtable-mapping t #\%)))
    (let ([t2 (make-readtable t
			      #\& #\$ t
			      #\a #\a t
			      #\^ #\^ #f)])
      (test-values '(#\a #f #f) (lambda () (readtable-mapping t2 #\a)))
      (test-values '(#\^ #f #f) (lambda () (readtable-mapping t2 #\^)))
      (test-values '(#\space #f #f) (lambda () (readtable-mapping t #\~)))
      (test-values (list 'terminating-macro plain-dollar #f) (lambda () (readtable-mapping t2 #\&)))

      (letrec ([test-read
		(case-lambda 
		 [(s l check-pos?)
		  (define (go read)
		    (let* ([o (open-input-string s)])
		      (port-count-lines! o)
		      (let loop ()
			(let ([v (read o)])
			  (if (eof-object? v)
			      null
			      (cons v (loop)))))))
		  (test l (lambda (a b) (go read)) 'read s)
		  (test l (lambda (a b) (map syntax-object->datum 
					     (go (lambda (p) (read-syntax 'string p)))))
			'read-syntax s)
		  (when check-pos?
		    (let ([stx (car (go (lambda (p) (read-syntax 'string (shift-rt-port p (list 1 2 3))))))])
		      (test 2 syntax-line stx)
		      (test 2 syntax-column stx)
		      (test 4 syntax-position stx)))]
		 [(s l) (test-read s l #t)])])
	
	(test-read "a$%_^b" '(a$%_^b))

	(let ([try-table
	       (lambda (t old-caret?)
		 (parameterize ([current-readtable t])
		   (test-read "a$b" '(a dollar b))
		   (when old-caret?
		     (test-read "a&b" '(a dollar b)))
		   (test-read "a #$ b" '(a (dollar . b)))
		   (test-read "(#1=a #$ #1#)" '((a (dollar . a))))
		   (test-read "(#1=a #$ (#1#))" '((a (dollar a))))
		   (test-read "a%b" '(a%b))
		   (test-read "a % b" '(a (percent b)))
		   (test-read "(#1=a % #1#)" '((a (percent a))))
		   (test-read "(#1=a % (#1#))" '((a (percent (a)))))
		   (test-read "a _xxx b" '(a b))
		   (test-read "(a _xxx b)" '((a b)))
		   (test-read "(a _xxx . b)" '((a . b)))
		   (test-read "(a . _xxx b)" '((a . b)))
		   (if old-caret?
		       (test-read "(a ^_xxx^ b)" '((a ^ ^ b)))
		       (test-read "(a ^_xxx^ b)" '((a _xxx b))))
		   (test-read "(a =_xxx b)" '((a _xxx b)))
		   (test-read "<a xxx b)" '((a xxx b)))
		   (test-read "<a~xxx~b)" '((a xxx b)))))])
	  (try-table t #f)
	  (try-table t2 #t))

	(let ([try-as-plain (lambda (ch)
			      (parameterize ([current-readtable (make-readtable #f
										ch #\a #f)])
				(let ([s1 (format "a~ab" ch)]
				      [s2 (format "~aab~a" ch ch)])
				  (test-read s1 (list (string->symbol s1)))
				  (test-read s2 (list (string->symbol s2)) #f)
				  (let ([blank (if (char=? ch #\space)
						   #\newline
						   #\space)])
				    (test-read (format "a~a~a~ab" blank ch blank) 
					       (list 'a (string->symbol (string ch)) 'b))))))])
	  (for-each try-as-plain (string->list "()[]{}|\\ \r\n\t\v',\"#")))

	;; Check /recursive functions with pre char and initial readtable
	(for-each
	 (lambda (base-readtable swap?)
	   (for-each
	    (lambda (read/recursive)
	      (let ([t (make-readtable #f 
				       #\~ 'terminating-macro (lambda (ch port src line col pos)
								(define read/rec
								  (if src
								      (lambda (port char readtable)
									(read-syntax/recursive 
									 src port
									 char readtable))
								      read/recursive))
								(if (eq? (char=? #\! (peek-char port)) (not swap?))
								    (read/rec port #\( base-readtable)
								    (read/rec port #\{ base-readtable))))])
		(parameterize ([current-readtable t])
		  (test-read "~!a (b))" `((!a (b))))
		  (test-read "~?a (b)}" `((?a (b)))))))
	    (list read/recursive (lambda (port char readtable)
				   (read-syntax/recursive 'ok port char readtable)))))
	 (list #f (make-readtable #f
				  #\! 'terminating-macro (lambda (ch port src line col pos) (error 'ack))
				  #\? 'terminating-macro (lambda (ch port src line col pos) (error 'ack))
				  #\( #\{ #f
				  #\{ #\( #f))
	 (list #f #t))
	
	(void)))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Make sure we can't expose fixup process for graphs and cycles

(let ([result #f]
      [mk (lambda (v)
	    `(,v ,(vector v) ,(box v) ,(let ([ht (make-hash-table)])
					 (hash-table-put! ht v v)
					 ht)))])
  (let ([get-zero
	 (case-lambda
	  [(ch port)
	   (let ([v (read/recursive (open-input-string "#0#"))])
	     (set! result (mk v))
	     result)]
	  [(ch port src line col pos)
	   (let ([v (read-syntax/recursive src (open-input-string "#0#"))])
	     (set! result (datum->syntax-object #f (mk v) #f))
	     result)])])
    (let ([t (make-readtable #f 
			     #\$ 'terminating-macro get-zero)])
      (let ([go
	     (lambda (read car cadr caddr cadddr unbox vector-ref hash-table-map
			   list? vector? box? hash-table?)
	       (let ([v (parameterize ([current-readtable t])
			  (read (open-input-string "#0=$")))])
		 (test #t list? v)
		 (test #t list? (car v))
		 (test #t vector? (cadr v))
		 (test #t box? (caddr v))
		 (test #t hash-table? (cadddr v))
		 (test #t eq? v (car v))
		 (test #t eq? v (vector-ref (cadr v) 0))
		 (test #t eq? v (unbox (caddr v)))
		 (test #f memq v (hash-table-map (cadddr v) (lambda (k v) k)))
		 (test #f memq v (hash-table-map (cadddr v) (lambda (k v) v)))
		 (test #f eq? v result)))])
	(go read car cadr caddr cadddr unbox vector-ref hash-table-map
	    list? vector? box? hash-table?)
	(go (lambda (p) (read-syntax 'string p))
	    (lambda (stx) (car (syntax->list stx))) 
	    (lambda (stx) (cadr (syntax->list stx))) 
	    (lambda (stx) (caddr (syntax->list stx))) 
	    (lambda (stx) (cadddr (syntax->list stx))) 
	    (lambda (stx) (unbox (syntax-e stx)))
	    (lambda (stx p) (vector-ref  (syntax-e stx) p))
	    (lambda (stx f) (hash-table-map (syntax-e stx) f))
	    (lambda (stx) (and (syntax->list stx) #t))
	    (lambda (stx) (vector? (syntax-e stx)))
	    (lambda (stx) (box? (syntax-e stx)))
	    (lambda (stx) (hash-table? (syntax-e stx))))))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check that sharing is preserved
	    
(let ([get-graph
       (case-lambda
	[(ch port) '#0=(#0#)]
	[(ch port src line col pos)
	 (datum->syntax-object #f '#1=(#1#) #f)])])
  (let ([t (make-readtable #f 
			   #\$ 'terminating-macro get-graph)])
    (let ([go
	   (lambda (read car)
	     (let ([v (parameterize ([current-readtable t])
			(read (open-input-string "$")))])
	       ;; Check that cycle is preserved by unrolling lots
	       (test #f boolean? (car (car (car (car v)))))))])
      (go read car)
      (go (lambda (p) (read-syntax 'string p))
	  (lambda (stx) (car (syntax->list stx)))))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(report-errs)
