;;; Lisp reader in Lisp with line numbers
;;; Based on read.scm from s48 distribution, which carries the notice
;;; "Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.
;;;  See file COPYING.", which says non-commercial use permitted

;;; This version Copyright Henry S. Thompson 1996
;;; Alpha version 0.7, not for onward distribution

;;; Produced at HCRC, Edinburgh with support for the UK Economic and Social
;;;  Research Council and SunSoft
;;; Last edited: Wed Aug 14 12:19:22 1996

; A little Scheme reader.

; Nonstandard things used:
;  Ascii stuff: char->ascii, ascii->char, ascii-whitespaces, ascii-limit
;    (for dispatch table; portable definitions in alt/ascii.scm)
;  reverse-list->string  -- ok to define as follows:
;    (define (reverse-list->string l n)
;      (list->string (reverse l)))
;  make-immutable! -- ok to define as follows:
;    (define (make-immutable! x) x)
;  signal (only for use by reading-error; easily excised)

(define line-no
  ;; for error reporting
  0)

(define form-line-tbl '())

(define read-chr
  (lambda (port)
    (let ((chr (read-char port)))
      (if (eof-object? chr)
	  (set! line-no -1)
	(if (char=? chr #\newline)
	    (set! line-no (+ line-no 1))))
      chr)))

(define (d!read . port-option)
  (let ((port (input-port-option port-option)))
    (let loop ()
      (let ((form (sub-read port)))
        (cond ((not (reader-token? form)) form)
              ((eq? form close-paren)
               ;; Too many right parens.
               (warn "discarding extraneous right parenthesis")
               (loop))
              (else
               (reading-error port (cdr form))))))))

(define (sub-read-carefully port)
  (let ((form (sub-read port)))
    (cond ((eof-object? form)
           (reading-error port "unexpected end of file"))
          ((reader-token? form) (reading-error port (cdr form)))
          (else form))))

(define reader-token-marker (list 'reader-token))
(define (make-reader-token message) (cons reader-token-marker message))
(define (reader-token? form)
  (and (pair? form) (eq? (car form) reader-token-marker)))

(define close-paren (make-reader-token "unexpected right parenthesis"))
(define dot         (make-reader-token "unexpected \" . \""))


; Main dispatch

(define (sub-read port)
  (let ((c (read-chr port))
        (l line-no))
    (if (eof-object? c)
        c
        (let ((val ((vector-ref read-dispatch-vector (char->ascii c))
                    c port)))
	  (if (not (and (pair? form-line-tbl)
			(eq? val (caar form-line-tbl))
			;; more accurate this way ? (= l (cdar form-line-tbl))
			))
	      (set! form-line-tbl (cons (cons val l) form-line-tbl)))
          val))))

(define read-dispatch-vector
  (make-vector ascii-limit
               (lambda (c port)
                 (reading-error port "illegal character read" c))))

(define read-terminating?-vector
  (make-vector ascii-limit #t))

(define (set-standard-syntax! char terminating? reader)
  (vector-set! read-dispatch-vector     (char->ascii char) reader)
  (vector-set! read-terminating?-vector (char->ascii char) terminating?))

(let ((sub-read-whitespace
       (lambda (c port)
         c                              ;ignored
         (sub-read port))))
  (for-each (lambda (c)
              (vector-set! read-dispatch-vector c sub-read-whitespace))
            ascii-whitespaces))

(let ((sub-read-constituent
       (lambda (c port)
         (parse-token (sub-read-token c port) port))))
  (for-each (lambda (c)
              (set-standard-syntax! c #f sub-read-constituent))
            (string->list
             (string-append "!$%&*+-./0123456789:<=>?@^_~ABCDEFGHIJKLM"
                            "NOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"))))

; Usual read macros

(define (set-standard-read-macro! c terminating? proc)
  (set-standard-syntax! c terminating? proc))

(define (sub-read-list c port)
  (sub-read-list-at c port line-no))

(define (sub-read-list-at c port l)
  (let ((form (sub-read port)))
    (cond ((eof-object? form)
           (reading-error port
                          (list "end of file inside list"
                                "unbalanced left paren on line"
                                l)))
          ((eq? form close-paren) '())
          ((eq? form dot)
           (let* ((last-form (sub-read-carefully port))
                  (another-form (sub-read port)))
             (cond ((eq? another-form close-paren) last-form)
                   (else
                    (reading-error port
                                   "randomness after form after dot"
                                   another-form)))))
          (else (cons form (sub-read-list-at c port l))))))

(set-standard-read-macro! #\( #t sub-read-list)

(set-standard-read-macro! #\) #t
  (lambda (c port)
    c port
    close-paren))

(set-standard-read-macro! #\' #t
  (lambda (c port)
    c
    (list 'quote (sub-read-carefully port))))

(set-standard-read-macro! #\` #t
  (lambda (c port)
    c
    (list 'quasiquote (sub-read-carefully port))))

(set-standard-read-macro! #\, #t
  (lambda (c port)
    c
    (let* ((next (peek-char port))
           ;; DO NOT beta-reduce!
           (keyword (cond ((eof-object? next)
                           (reading-error port "end of file after ,"))
                          ((char=? next #\@)
                           (read-char port)
                           'unquote-splicing)
                          (else 'unquote))))
      (list keyword
            (sub-read-carefully port)))))

(set-standard-read-macro! #\" #t
  (lambda (c port)
    c ;ignored
    (let loop ((l '()) (i 0))
      (let ((c (read-chr port)))
        (cond ((eof-object? c)
               (reading-error port "end of file within a string"))
              ((char=? c #\\)
               (let ((c (read-chr port)))
                 (cond ((eof-object? c)
                        (reading-error port "end of file within a string"))
                       ((or (char=? c #\\) (char=? c #\"))
                        (loop (cons c l) (+ i 1)))
                       ;; should handle character names here . . .
                       (else
;;;                        (reading-error port
;;;                                       "invalid escaped character in string"
;;;                                       c)
                        (loop (cons c (cons #\\ l)) (+ i 2))))))
              ((char=? c #\")
               (reverse-list->string l i))
              (else
               (loop (cons c l) (+ i 1))))))))

(set-standard-read-macro! #\; #t
  (lambda (c port)
    c ;ignored
    (gobble-line port)
    (sub-read port)))

(define (gobble-line port)
  (let loop ()
    (let ((c (read-char port)))
      (cond ((eof-object? c) c)
            ((char=? c #\newline)
	     (set! line-no (+ line-no 1)))
            (else (loop))))))

(define *sharp-macros* '())

(define (define-sharp-macro c proc)
  (set! *sharp-macros* (cons (cons c proc) *sharp-macros*)))

(set-standard-read-macro! #\# #f
  (lambda (c port)
    c ;ignored
    (let* ((c (peek-char port))
           (probe (assq c *sharp-macros*)))
      (if (eof-object? c)
	  (reading-error port "end of file after #"))
      (if probe
          ((cdr probe) c port)
          (reading-error port "unknown # syntax" c)))))

(define-sharp-macro #\f
  (lambda (c port) (read-char port) #f))

(define-sharp-macro #\t
  (lambda (c port) (read-char port) #t))

(define-sharp-macro #\A
  (lambda (c port)
    (read-char port)
    (let ((c (peek-char port)))
      (cond ((eof-object? c)
	     (reading-error port "end of file after #A"))
	    (else
	     (let ((str (sub-read-token (read-chr port) port)))
	       (cond
		((string->number str)
		 =>
		 (lambda (n) (list 'd!g n)))
		(else
		 (reading-error port "Expected number after #A" str)))))))))

(define-sharp-macro #\\
  (lambda (c port)
    (read-char port)
    (let ((c (peek-char port)))
      (cond ((eof-object? c)
             (reading-error port "end of file after #\\"))
            ((char-alphabetic? c)
             (list 'd!c (sub-read-token (read-char port) port)))
            (else (list 'd!c (list->string (list (read-chr port)))))))))

(define-sharp-macro #\(
  (lambda (c port)
    (read-char port)
    (list->vector (sub-read-list c port))))

(define-sharp-macro #\!
  ;; DSSSL declared constants
  (lambda (c port)
    (read-char port)
    (let ((c (read-chr port)))
      (if (eof-object? c)
	  (reading-error port "end of file after @!")
	(list 'd!d (string->symbol
		    (make-immutable!
		     (sub-read-token c port)))))))) ; cs?

(let ((number-sharp-macro
       (lambda (c port)
         (let ((string (sub-read-token #\# port)))
           (or (string->number string)
               (reading-error port "unsupported number syntax" string))))))
  (for-each (lambda (c)
              (define-sharp-macro c number-sharp-macro))
            '(#\b #\o #\x #\i #\e)))

(define-sharp-macro #\d
  (lambda (c port)
    (let ((string (sub-read-token #\# port)))
      (or (string->number string)
	  (quantity-expr string 2 (- (string-length string) 1))
	  (reading-error port "unsupported number syntax" string)))))

; Tokens

(define (sub-read-token c port)
  (let loop ((l (list c)) (n 1))
    (let ((c (peek-char port)))
      (cond ((or (eof-object? c)
                 (vector-ref read-terminating?-vector (char->ascii c)))
             (reverse-list->string l n))
            (else
             (loop (cons (read-chr port) l)
                   (+ n 1)))))))

(define (parse-token string port)
  (let ((lcn (- (string-length string) 1))
        (c (string-ref string 0)))
    (cond ((or (char-numeric? c) (char=? c #\+) (char=? c #\-) (char=? c #\.))
	   (cond ((string->number string))
		 ((member string strange-symbol-names)
		  (string->symbol (make-immutable! string)))
		 ((string=? string ".")
		  dot)
		 ((quantity-expr string
				 (if (char-numeric? c) 0 1) lcn))
		 (else
		  (reading-error port "unsupported number syntax" string))))
	  ((char=? (string-ref string lcn) #\:)
	   ;; dsssl keyword
	   (list 'd!k (string->symbol (make-immutable!
				       (substring string 0 lcn)))))
	  (else (string->symbol (make-immutable! string))))))

(define strange-symbol-names
  '("+" "-" "..."
        "1+" "-1+"  ;Only for S&ICP support
        "->"        ;Only for JAR's thesis
        ))

(define quantity-expr
  ;; (#d)?([-+]?([0-9]+\.[0-9]*|\.?[0-9]+)(e[-+]?[0-9]+)?)([a-zA-Z]{2,}|[a-df-zA-Z])(([-+]?[0-9]+)?)
  (lambda (string pos lcn)
    (let ((dp #f)(exp #f)(q '()))
      (let loop ((n pos))
	   (if (char-numeric? (string-ref string n))
	       (loop (+ n 1))
	     (let ((c (string-ref string n)))
	       (cond
		((char=? c #\.)(if dp #f (begin (set! dp #t)(loop (+ n 1)))))
		((and (char=? c #\e)
		      (< n lcn)
		      (let ((c (string-ref string (+ n 1))))
			(or (char-numeric? c)(char=? c #\+)(char=? c #\-))))
		 (if exp #f (begin (set! exp #t)(loop (+ n 1)))))
	       (else (cond ((string->number (substring string 0 n))
			    =>
			    (lambda (num)
			      (let loop2 ((m (+ n 1)))
				   (if (or (> m lcn)
					   (let ((c (string-ref string m)))
					     (or (char-numeric? c)
						 (char=? c #\+)
						 (char=? c #\-))))
				       (begin
					(set! q (string->symbol
						 (make-immutable!
						  (substring string n m))))
					(if (<= m lcn)
					    (cond ((string->number
						    (substring string m
							       (+
								lcn
								1)))
						   =>
						   (lambda (pow)
						     (list 'd!m num q pow)))
						  (else #f))
					  (list 'd!m num q)))
				     (loop2 (+ m 1))))))
			   (else #f))))))))))

; Reader errors

(define (reading-error port message . irritants)
  (spec-error "Read error at line " line-no message
         (append irritants (list port))))

