;;; SCHEME->C Runtime Library

;*              Copyright 1989 Digital Equipment Corporation
;*                         All Rights Reserved
;*
;* Permission to use, copy, and modify this software and its documentation is
;* hereby granted only under the following terms and conditions.  Both the
;* above copyright notice and this permission notice must appear in all copies
;* of the software, derivative works or modified versions, and any portions
;* thereof, and both notices must appear in supporting documentation.
;*
;* Users of this software agree to the terms and conditions set forth herein,
;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
;* right and license under any changes, enhancements or extensions made to the
;* core functions of the software, including but not limited to those affording
;* compatibility with other hardware or software environments, but excluding
;* applications which incorporate this software.  Users further agree to use
;* their best efforts to return to Digital any such changes, enhancements or
;* extensions that they make and inform Digital of noteworthy uses of this
;* software.  Correspondence should be provided to Digital at:
;* 
;*                       Director of Licensing
;*                       Western Research Laboratory
;*                       Digital Equipment Corporation
;*                       100 Hamilton Avenue
;*                       Palo Alto, California  94301  
;* 
;* This software may be distributed (but not offered for sale or transferred
;* for compensation) to third parties, provided such third parties agree to
;* abide by the terms and conditions of this notice.  
;* 
;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
;* SOFTWARE.

(module scrt7 (top-level))

(define-external UNDEFINED "sc" "undefined")

(define-c-external (SSCANF pointer pointer pointer pointer) int "sscanf")

(define-c-external (GCVT double int pointer) int "gcvt")

;;; 7.1.1.  Lexical Structure

;;; The following global values define tokens used to denote special symbols
;;; which are returned by TOKEN.  They must be computed at run-time as they
;;; cannot use READCONSTANT.

(define TOKEN-LEFT-PAREN (cons 'left-paren '()))

(define TOKEN-RIGHT-PAREN (cons 'right-paren '()))

(define TOKEN-QUOTE (cons 'quote '()))

(define TOKEN-QUASIQUOTE (cons 'quasiquote '()))

(define TOKEN-UNQUOTE-SPLICING (cons 'unquote-splicing '()))

(define TOKEN-UNQUOTE (cons 'unquote '()))

(define TOKEN-PERIOD (cons 'period '()))

(define TOKEN-VECTOR (cons 'vector '()))

;;; In order to read characters faster from the current input port, the
;;; methods are cached here on entry to this module by READ-DATUM.

(define PEEK-CHAR-PORT '())	;;; Method to inspect a char

(define READ-CHAR-PORT '())	;;; Method to read a char

(define (NEXT-CHAR)
    (let ((char (read-char-port)))
	 (if (eof-object? char)
	     (error 'READ "Unexpected end-of-file")
	     char)))

(define-in-line (CHAR-WHITESPACE? char)
    ((lap (char)
	  (BOOLEAN (OR (EQ char (C_CHAR "040"))
		       (AND (GTE char (C_CHAR "011"))
			    (LTE char (C_CHAR "015")))))) char))

(define-in-line (CHAR->INTEGER c) ((lap (c) (C_FIXED (CHAR_C c))) c))

(define-in-line (SPECIAL-INITIAL? char)
    (memq char '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\~ #\_ #\^)))

(define-in-line (SPECIAL-SUBSEQUENT? char) (memq char '(#\. #\+ #\-)))

(define (TOKEN)
    (let ((char (next-char)))
	 (cond ((or (char-whitespace? char) (comment? char))
		(token))
	       ((char-alphabetic? char)
		(identifier (char-upcase char)))
	       ((char=? char #\")
		(string))
	       ((char=? char #\()
		token-left-paren)
	       ((char=? char #\))
		token-right-paren)
	       ((char=? char #\')
		token-quote)
	       ((char=? char #\`)
		token-quasiquote)
	       ((char=? char #\,)
		(if (char=? (peek-char-port) #\@)
		    (begin (next-char)
		           token-unquote-splicing)
		    token-unquote))
	       ((char=? char #\.)
		(cond ((char-numeric? (peek-char-port)) (number char 10 1))
		      ((char-whitespace? (peek-char-port)) token-period)
		      (else (identifier char))))
	       ((char=? char #\#)
		(set! char (char-upcase (next-char)))
		(cond ((char=? char #\()
		       token-vector)
		      ((char=? char #\\ )
		       (character))
		      ((char=? char #\T)
		       #t)
		      ((char=? char #\F)
		       #f)
		      ((char=? char #\B)
		       (number (next-char) 2 1))
		      ((char=? char #\O)
		       (number (next-char) 8 1))
		      ((char=? char #\D)
		       (number (next-char) 10 1))
		      ((char=? char #\X)
		       (number (next-char) 16 1))
		      (else (error 'READ "Invalid # option: ~a" char))))
	       ((special-initial? char)
		(identifier char))
	       ((char=? char #\\ )
		(identifier (next-char)))
	       ((or (eq? char '#\+) (eq? char #\-))
		(let ((next (peek-char-port)))
		     (if (or (char-numeric? next) (memq next '(#\# #\.)))
			 (number char 0 0)
			 (identifier char))))
	       (else (number char 0 0)))))
	       				   		
(define (DELIMITER? char)
    (or (eof-object? char)
	(char-whitespace? char)
	(memq char '(#\( #\) #\" #\;))))

(define (COMMENT? char)
    (if (char=? char #\;)
	(do () ((char=? (next-char) #\newline) #t))
	#f))

;;; When a " is detected, this function is called to read the rest of the
;;; string.

(define (STRING)
    (do ((cl '() (cons char cl))
	 (char (next-char) (next-char)))
	((char=? char #\")
	 (list->string (reverse cl)))
	(if (char=? #\\ char) (set! char (next-char)))))

;;; When a #\ is detected, this function is called to read the rest of the
;;; character constant.

(define (CHARACTER)
    (let ((char (next-char)))
	 (if (and (char-alphabetic? char)
		  (not (delimiter? (peek-char-port))))
	     (let ((id (identifier (char-upcase char))))
		  (case id 
			((tab)      (integer->char #o11))
			((newline)  (integer->char #o12))
			((linefeed) (integer->char #o12))
			((formfeed) (integer->char #o14))
			((return)   (integer->char #o15))
			((space)    (integer->char #o40))
			(else (error 'READ "Unrecognized CHARACTER NAME: ~s"
				     id))))
	     char)))

;;; When the start of an identifier is detected, the following function is
;;; called to finish reading it.  It is table driven from the IDTABLE which
;;; contains an entry for each possible character.  The entries are:
;;;
;;;	#f	character is not part of the identifier.
;;;	newchar	character is part of the identifier and "newchar" is the
;;;		 upshifted value.
;;;	#t	character is \ so the following character is taken as is.

(define IDTABLE
    (let ((tab (make-vector 256 #f)))
	 (do ((i (char->integer #\A) (+ i 1))
	      (last (char->integer #\Z)))
	     ((> i last))
	     (vector-set! tab i (integer->char i))
	     (vector-set! tab (+ i 32) (integer->char i)))
	 (for-each
	     (lambda (c)
		     (vector-set! tab (char->integer c) c))
	     '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
					; Numeric characters.
	       #\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\~ #\_ #\^
	       				; Special initial.
	       #\. #\+ #\-))		; Special subsequent.
	 (vector-set! tab (char->integer #\\) #t)
	 tab))

(define (IDENTIFIER firstchar)
    (let loop ((cl (list firstchar)))
	 (let* ((pc (peek-char-port))
		(tc (and (char? pc)
			 (vector-ref idtable (char->integer pc)))))
	       (cond ((char? tc)
		      (read-char-port)
		      (loop (cons tc cl)))
		     (tc
		      (read-char-port)
		      (loop (cons (next-char) cl)))
		     (else
		      (string->symbol (list->string (reverse cl))))))))

;;; When the start of a number is detected, the following function is called
;;; to finish reading it.

(define (NUMBER firstchar base sign)
    (if (zero? sign)
	(cond ((char=? firstchar #\+)
	       (set! sign 1)
	       (set! firstchar (next-char)))
	      ((char=? firstchar #\-)
	       (set! sign -1)
	       (set! firstchar (next-char)))
	      (else (set! sign 1))))
    (if (zero? base)
	(cond ((char=? firstchar #\#)
	       (let ((char (next-char)))
		    (case char
			  ((#\B #\b) (set! base 2))
			  ((#\O #\o) (set! base 8))
			  ((#\D #\d) (set! base 10))
			  ((#\X #\x) (set! base 16))
			  (else (error 'READ "Invalid number base: ~a" char))))
	       (set! firstchar (next-char)))
	      (else (set! base 10))))
    (do ((cl (list firstchar) (cons char cl))
	 (char (peek-char-port) (peek-char-port))
	 (bv (case firstchar ((#\0) 0) ((#\1) 1) (else -1))
	     (case char ((#\0) (* bv 2)) (( #\1) (+ (* bv 2) 1)) (else -1)))
	 (iv (accv 0.0 base firstchar) (accv iv base char))
	 (maxchar (char->integer firstchar) (max maxchar (char->integer char)))
	 (result (make-string 8))
	 (pad    (make-string 4))
	 (cs 0)
	 (fpt (eq? firstchar #\.)
	      (or fpt
		  (eq? char #\.)
		  (and (not (= base 16)) (or (eq? char #\e) (eq? char #\E))))))
	((delimiter? char)
	 (set! cl (list->string (reverse cl)))
	 (set! cs (string-append (if (eq? sign -1) "-" "") cl ")0"))
	 (cond (fpt
		(if (not (eq? base 10))
		    (error 'READ "Floating point numbers must be base 10: ~a"
			   cl))
		(if (eq? 2 (sscanf cs "%f)%d" result pad))
		    (c-double-ref result 0)
		    (error 'READ "Illegal floating point number: ~a" cl)))
	       ((eq? iv -1)
		(error 'READ "Illegal digit(s) in integer: ~a" cl))
	       (else (let ((siv (* sign iv)))
			  (if (or (< siv minintf) (> siv maxintf))
			      siv
			      (float->fixed siv))))))
	(next-char)))

(define (ACCV value base char)
    (let ((cv (assq char '((#\0 0)  (#\1 1)  (#\2 2)  (#\3 3)
			   (#\4 4)  (#\5 5)  (#\6 6)  (#\7 7)
			   (#\8 8)  (#\9 9)  (#\a 10) (#\b 11)
			   (#\c 12) (#\d 13) (#\e 14) (#\f 15)
			   (#\A 10) (#\B 11) (#\C 12) (#\D 13)
			   (#\E 14) (#\F 15)))))
	 (if (or (eq? value -1) (not cv) (>= (cadr cv) base))
	     -1
	     (+ (* base value) (cadr cv)))))

;;; 7.1.2. External Representations

(define (READ-DATUM port-proc)
    (let ((save-peek-char-port peek-char-port)
	  (save-read-char-port read-char-port))
	 (set! peek-char-port (port-proc 'peek-char))
	 (set! read-char-port (port-proc 'read-char))
	 (let ((result (let loop ((char (peek-char-port)))
			    (cond ((eof-object? char)
				   (read-char-port))
				  ((char-whitespace? char)
				   (read-char-port)
				   (loop (peek-char-port)))
				  ((char=? char #\;)
				   (do () ((char=? (next-char) #\newline)))
				   (loop (peek-char-port)))
				  (else (datum (token)))))))
	      (set! peek-char-port save-peek-char-port)
	      (set! read-char-port save-read-char-port)
	      result)))

(define (DATUM current-token)
    (cond ((eq? current-token token-left-paren)
	   (datum-list (token)))
	  ((eq? current-token token-vector)
	   (list->vector (datum-vector (token))))
	  ((eq? current-token token-quote)
	   (list 'quote (datum (token))))
	  ((eq? current-token token-quasiquote)
	   (list 'quasiquote (datum (token))))
	  ((eq? current-token token-unquote)
	   (list 'unquote (datum (token))))
	  ((eq? current-token token-unquote-splicing)
	   (list 'unquote-splicing (datum (token))))
	  ((not (pair? current-token))
	   current-token)
	  (else (error 'READ "Poorly formed DATUM: ~s" current-token))))

(define (DATUM-LIST current-token)
    (cond ((eq? current-token token-right-paren)
	   '())
	  ((eq? current-token token-period)
	   (let ((result (datum (token))))
		(if (eq? (token) token-right-paren)
		    result
		    (error 'READ "Poorly formed LIST"))))
	  (else
	   (cons (datum current-token) (datum-list (token))))))

(define (DATUM-VECTOR current-token)
    (cond ((eq? current-token token-right-paren)
           '())
          (else
           (cons (datum current-token)
		 (datum-vector (token))))))

;;; Method for printing a token is cached here.

(define WRITE-TOKEN-PORT '())

(define (WRITE/DISPLAY obj readable port-proc)
    (let ((save-write-token-port write-token-port))
	 (set! write-token-port (port-proc 'write-token))
	 (let ((result (write/display2 obj readable)))
	      (set! write-token-port save-write-token-port)
	      result)))

(define (WRITE/DISPLAY2 obj readable)
    (cond ((pair? obj)
	   (let ((qq (and (pair? (cdr obj)) (null? (cddr obj))
			  (assq (car obj)
				'((quote "'") (quasiquote "`")
				  (unquote ",") (unquote-splicing ",@"))))))
		(cond ((and qq readable) 
		       (write-token-port (cadr qq))
		       (write/display2 (cadr obj) readable))
		      (else
		       (write-token-port "(")
		       (write/display2 (car obj) readable)
		       (write/display-list (cdr obj) readable)))))
	  ((symbol? obj)
	   (if readable
	       (if (memq obj '(+ - ))
	           (write-token-port (symbol->string obj))
	           (write-token-port (readable-symbol obj)))
	       (write-token-port (symbol->string obj))))
	  ((fixed? obj)
	   (write-token-port (fixed->clist obj)))
	  ((string? obj)
	   (write-token-port (if readable (readable-string obj) obj)))
	  ((char? obj)
	   (write-token-port (if readable (readable-char obj) obj)))
	  ((or (string? obj) (char? obj))
	   (write-token-port obj))
	  ((vector? obj)
	   (write-token-port "#")
	   (write/display2 (vector->list obj) readable))
	  ((float? obj)
	   (write-token-port (float->clist obj)))
	  ((eq? obj #t)
	   (write-token-port "#T"))
	  ((eq? obj #f)
	   (write-token-port "#F"))
	  ((null? obj)
	   (write-token-port "()"))
	  ((eof-object? obj)
	   (write-token-port "#*END-OF-FILE*"))
	  ((eq? obj undefined)
	   (write-token-port "#*UNDEFINED*"))
	  ((procedure? obj)
	   (write-token-port "#*PROCEDURE*"))
	  (else (write-token-port "#*??????*"))))

(define (WRITE/DISPLAY-LIST obj readable)
    (cond ((null? obj)
	   (write-token-port ")"))
	  ((not (pair? obj))
	   (write-token-port " . ")
	   (write/display2 obj readable)
	   (write-token-port ")"))
	  (else
	   (write-token-port " ")
	   (write/display2 (car obj) readable)
	   (write/display-list (cdr obj) readable))))

(define (READABLE-CHAR obj)
    (if (and (char>? obj #\space) (char<=? obj #\~))
	(list->string (list #\# #\\ obj))
	(let ((spec (assoc obj '((#\tab      "#\\tab")
				 (#\newline  "#\\newline")
				 (#\linefeed "#\\linefeed")
				 (#\formfeed "#\\formfeed")
				 (#\return   "#\\return")
				 (#\space    "#\\space")))))
	     (if spec
		 (cadr spec)
		 "#\\???"))))

(define (READABLE-STRING obj) 
    (do ((cl '(#\") (cons (string-ref obj i) cl))
	 (len (string-length obj))
	 (i 0 (+ i 1)))
	((= len i) (reverse (cons #\" cl)))
	(if (and (or (eq? (string-ref obj i) #\\ )
		     (eq? (string-ref obj i) #\" )))
	    (set! cl (cons #\\ cl)))))

(define (READABLE-SYMBOL obj)
    (set! obj (symbol->string obj))
    (do ((cl '() (cons (string-ref obj i) cl))
	 (len (string-length obj))
	 (i 0 (+ 1 i)))
	((= i len) (reverse cl))
	(let ((c (string-ref obj i)))
	     (cond ((and (not (and (char-alphabetic? c) (char-upper-case? c)))
			 (not (special-initial? c))
			 (not (special-subsequent? c))
			 (not (char-numeric? c)))
		    (set! cl (cons #\\ cl)))
		   ((and (zero? i) (not (char-alphabetic? c))
			 (not (special-initial? c)))
		    (set! cl (cons #\\ cl)))))))

(define (FIXED->CLIST obj)
    (do ((cl '() (cons (integer->char (+ (char->integer #\0)
					 (abs (remainder number 10))))
		       cl))
	 (number obj (quotient number 10)))
	((and (zero? number) cl)
	 (if (< obj 0) (cons #\- cl) cl))))

(define (FLOAT->CLIST obj)
    (let* ((null (integer->char 0))
	   (buffer (make-string 30 null)))
	  (gcvt obj 16 buffer)
	  (let loop ((cli (string->list buffer)) (clo '())) 
	       (if (eq? (car cli) null)
		   (reverse (if (or (memq #\. clo) (memq #\e clo))
				clo
				(cons #\. clo)))
		   (loop (cdr cli) (cons (car cli) clo))))))