;;;-*- Mode:Common-Lisp; Package:SI; Base:10; Fonts:(CPTFONT HL12B HL12BI) -*-

;;; Copyright (C) 1987 Texas Instruments Incorporated. All rights reserved.

Ï2;;; Scheme read tableÏ*

;;  1/09/88 DNG - Fixed #S and #L.
;;  2/11/89 DNG - Fixed handling of brackets and braces.

(defvar SI:SCHEME-READTABLE (copy-readtable SI:COMMON-LISP-READTABLE))

(set-dispatch-macro-character #\# #\!
     #'(lambda (stream subchar arg)
	 (declare (ignore subchar arg))
	 (let ((tail (let ((*package* *system-package*))
		       (read stream t nil t))))
	   (case tail
	     ((true) t)
	     ((false) nil)
	     ((eof) the-eof-object)
	     ((null) nil)
	     ((unassigned) the-unassigned-value)
	     ((unprintable) '| |)
	     (otherwise (values (intern (concatenate 'string "#!" (string tail))))))))
     SI:SCHEME-READTABLE)

(set-dispatch-macro-character #\# #\t
     #'(lambda (stream subchar arg)
	 (declare (ignore stream subchar arg))
	 t)
     SI:SCHEME-READTABLE)

(set-dispatch-macro-character #\# #\f #'ignore SI:SCHEME-READTABLE)

(set-dispatch-macro-character #\# #\e ; exact number
     #'(lambda (stream ignore ignore)
	 (scheme:inexact->exact 
	   (read-preserving-whitespace stream t nil t)))
     SI:SCHEME-READTABLE)
(set-dispatch-macro-character #\# #\i ; inexact number
     #'(lambda (stream ignore ignore)
	 (scheme:exact->inexact
	   (read-preserving-whitespace stream t nil t)))
     SI:SCHEME-READTABLE)
(set-dispatch-macro-character #\# #\d ; decimal number
     #'(lambda (stream ignore ignore)
	 (si:sharp-r stream nil 10.))
     SI:SCHEME-READTABLE)
(set-dispatch-macro-character #\# #\S ; single precision floating point
     #'(lambda (stream ignore ignore)
	 (let ((*read-default-float-format* 'single-float))
	   (float (read-preserving-whitespace stream t nil t)
		  1.0F0)))
     SI:SCHEME-READTABLE)
(set-dispatch-macro-character #\# #\L ; double precision floating point
     #'(lambda (stream ignore ignore)
	 (let ((*read-default-float-format* 'double-float))
	   (float (read-preserving-whitespace stream t nil t)
		  1.0D0)))
     SI:SCHEME-READTABLE)

(set-dispatch-macro-character #\# #\' 'sharp-not-scheme SI:SCHEME-READTABLE)
(set-dispatch-macro-character #\# #\+ 'sharp-not-scheme SI:SCHEME-READTABLE)
(set-dispatch-macro-character #\# #\- 'sharp-not-scheme SI:SCHEME-READTABLE)
(set-dispatch-macro-character #\# #\| 'sharp-not-scheme SI:SCHEME-READTABLE)
(set-dispatch-macro-character #\# #\* 'sharp-not-scheme SI:SCHEME-READTABLE)
(set-dispatch-macro-character #\# #\. 'sharp-not-scheme SI:SCHEME-READTABLE)
(set-dispatch-macro-character #\# #\, 'sharp-not-scheme SI:SCHEME-READTABLE)
(set-dispatch-macro-character #\# #\A 'sharp-not-scheme SI:SCHEME-READTABLE)
(set-dispatch-macro-character #\# #\= 'sharp-not-scheme SI:SCHEME-READTABLE)

(defun sharp-not-scheme (stream subchar arg)
  (unless (member *package* '#,(list *lisp-package* *ticl-package* *global-package*) :test #'eq)
    (cerror "Proceed, using the Common Lisp semantics for #~A"
	    "Reader macro #~A is not defined in Scheme." subchar))
  (funcall (si:get-dispatch-macro-character #\# subchar SI:COMMON-LISP-READTABLE)
	   stream subchar arg))

;; The following 4 characters are read as being symbols by themselves.
(set-macro-character #\[ 'read-single-char-symbol nil scheme-readtable)
(set-macro-character #\] 'read-single-char-symbol nil scheme-readtable)
(set-macro-character #\{ 'read-single-char-symbol nil scheme-readtable)
(set-macro-character #\} 'read-single-char-symbol nil scheme-readtable)

(defun read-single-char-symbol (stream char)
  (declare (ignore stream))
  (values (intern (string char))))
