;;; -*- cold-load:t; Mode:Common-Lisp; Package:SI ; Base:10 -*- file.

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.

;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151

;;; Copyright (C) 1985-1989 Texas Instruments Incorporated. All rights reserved.
;	** (c) Copyright 1980 Massachusetts Institute of Technology **

;;; This code has been inspired from the Spice Lisp Reader(Written by David Dill).


(defvar secondary-attribute-table)

(defun set-secondary-attribute (char attribute)
  (setf (elt (the simple-vector secondary-attribute-table) (char-int char))
	attribute))


(defun init-secondary-attribute-table ()
  (setq secondary-attribute-table
	(make-array 256 :element-type t
			    :initial-element '#.constituent))
  (set-secondary-attribute #\: package-delimiter)
  (set-secondary-attribute #\| multiple-escape)
  (set-secondary-attribute #\. constituent-dot)
  (set-secondary-attribute #\+ constituent-sign)
  (set-secondary-attribute #\- constituent-sign)
  (set-secondary-attribute #\/ constituent-slash)
  (set-secondary-attribute #\# sharp-sign )
  (do ((i (char-int #\0) (1+ i)))
      ((> i (char-int #\9)))
    (set-secondary-attribute (int-char i) constituent-digit))
  (do ((i (char-int #\A) (1+ i)))
      ((> i (char-int #\Z)))
    (set-secondary-attribute (int-char i) constituent-digit))
  (do ((i (char-int #\a) (1+ i)))
      ((> i (char-int #\z)))
    (set-secondary-attribute (int-char i) constituent-digit))
  (set-secondary-attribute #\E constituent-expt)
  (set-secondary-attribute #\F constituent-expt)
  (set-secondary-attribute #\D constituent-expt)
  (set-secondary-attribute #\S constituent-expt)
  (set-secondary-attribute #\L constituent-expt)
  (set-secondary-attribute #\e constituent-expt)
  (set-secondary-attribute #\f constituent-expt)
  (set-secondary-attribute #\d constituent-expt)
  (set-secondary-attribute #\s constituent-expt)
  (set-secondary-attribute #\l constituent-expt)
   secondary-attribute-table)

(defmacro get-secondary-attribute (char)
  `(elt (the simple-vector secondary-attribute-table)
	(char-int ,char)))


(defun copy-readtable (&optional (from-readtable *readtable*) to-readtable)
  (if (null from-readtable) (setq from-readtable common-lisp-readtable))
  (if (null to-readtable) (setq to-readtable (make-readtable)))
  ;;physically clobber contents of internal tables.
  (replace (character-attribute-table to-readtable)
	   (character-attribute-table from-readtable))
  (replace (character-macro-table to-readtable)
	   (character-macro-table from-readtable))
  ;; Preserve the printslots for Zetalisp.
  (setf (pttbl-character-prefix  to-readtable)
	   (pttbl-character-prefix  from-readtable))
  (setf (pttbl-slash  to-readtable)
	   (pttbl-slash  from-readtable))
  (setf (pttbl-rational-infix to-readtable)
	   (pttbl-rational-infix from-readtable))
  (setf (dispatch-tables to-readtable)
	(mapcar #'(lambda (pair) (cons (car pair)
				       (copy-seq (cdr pair))))
		(dispatch-tables from-readtable)))
  to-readtable)


(defun set-syntax-from-char (to-char from-char &optional
				     (to-readtable *readtable*)
				     (from-readtable ()))
  (if (null from-readtable) (setq from-readtable common-lisp-readtable))
  ;;copy from-char entries to to-char entries, but make sure that if
  ;;from char is a constituent you don't copy non-movable secondary
  ;;attributes (constituent types), and that said attributes magically
  ;;appear if you transform a non-constituent to a constituent.
  (let ((att (get-cat-entry from-char from-readtable)))
    (when (>=  att constituent) ;Means we have a constituent character
      (setq att (get-secondary-attribute to-char)))
    (set-cat-entry to-char att to-readtable)
    (set-cmt-entry to-char
		   (get-cmt-entry from-char from-readtable)
		   to-readtable)))




(defun set-macro-character (char function &optional
				 (non-terminatingp nil) (rt *readtable*))
  (if non-terminatingp
      (set-cat-entry char (get-secondary-attribute char) rt)
      (set-cat-entry char terminating-macro rt))
  (set-cmt-entry char function rt))

(defun get-macro-character (char &optional (rt *readtable*))
  ;;check macro syntax, return associated function if it's there.
  ;;returns a value for all constituents.
  (cond ((constituentp char)
	 (values (get-cmt-entry char rt) t))
	((terminating-macrop char)
	 (values (get-cmt-entry char rt) nil))
	(t nil)))


;;;dispatching macro cruft

(proclaim '(inline find-disp-char))

(defun find-disp-char (char list)
  (dolist (el list)
    (when (char= (car el) char)
      (return el))))

(defun make-char-dispatch-table ()
  (make-array 256 :initial-element 'dispatch-char-error))


(defun make-dispatch-macro-character (char &optional
					   (non-terminating-p nil)
					   (rt *readtable*))
  (if non-terminating-p
      (set-cat-entry char sharp-sign rt)
      (set-cat-entry char terminating-macro rt))
  (set-cmt-entry char 'read-dispatch-char rt)
  (let* ((dalist (dispatch-tables rt))
	 (dtable (cdr (find-disp-char char dalist))))
    (cond (dtable
	   (error "Dispatch character already exists"))
	  (t
	   (setf (dispatch-tables rt)
	    (push (cons char (make-char-dispatch-table)) dalist))
	   t))))

(defun set-dispatch-macro-character
  (disp-char sub-char function &optional (rt *readtable*))
  ;;get the dispatch char for macro (error if not there), diddle
  ;;entry for sub-char.
  (if (digit-char-p sub-char)
      nil
      (let ((dpair (find-disp-char disp-char (dispatch-tables rt))))
	(if dpair
	    (setf (elt (the simple-vector (cdr dpair))
		       (char-int (char-upcase sub-char)))
		  function)
	    (error "~S is not a dispatch char." disp-char)))))

(defun get-dispatch-macro-character (disp-char sub-char
					       &optional (rt *readtable*))
  (let ((dpair (find-disp-char disp-char (dispatch-tables rt))))
    (if dpair
	(elt (the simple-vector (cdr dpair))
	     (char-int sub-char))
	(error "~S is not a dispatch char." disp-char))))



;;; Reader initialization code.

;;;Temporary initialization hack.
(defun sharp-init (areadtable )
  (let ((*readtable* areadtable))
    (make-dispatch-macro-character #\# t)
    (set-dispatch-macro-character #\# #\\ 'sharp-backslash)
    (set-dispatch-macro-character #\# #\' 'sharp-quote)
    (set-dispatch-macro-character #\# #\( 'sharp-left-paren)
    (set-dispatch-macro-character #\# #\* 'sharp-star)
    (set-dispatch-macro-character #\# #\: 'sharp-colon)
    (set-dispatch-macro-character #\# #\. 'sharp-dot)
    (set-dispatch-macro-character #\# #\, 'sharp-comma)
    (set-dispatch-macro-character #\# #\R 'sharp-R)
    (set-dispatch-macro-character #\# #\r 'sharp-R)
    (set-dispatch-macro-character #\# #\B 'sharp-B)
    (set-dispatch-macro-character #\# #\b 'sharp-B)
    (set-dispatch-macro-character #\# #\O 'sharp-O)
    (set-dispatch-macro-character #\# #\o 'sharp-O)
    (set-dispatch-macro-character #\# #\X 'sharp-X)  
    (set-dispatch-macro-character #\# #\x 'sharp-X)
    (set-dispatch-macro-character #\# #\A 'sharp-A)    
    (set-dispatch-macro-character #\# #\a 'sharp-A)    
    (set-dispatch-macro-character #\# #\S 'sharp-S)    
    (set-dispatch-macro-character #\# #\s 'sharp-S)    
    (set-dispatch-macro-character #\# #\= 'sharp-equal)    
    (set-dispatch-macro-character #\# #\# 'sharp-sharp)    
    (set-dispatch-macro-character #\# #\+ 'sharp-plus)    
    (set-dispatch-macro-character #\# #\- 'sharp-minus)    
    (set-dispatch-macro-character #\# #\C 'sharp-C)
    (set-dispatch-macro-character #\# #\c 'sharp-C)
    (set-dispatch-macro-character #\# #\| 'sharp-vertical-bar)
    (set-dispatch-macro-character #\# #\tab 'sharp-illegal)
    (set-dispatch-macro-character #\# #\  'sharp-illegal)
    (set-dispatch-macro-character #\# #\) 'sharp-illegal)
    (set-dispatch-macro-character #\# #\< 'sharp-illegal)
    (set-dispatch-macro-character #\# #\form 'sharp-illegal)
    (set-dispatch-macro-character #\# #\return 'sharp-illegal)
    (set-dispatch-macro-character #\# #\` 'sharp-backquote)
    (set-dispatch-macro-character #\# #\ 'xr-#-macro )
    (set-dispatch-macro-character #\# #\! 'xr-#!-macro )))

(defun backq-init (areadtable)
  (let ((*readtable* areadtable))
    (set-macro-character #\` 'backquote-macro)
    (set-macro-character #\, 'comma-macro)))   

;;PHD 2/13/87 Added #\ to be able to read instances
(defun init-std-lisp-readtable (&aux COMMON-LISP-READTABLE )
  (setq COMMON-LISP-READTABLE (make-readtable))
  ;;all characters default to "constituent" in make-readtable
  ;;*** un-constituent-ize some of these ***
  (let ((*readtable* COMMON-LISP-READTABLE ))
    (set-cat-entry #\tab whitespace)
    (set-cat-entry #\linefeed whitespace)  
    (set-cat-entry #\space whitespace)
    (set-cat-entry #\page whitespace)
    (set-cat-entry #\return whitespace)
    (set-cat-entry #\ whitespace)
    (set-cat-entry #\\ escape)
    (set-cmt-entry #\\ 'read-token)
    (set-cat-entry #\rubout whitespace)
    (set-cmt-entry #\: 'read-token)
    (set-cmt-entry #\| 'read-token)
    ;;macro definitions
    (set-macro-character #\" 'internal-read-string)
    ;;* # macro
    (set-macro-character #\' 'read-quote)
    (set-macro-character #\( 'internal-read-list)
    (set-macro-character #\) 'read-right-paren)
    (set-macro-character #\; 'read-comment)
    ;;* backquote
    ;;all constituents
    (do ((ichar 0 (1+ ichar))
	 (char))
	((= ichar #O400))
      (setq char (int-char ichar))
      (when (constituentp char COMMON-LISP-READTABLE )
	    (set-cat-entry char (get-secondary-attribute char))
	    (set-cmt-entry char 'read-token))))
  (sharp-init COMMON-LISP-READTABLE )
  (backq-init COMMON-LISP-READTABLE )
  common-lisp-readtable)

;;PHD 2/13/87 Added #\ to be able to read instances
;;DNG 2/11/89 Restored support for #Q, #M,and #N to fix SPR 5376.
(defun init-std-zetalisp-readtable (&aux STANDARD-READTABLE  )
  (setq STANDARD-READTABLE  
	(make-readtable   :PTTBL-CHARACTER-PREFIX      "/"   
	                  :PTTBL-RATIONAL-INFIX        #\\
			  :PTTBL-SLASH                 #\/))
  ;;all characters default to "constituent" in make-readtable
  ;;*** un-constituent-ize some of these ***
  (let ((*readtable* STANDARD-READTABLE  ))
    (set-cat-entry #\tab whitespace)
    (set-cat-entry #\linefeed whitespace)  
    (set-cat-entry #\space whitespace)
    (set-cat-entry #\page whitespace)
    (set-cat-entry #\return whitespace)
    (set-cat-entry #\ whitespace)
    (set-cat-entry #\/ escape)
    (set-cmt-entry #\/ 'read-token)
    (set-cat-entry #\rubout whitespace)
    (set-cmt-entry #\: 'read-token)
    (set-cmt-entry #\| 'read-token)
    ;;macro definitions
    (set-macro-character #\" 'internal-read-string)
    ;;* # macro
    (set-macro-character #\' 'read-quote)
    (set-macro-character #\( 'internal-read-list)
    (set-macro-character #\) 'read-right-paren)
    (set-macro-character #\; 'read-comment)
    ;;* backquote
    ;;all constituents
    (do ((ichar 0 (1+ ichar))
	 (char))
	((= ichar #O400))
      (setq char (int-char ichar))
      (when (constituentp char STANDARD-READTABLE  )
	    (set-cat-entry char (get-secondary-attribute char))
	    (set-cmt-entry char 'read-token)))
    (set-cat-entry #\\ constituent-slash)
    (sharp-init STANDARD-READTABLE  )
    (backq-init STANDARD-READTABLE  )
    (set-dispatch-macro-character #\# #\/ 'xr-#\\-macro )
    (set-dispatch-macro-character #\# #\\ 'xr-#\\-macro )
    (set-dispatch-macro-character #\# #\Q 'xr-#q-macro)
    (set-dispatch-macro-character #\# #\M 'xr-#m-macro)
    (set-dispatch-macro-character #\# #\N 'xr-#n-macro)
    (set-dispatch-macro-character #\# #\ 'xr-#-macro  ))
  standard-readtable )


(defun reader-init ()
  (setq secondary-attribute-table (init-secondary-attribute-table)) 
  (setq standard-readtable (init-std-zetalisp-readtable ))
  (setq common-lisp-readtable (init-std-lisp-readtable )) 
  (setf *readtable* common-lisp-readtable))