;;;; read.scm
;
; misc error syntax


(define %case-sensitive
  (let ((f #t))				; not R5RS compliant but simply the right thing to do
    (lambda arg
      (if (pair? arg)
	  (set! f (car arg))
	  f))))

(define %read
  (let ((read-char read-char)
	(reverse reverse)
	(peek-char peek-char)
	(list->vector list->vector)
	(list->string list->string)
	(case-sensitive %case-sensitive)
	(string->number string->number))
    (lambda port
      (let ((port (optional port %input-port))
	    (cs (case-sensitive))
	    (eol (lambda (c) (error "unexpected delimiter" c))))
	(define (parse-token t)
	  (or (string->number t)
	      (string->symbol t)))
	(define (read1)
	  (let ((c (read-char port)))
	    (if (eof-object? c) 
		c
		(case c
		  ((#\#) (read-sharp))
		  ((#\() (read-list #\)))
		  ((#\[) (read-list #\]))
		  ((#\{) (read-list #\}))
		  ((#\,)
		   (cond ((eqv? (peek-char port) #\@)
			  (read-char port)
			  (list 'unquote-splicing (read1)))
			 (else (list 'unquote (read1)))))
		  ((#\`) (list 'quasiquote (read1)))
		  ((#\') `',(read1))
		  ((#\;) (skip-line) (read1))
		  ((#\") (read-string))
		  ((#\|) (read-xsymbol))
		  ((#\) #\] #\}) (eol c))
		  (else
		   (if (char-whitespace? c)
		       (read1)
		       (parse-token (read-token (list (docase c)) cs))))))))
	(define (skip-line)
	  (let ((c (read-char port)))
	    (unless (or (eof-object? c) (char=? #\newline c))
	      (skip-line))))
	(define (skip-whitespace)	; returns peeked char
	  (let ((c (peek-char port)))
	    (cond ((eof-object? c) c)
		  ((char-whitespace? c)
		   (read-char port)
		   (skip-whitespace))
		  (else c))))
	(define (read-sharp)
	  (let ((c (read-char port)))
	    (if (eof-object? c)
		(error "unexpected EOF after `#'")
		(case c
		  ((#\f #\F) #f)
		  ((#\t #\T) #t)
		  ((#\x #\X) (string->number (read-token '() #f) 16))
		  ((#\o #\O) (string->number (read-token '() #f) 8))
		  ((#\b #\B) (string->number (read-token '() #f) 2))
		  ((#\i #\I) 
		   (let* ((tok (read-token '() #f))
			  (n (string->number tok)))
		     (cond ((not (number? n)) (error "invalid number syntax" tok))
			   ((inexact? n) n)
			   (else (exact->inexact n)))))
		  ((#\e #\E) 
		   (let* ((tok (read-token '() #f))
			  (n (string->number tok)))
		     (cond ((not (number? n)) (error "invalid number syntax" tok))
			   ((exact? n) n)
			   (else (inexact->exact n)))))
		  ((#\() (list->vector (read-list #\))))
		  ((#\;) (read1) (read1))
		  ((#\%) (string->symbol (read-token (list (docase c) #\#) cs)))
		  ((#\!) (skip-line) (read1))
		  ((#\\) 
		   (let ((t (read-token '() #t)))
		     (cond ((string-ci=? "newline" t) #\newline)
			   ((string-ci=? "tab" t) #\tab)
			   ((string-ci=? "space" t) #\space)
			   ((string-ci=? "return" t) #\return)
			   ((zero? (string-length t))
			    (read-char port))
			   (else (string-ref t 0)))))
		  ((#\') `(syntax ,(read1))) ; for v-t-ex
		  (else (error "invalid `#' syntax" c))))))
	(define (read-list delim)
	  (%call-with-exit-continuation
	   (lambda (return)
	     (let ((lst '())
		   (old eol))
	       (set! eol
		 (lambda (c)
		   (set! eol old)
		   (if (eqv? c delim)
		       (return (reverse lst))
		       (error "missing closing delimiter" delim))))
	       (let loop ()
		 (let ((c (skip-whitespace)))
		   (cond ((eof-object? c)
			  (error "unexpected EOF while reading list"))
			 ((char=? c delim)
			  (read-char port)
			  (set! eol old)
			  (return (reverse lst)))
			 (else
			  (if (eqv? #\. c)
			      (let ((t (read-token '() cs)))
				(if (string=? "." t)
				    (let ((rest (read1)))
				      (skip-whitespace)
				      (set! eol old)
				      (if (eqv? (read-char port) delim)
					  (return (append (reverse lst) rest))
					  (error "missing closing delimiter" 
						 delim)))
				    (set! lst (cons (parse-token t) lst))))
			      (set! lst (cons (read1) lst)))
			  (loop)))))))))
	(define (read-string)
	  (let loop ((lst '()))
	    (let ((c (read-char port)))
	      (cond ((eof-object? c)
		     (error "unexpected EOF while reading string"))
		    ((char=? #\" c) 
		     (list->string (reverse lst)))
		    ((char=? #\\ c)
		     (let ((c (read-char port)))
		       (if (eof-object? c)
			   (error "unexpected EOF while reading string")
			   (case c
			     ((#\n) (loop (cons #\newline lst)))
			     ((#\r) (loop (cons #\return lst)))
			     ((#\t) (loop (cons #\tab lst)))
			     (else (loop (cons c lst)))))))
		    (else (loop (cons c lst)))))))
	(define (read-xsymbol)
	  (let loop ((lst '()))
	    (let ((c (read-char port)))
	      (cond ((eof-object? c)
		     (error "unexpected EOF while reading extended symbol"))
		    ((char=? #\| c) 
		     (string->symbol (list->string (reverse lst))))
		    ((char=? #\\ c)
		     (let ((c (read-char port)))
		       (if (eof-object? c)
			   (error "unexpected EOF while reading extended symbol")
			   (loop (cons c lst)))))
		    (else (loop (cons c lst)))))))
	(define (docase c)
	  (if cs
	      c
	      (char-downcase c)))
	(define (read-token prefix cs)
	  (let loop ((lst prefix))   ; prefix must be in reverse order
	    (let ((c (peek-char port)))
	      (if (or (eof-object? c) 
		      (memv c '(#\{ #\} #\( #\) #\[ #\] #\; #\"))
		      (char-whitespace? c))
		  (list->string (reverse lst))
		  (loop (cons ((if cs id docase) (read-char port)) lst))))))
	(read1)))))