;;; -*- cold-load:t; Mode:Common-Lisp; Package:si; Base:10 -*-

;;;			      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.


;;;BACKQUOTE:
;;; The flags passed back by BACKQUOTIFY can be interpreted as follows:
;;;
;;;   |`,|: [a] => a
;;;    NIL: [a] => a			;the NIL flag is used only when a is NIL
;;;      T: [a] => a			;the T flag is used when a is self-evaluating
;;;  QUOTE: [a] => (QUOTE a)
;;; APPEND: [a] => (APPEND . a)
;;;  NCONC: [a] => (NCONC . a)
;;;   LIST: [a] => (LIST . a)
;;;  LIST*: [a] => (LIST* . a)
;;;
;;; The flags are combined according to the following set of rules:
;;;  ([a] means that a should be converted according to the previous table)
;;;
;;;    \ car   ||    otherwise    |    QUOTE or     |     |`,@|      |     |`,.|      |
;;;  cdr \     ||		  |    T or NIL     |                |		      |
;;;====================================================================================
;;;    |`,|    || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC  (a [d]) |
;;;    NIL     || LIST    ([a])   | QUOTE    (a)    | <hair>    a    | <hair>    a    |
;;; QUOTE or T || LIST* ([a] [d]) | QUOTE  (a . d)  | APPEND (a [d]) | NCONC  (a [d]) |
;;;   APPEND   || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a . d) | NCONC  (a [d]) |
;;;   NCONC    || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC  (a . d) |
;;;    LIST    || LIST  ([a] . d) | LIST  ([a] . d) | APPEND (a [d]) | NCONC  (a [d]) |
;;;    LIST*   || LIST* ([a] . d) | LIST* ([a] . d) | APPEND (a [d]) | NCONC  (a [d]) |
;;;
;;;<hair> involves starting over again pretending you had read ".,a)" instead of ",@a)"

(proclaim '(special *keyword-package* *package*))

(defparameter |**BACKQUOTE-,-FLAG**| (make-symbol ",")) 

(defparameter |**BACKQUOTE-,@-FLAG**| (make-symbol ",@")) 

(defparameter |**BACKQUOTE-,.-FLAG**| (make-symbol ",.")) 

;Expansions of backquotes actually use these five functions
;so that oneUN XR-BACKQUOT what came from backquote and what did not.


(defmacro xr-bq-cons (car cdr)
  (list 'cons car cdr))


(defmacro xr-bq-list (&rest elements)
  (cons 'list elements))


(defmacro xr-bq-list* (&rest elements)
  (cons 'list* elements))


(defmacro xr-bq-append (&rest elements)
  (cons 'append elements)) 


(defmacro xr-bq-nconc (&rest elements)
  (cons 'nconc elements)) 


(defmacro xr-bq-vector (&rest elements)
  (cons 'vector elements)) 


(defvar **backquote-repeat-variable-lists** ()) 


(defun backquote-macro (stream ignore)
  (prog ((flag NIL)
         (thing NIL)
         (**backquote-repeat-variable-lists** (cons t **backquote-repeat-variable-lists**)))
    (multiple-value-setq (flag thing)
      (backquotify (read-preserving-whitespace stream t () t)))
    (and (eq flag |**BACKQUOTE-,@-FLAG**|)
         (return
          (cerror ':no-action () 'sys:read-error-1 " \",@\" right after a \"`\": `,@~S." thing)))
    (and (eq flag |**BACKQUOTE-,.-FLAG**|)
         (return
          (cerror ':no-action () 'sys:read-error-1 " \",.\" right after a \"`\": `,.~S." thing)))
    (return (backquotify-1 flag thing)))) 


(defun sharp-backquote (stream ignore ignore)
  (prog ((flag NIL)
         (thing NIL)
         (**backquote-repeat-variable-lists** (cons () **backquote-repeat-variable-lists**)))
    (multiple-value-setq (flag thing)
      (backquotify (read-preserving-whitespace stream t () t)))
    (and (eq flag |**BACKQUOTE-,@-FLAG**|)
         (return
          (cerror ':no-action () 'sys:read-error-1 " \",@\" right after a \"`\": `,@~S." thing)))
    (and (eq flag |**BACKQUOTE-,.-FLAG**|)
         (return
          (cerror ':no-action () 'sys:read-error-1 " \",.\" right after a \"`\": `,.~S." thing)))
    (return
     (cons 'progn
           (nreverse
            (si:*eval
             `(let (accum)
                (do ,(car
                     **backquote-repeat-variable-lists**)
                    ((null ,(caaar **backquote-repeat-variable-lists**)) accum)
                  (push ,(backquotify-1 flag thing) accum))))))))) 


(defun comma-macro (stream ignore)
  (or **backquote-repeat-variable-lists**
      (cerror ':no-action () 'sys:read-error-1 "Comma not inside a backquote."))
  (prog (c)
    (setf c (internal-read-char stream t () t))
    (or (= c #\@) (= c #\.) (unread-char c  stream))
    (let ((comma-arg
           (let ((**backquote-repeat-variable-lists** (cdr **backquote-repeat-variable-lists**)))
             (read-preserving-whitespace stream t () t))))
      (unless (or (null **backquote-repeat-variable-lists**)
           (eq (car **backquote-repeat-variable-lists**) t))
        (if (eq (car comma-arg) |**BACKQUOTE-,-FLAG**|) (setq comma-arg (list 'quote comma-arg))
            (let ((var (gensym)))
              (push (list var (list 'quote comma-arg) (list 'cdr var))
                    (car **backquote-repeat-variable-lists**))
              (setq comma-arg (list 'car var)))))
      (return
       (cond
         ((= c #\@) (cons |**BACKQUOTE-,@-FLAG**| comma-arg ))
         ((= c #\.) (cons |**BACKQUOTE-,.-FLAG**| comma-arg))
         (t (cons |**BACKQUOTE-,-FLAG**| comma-arg ))))))) 

;;AB for PHD 7-27-87.  Fix macroexpansion of backquoted vector. [SPR 5390]
;;clm for DNG 9/21/88 - change check for simple-vector-p to also check for
;;named structures.  If the code is a named structure we don't try to handle
;;it at that point. [sprs 8758 and 8759]
(defun backquotify (code)
  (prog (aflag
         a
         dflag
         d)
    (cond
      ((and (simple-vector-p code) (not (named-structure-p code)))
       (return 'apply
	       `(#'VECTOR
		 ,(multiple-value-bind (flag code)
		      (backquotify (concatenate 'list (the vector code)))
		    (backquotify-1 flag code)))
               ))
      ((atom code)
       (cond
         ((null code) (return () ()))
         ((or (numberp code) (eq code t)) (return t code))
         (t (return 'quote code))))
      ((eq (car code) |**BACKQUOTE-,-FLAG**|) (setq code (cdr code)) (go comma))
      ((eq (car code) |**BACKQUOTE-,@-FLAG**|) (return |**BACKQUOTE-,@-FLAG**| (cdr code)))
      ((eq (car code) |**BACKQUOTE-,.-FLAG**|) (return |**BACKQUOTE-,.-FLAG**| (cdr code))))
    (multiple-value-setq (aflag a)
      (backquotify (car code)))
    (multiple-value-setq (dflag d)
      (backquotify (cdr code)))
    (and (eq dflag |**BACKQUOTE-,@-FLAG**|)
         (cerror ':no-action () 'sys:read-error-1 " \",@\" after a \".\": .,@~S in ~S." d code))
    (and (eq dflag |**BACKQUOTE-,.-FLAG**|)
         (cerror ':no-action () 'sys:read-error-1 " \",.\" after a \".\": .,.~S in ~S." d code))
    (cond
      ((eq aflag |**BACKQUOTE-,@-FLAG**|) (cond
                                            ((null dflag) (setq code a) (go comma)))
       (return 'append
               (cond
                 ((eq dflag 'append) (cons a d ))
                 (t (list a (backquotify-1 dflag d))))))
      ((eq aflag |**BACKQUOTE-,.-FLAG**|) (cond
                                            ((null dflag) (setq code a) (go comma)))
       (return 'nconc
               (cond
                 ((eq dflag 'nconc) (cons a d))
                 (t (list a (backquotify-1 dflag d))))))
      ((null dflag)
       (cond
         ((member aflag '(quote t ()) :test #'eq) (return 'quote (list a)))
         (t (return 'list (list (backquotify-1 aflag a))))))
      ((member dflag ''t :test #'eq)
       (cond
         ((member aflag '(quote t ()) :test #'eq) (return 'quote (cons a d )))
         (t
          (return 'list*
		  (list (backquotify-1 aflag a) (backquotify-1 dflag d)))))))
    (setq a (backquotify-1 aflag a))
    (and (member dflag '(list list*) :test #'eq) (return dflag (cons a d)))
    (return 'list* (list a (backquotify-1 dflag d)))
    comma
    (cond
      ((atom code)
       (cond
         ((null code) (return () ()))
         ((or (numberp code) (eq code 't)) (return t code))
         (t (return |**BACKQUOTE-,-FLAG**| code))))
      ((eq (car code) 'quote) (return (car code) (cadr code)))
      ((member (car code) '(append list list* nconc) :test #'eq) (return (car code) (cdr code)))
      ((eq (car code) 'cons) (return 'list* (cdr code)))
      (t (return |**BACKQUOTE-,-FLAG**| code))))) 

;;AB for PHD 7-27-87.  Fix macroexpansion of backquoted vector. [SPR 5390]
(defun backquotify-1 (flag thing)
  (cond
    ((or (eq flag |**BACKQUOTE-,-FLAG**|) (member flag '(t NIL) :test #'eq)) thing)
    ((eq flag 'quote) (list 'quote thing))
    ((eq flag 'list*)
     (cond
       ((null (cddr thing)) (cons'xr-bq-cons thing ))
       (t (cons 'xr-bq-list* thing ))))
    (t
     (cons
      (or
	(cdr
	  (assoc flag
		 '((cons . xr-bq-cons) (list . xr-bq-list) (append . xr-bq-append)
		   (nconc . xr-bq-nconc) (vector . xr-bq-vector))
		 :test #'eq))
	flag)
      thing ))))
 

;; # submacros.

(defun internal-sharp-R (stream ignore radix)
  (multiple-value-bind (token escape-appearedp)
		       (read-extended-token stream)
    (declare (simple-string token))
    (when *read-suppress* (return-from internal-sharp-R nil))
    (let ((numval 0) (denval 0) (resttok 0) (toklength (length token))
		     (sign 1))
      (if escape-appearedp
	  (cerror ':no-action () 'sys:read-error-1 "Escape character appears in number."))
      ;;look for leading sign
      (let ((firstchar (elt token 0)))
	(cond ((char= firstchar #\-)
	       (setq sign -1)
	       (setq resttok 1))
	      ((char= firstchar #\+)
	       (setq resttok 1))))
      ;;read numerator
      (do ((position resttok (1+ position))
	   (dig ()))
	  ((or (>= position toklength)
	       (not (setq dig (digit-char-p (elt token position) radix))))
	   (setq resttok position))
	(setq numval (+ (* numval radix) dig)))
      ;;see if we're at the end.
      (cond ((>= resttok toklength)
	     ;;just return numerator -- that's all there is.
	     (* numval sign))
	    ((char= (elt token resttok) #\/)
	     ;;it's a ratio.
	     (do ((position (1+ resttok) (1+ position))
		  (dig ())
		  (retval ()))
		 ((cond ((>= position toklength)
			 (setq retval (/ (* numval sign) denval)))
			((not (setq dig (digit-char-p (elt token position)
						     radix)))
			 ;;there's bogus stuff at the end
			 (cerror ':no-action () 'sys:read-error-1 
              				 "Illegal digits ~S for radix ~D." token radix)
			 (setq retval (/ (* numval sign) denval)))
			;;continue looping
			(t nil))
		  retval)
	       (setq denval (+ (* denval radix) dig))))
	    ;;it's bogus
	    (t (cerror ':no-action () 'sys:read-error-1 
		       "Illegal digits ~S for radix ~D." token radix))))))

(defun sharp-B (stream ignore ignore)
  (sharp-r stream nil 2))

(defun sharp-O (stream ignore ignore)
  (sharp-r stream nil 8))

(defun sharp-X (stream ignore ignore)
  (sharp-r stream nil 16))

(defun sharp-R (stream ignore radix )
  (unless (integerp radix)
    (unless *read-suppress*
      (cerror ':no-action () 'sys:read-error-1 "#R was read with no digits after the #."))
    (setq radix 10))
  (if (<= 2. radix  36.)
      (if *read-accept-extensions*
	  (let ((*read-base* radix ))
	    (values (read-preserving-whitespace stream t () t)))
	  (internal-sharp-r stream nil radix))
      (cerror :noaction () 'sys:read-error-1 "Radix not between 2. and 36. in #R")))


(defun sharp-quote (stream ignore  ignore)
  (list 'function (read-preserving-whitespace stream t () t))) 


(defvar file-in-cold-load ()
        "T while evaluating text from a file which is in the cold load.
FILE-ATTRIBUTE-BINDINGS makes a binding for this from the Cold-load attribute.") 


(defun sharp-comma (stream ignore &optional ignore)
  (if file-in-cold-load
      (cerror ':no-action () 'sys:read-error-1 "#, cannot be used in files in the cold load."))
  (if (and (boundp 'compiler::qc-file-read-in-progress) compiler::qc-file-read-in-progress)
      (cons compiler::eval-at-load-time-marker (read-preserving-whitespace stream t () t) )
      (values
       (if *read-suppress* (progn
                             (read-preserving-whitespace stream t () t)
                             ())
           (si:*eval (read-preserving-whitespace  stream t () t)))))) 


(defun sharp-colon (stream ignore ignore)
  (when *read-suppress*
	(read-preserving-whitespace stream () () t)
	(return-from sharp-colon nil))
  (let ((token (read-extended-token stream)))
    (cond (*read-suppress*)
	  ((find #\: token)
	   (cerror ':no-action () 'sys:read-error-1  "Symbol following #: contains a #\: ~S" token))
	  (t (make-symbol token)))))

;(defun |XR-#:-MACRO| (stream ignore ignore)
;  (let ((read-intern-function 'read-uninterned-symbol))
;    (values (read-preserving-whitespace stream t () t)))) 


(defun sharp-left-paren (stream ignore  length )
  (let* ((elements (internal-read-list stream nil))
         (vector
          (make-sequence 'vector (or length (length elements)) :initial-element
                         (car (last elements)))))
    (if (and length (plusp length) (null elements))
        (cerror ':no-action () 'sys:read-error-1
                "The construct #~D() is illegal; at least one element must be given." length))
    (if (< (length vector) (length elements))
        (cerror ':no-action () 'sys:read-error-1
                "Elements specified are more than the specified length in #(..) vector construct."))
    (replace vector elements)
    vector)) 


(defun sharp-star (stream ignore numarg)
  (multiple-value-bind (bstring escape-appearedp)
		       (read-extended-token stream)
    (cond (*read-suppress*)
	  (escape-appearedp
	   (cerror ':no-action () 'sys:read-error-1 "Escape character appeared after #*"))
	  ((or (null numarg) (>= numarg (length bstring)))
	   (let* ((len1 (length bstring))
		  (last1 (1- len1))
		  (len2 (or numarg len1))
		  (bvec (make-array len2
				     :element-type '(mod 2)
				     :initial-element 0)))
	     (do ((i 0 (1+ i))
		  (char ()))
		 ((= i len2))
	       (setq char (elt bstring (if (< i len1) i last1)))
	       (setf (elt bvec i)
		     (cond ((char= char #\0) 0)
			   ((char= char #\1) 1)
			   (t
			    (cerror :no-action () 'sys:read-error-1
				    "Illegal element given for ~
					  bitvector #~A*~A"
				    numarg bstring)))))
	     bvec))
	  (t
	   (cerror ':no-action () 'sys:read-error-1 
		   "Bit vector is longer than specified length #~A*~A"
		   numarg bstring)))))
;(defun xr-#*-macro (stream ignore &optional (length xr-sharp-argument) &aux bit-vector last-element-read)
;  (if *read-suppress* (progn
;                        (read-preserving-whitespace stream t () t)
;                        ())
;      (progn
;        (setq bit-vector (make-array (or length 10) ':type 'art-1b ':leader-list '(0)))
;        (do (char
;             index
;             error-reported)
;            (NIL)
;          (setf (values char index) (xr-xrtyi stream () t))
;          (selector char char-equal
;                    ((#\0 #\1) (setq last-element-read (- char #\0))
;                     (if length
;                         (unless (or (array-push bit-vector last-element-read) error-reported)
;                           (cerror ':no-action () 'sys:read-error-1
;                                   "Number of data bits exceeds specified length in #* bit vector construct.")
;                           (setq error-reported t))
;                         (array-push-extend bit-vector last-element-read)))
;                    (t
;                     (if (and length (plusp length) (zerop (fill-pointer bit-vector)))
;                         (cerror ':no-action () 'sys:read-error-1
;                                 "The construct #~D* is illegal; at least one bit must be given."
;                                 length))
;                     (and length;; ARRAY-PUSH returns () when the fill pointer is at the end of the
;                          ;; array.
                          
;                          (loop while (array-push bit-vector last-element-read)))
;                     (xr-xruntyi stream char index)
;                     (let ((nvec (make-array (length bit-vector) ':type art-1b)))
;                       (copy-array-contents bit-vector nvec)
;                       (return nvec)))))))) 


(defun sharp-a (stream ignore  rank )
  (if *read-suppress* (progn
                        (read-preserving-whitespace stream t () t)
                        ())
      (if (and (fixnump rank) (plusp rank))
          (let (dimensions
                (sequences (read-preserving-whitespace stream t () t)))
            (do ((dim 0 (1+ dim))
                 (stuff sequences (elt stuff 0)))
                ((= dim rank))
              (push (length stuff) dimensions))
            (values (make-array (nreverse dimensions) ':initial-contents sequences)))
          (if (eq rank 0)
              (values (make-array () ':initial-element (read-preserving-whitespace stream t () t)))
              (progn
                (cerror ':no-action () 'sys:read-error-1 "~S is not a valid array rank." rank)
                (read-preserving-whitespace stream t () t)
                ()))))) 


(defun sharp-C (stream ignore ignore)
  ;;next thing better be a list of two numbers.
  (let ((cnum (read stream () () t)))
    (when *read-suppress* (return-from sharp-c nil))
    (if (= (length cnum) 2)
	(complex (car cnum) (cadr cnum))
	(cerror ':no-action () 'sys:read-error-1  "Illegal complex number format" cnum))))
 

(defun sharp-s (stream ignore  ignore)
  ;; 09/10/87 CLM for DNG - Use APPLY instead of EVAL so that the number
  ;;          of slots is not limited by the number of arguments that
  ;;          can be pushed on the stack.  [SPR 6268]
  (if *read-suppress* (progn
                        (read-preserving-whitespace stream t () t)
                        ())
      (let* ((args (read-preserving-whitespace stream t () t))
             (constructor
              (dolist (c (si:defstruct-description-constructors (get (car args) 'si:defstruct-description)))
                (if (or (atom c)(null (cdr c)) (and (stringp (cadr c)) (null (cddr c))))
                    (return (if (atom c) c (car c)))))))
        (if constructor
	    (let* ((defn (symbol-function constructor))
		   (macrop (eq (car-safe defn) 'macro))
		   (args (loop for (slot value) on (cdr args) by 'cddr append
			       (list (intern (symbol-name slot) *keyword-package*)
				     (if (and macrop (not (numberp value)))
					 `(quote ,value)
				       value)))))
	      (if macrop ; expand macro and evaluate
		  (si:*eval (cons constructor args))
		;; Use APPLY instead of EVAL so that the number of slots is not limited by the
		;; number of arguments that can be pushed on the stack.  [SPR 6268]
		(apply defn args)))
            (progn
              (cerror ':no-action () 'sys:read-error-1
                      "~S is not a structure type with a standard keyword constructor."
                      (car args))
              ())))))


;;; The following two sharp-sign reader macros allow tagged LISP objects to be read in.
;;; #n=object reads object and assigns the n label to it.  #n# refers that object
;;; (in other words it is EQ to it) later or at a lower level of S-expression.
;;; The variable SHARP-EQUAL-ALIST is an alist of a cons: a label (number) and
;;; a list of one element; that element is the LISP object to which the label refers.
;;; (It has to be a list so the binding can be a distinct object that you can RPLACA into.
;;; Also, it means that cdr[assq[tag;.sharp-equal-alist.]] be () is if the tag is
;;; defined.

(defun sharp-equal (stream ignore &optional label
			   &aux thing )
  (cond
    (*read-suppress* (values))
    ((not label) (cerror ':no-action () 'sys:read-error-1 "No argument (label number) to #= given."))
    ((assoc label sharp-equal-alist :test #'eq)	; The label is already defined, but we can't tell what it is yet.
     (cerror ':no-action () 'sys:read-error-1 "Label ~S already defined in this expression." label))
    (t
      (let ((tmp (list nil)))
	(push (cons label tmp) sharp-equal-alist)
	(push (cons tmp nil) sharp-sharp-alist)
	(let ((label-binding (assoc label sharp-equal-alist :test #'eq)))
	  (if (null label-binding)
	      (ferror 'sys:read-error-1 "Internal error in #= after reading in label's value.")
	      ;; The preceding line should never happen.  By writing into the slot
	      ;; will RPLACD, we also cause other places that referred to the label
	      ;; to get the value, too.
	      (progn
		(setf (car (cdr label-binding)) (setq thing (read-preserving-whitespace stream t () t)))
		;; Clear up colors
		(dolist (acons sharp-sharp-alist)
		  (setf (cdr acons) nil))
		(nsubstitute-eq-safe  thing (cdr label-binding) thing)	; Substitute for `self'
		(setf (cdr label-binding) (car (cdr label-binding)))
		thing)))))))
 
;;AB for PHD 7-27-87.  Add INSTANCE clause for circular instance variable contents [SPR 6081] 
(defun nsubstitute-eq-safe (new old seq &aux car cdr acons )
  (cond ((eq seq old) new)
	((cdr (setf acons (assoc seq sharp-sharp-alist
				 :test #'(lambda (item1 item2)
					   (eq item1 (car item2)))))) seq)       ; Already colored
	((arrayp seq)
	 ;;color the thing
	 (when acons (setf (cdr acons) t))
	 (dotimes (i (array-total-size seq))
	   (as-1-force (nsubstitute-eq-safe new old (ar-1-force seq i)) seq i))
	 seq)
	((instancep seq)
	 (when acons (setf (cdr acons) t))
	 (dotimes (i (1- (flavor-instance-size (instance-flavor seq))))
	   (set-%instance-ref seq (1+ i) (nsubstitute-eq-safe new old (%instance-ref seq (1+ i))))))
	((consp seq)
	 (when acons (setf (cdr acons) t))
	 (setq car (nsubstitute-eq-safe new old (car seq) ))
	 (unless (eq car (car seq)) (setf (car seq) car))
	 (setq cdr (nsubstitute-eq-safe new old (cdr seq) ))
	 (unless (eq cdr (cdr seq)) (setf (cdr seq) cdr))
	 seq)
	(t seq)))
 
(defun find-any-things (things tree)
  (if (null things) () (find-any-things-1 things tree))) 


(defun find-any-things-1 (things tree)
  (if (null tree) ()
      (if (consp tree)
          (or (find-any-things-1 things (car tree)) (find-any-things-1 things (cdr tree)))
          (member tree things :test #'eq))))  ; TREE is an atom


(defun sharp-sharp (stream ignore &optional label )
  stream; Not used, we never actually do a READ
  
  (cond
    (*read-suppress* NIL)
    ((not label) (cerror ':no-action () 'sys:read-error-1 "No argument (label number) to ## given."))
    ((null (assoc label sharp-equal-alist :test #'eq))
     (cerror ':no-action () 'sys:read-error-1 "The ##-label ~S is undefined." label))
    (t (cdr (assoc label sharp-equal-alist :test #'eq))))) 


(defun sharp-dot (stream ignore  ignore)
  (values
   (if *read-suppress* (progn
                         (read-preserving-whitespace stream t () t)
                         ())
       (compiler:eval-for-target (read-preserving-whitespace stream t () t))))) 


(defun xr-#-macro (stream ignore &optional arg)
  (internal-read-char stream t () t);Skip the / that follows.
  (%make-pointer dtp-character (%logdpb (or arg 0) %%ch-font (xr-#\\-macro stream () nil)))) 


(defun sharp-backslash (stream ignore &optional arg)
  (%make-pointer dtp-character (%logdpb (or arg 0) %%ch-font (xr-#\\-macro stream () nil)))) 


(defun xr-#\\-macro (stream ignore bits )
  (declare (ignore bits))
  (let (( char (internal-read-char stream t () t)))
    (if (not (or (<= #\A char #\Z) (<= #\a char #\z)))
	(char-int char)
	(progn
	  (unread-char char  stream)
	  (pkg-bind *keyword-package* 
	    (let* ((*read-base* 10.)
		   (frob (read-preserving-whitespace stream t () t)))   ;Get symbolic name of character
	      (if *read-suppress* 0                                     ;READ returns NIL in this case; don't bomb.
		  (if (= (length (symbol-name frob)) 1) (char-int char)
		      (or
			(cdr (assoc frob si:xr-special-character-names :test #'eq))
			(xr-parse-keyboard-char frob)
			(cerror ':no-action () 'sys:read-error-1
				"#\\~A is not a defined character-name." frob))))))))))


(defmacro xr-str-cmp (string)
  `(and (= len ,(length string))
     (%string-equal ,string 0 string 1+prev-hyphen-pos ,(length string)))) 

;;; This function is given a symbol whose print-name is expected to look
;;; like Control-Meta-A or Control-Meta-Abort or something.  It should return
;;; NIL if the print-name doesn't look like that, or the character code if
;;; it does.

(defun xr-parse-keyboard-char (sym)
  (and (or (symbolp sym) (stringp sym))
       (let ((string (if (stringp sym) sym (symbol-name sym)))
             top-flag
             greek-flag
             shift-flag)
         (loop with char = 0 with end = (array-active-length string) with tem = () for start
               first 0 then (1+ hyphen-pos) for 1+prev-hyphen-pos = 0 then (1+ hyphen-pos) for
               hyphen-pos = (or (position #\- (the string string) :start start :end end) end) do
               (let ((len (- hyphen-pos 1+prev-hyphen-pos)))
                 (cond
                   ((or (xr-str-cmp "CTRL") (xr-str-cmp "CONTROL"))
                    (setq char (dpb 1 %%kbd-control char)))
                   ((xr-str-cmp "META") (setq char (dpb 1 %%kbd-meta char)))
                   ((xr-str-cmp "HYPER") (setq char (%logdpb 1 %%kbd-hyper char)))
                   ((xr-str-cmp "SUPER") (setq char (dpb 1 %%kbd-super char)))
                   ((xr-str-cmp "GREEK") (setq greek-flag t))
                   ((xr-str-cmp "FRONT") (setq greek-flag t))
                   ((xr-str-cmp "TOP") (setq top-flag t))
                   ((or (xr-str-cmp "SHIFT") (xr-str-cmp "SH")) (setq shift-flag t))
                   ((= 1+prev-hyphen-pos (1- end))
                    (return
                     (greekify-character (char-int (aref string 1+prev-hyphen-pos)) greek-flag top-flag
                                         shift-flag char)))
                   ((= 1+prev-hyphen-pos (1- hyphen-pos))
                    (let ((tem
                           (assoc (char-upcase (aref string 1+prev-hyphen-pos))
                                  '((#\C . %%kbd-control) (#\M . %%kbd-meta) (#\H . %%kbd-hyper)
                                   (#\S . %%kbd-super))
                                  :test #'eq)))
                      (if (null tem) (return ())
                          (setq char (%logdpb 1 (symbol-value (cdr tem)) char)))))
		   ;; See if we have a name of a special character "Return", "SP" etc.
                   
                   ((setq tem
                          (dolist (elem si:xr-special-character-names)
                            (let ((target (symbol-name (car elem))))
                              (if
                               (string-equal target string :start1 0 :start2 1+prev-hyphen-pos
                                             :end1 (array-active-length target) :end2 end)
                               (return (cdr elem))))))
		    ;; Note: combine with LOGIOR rather than DPB, since mouse
                    ;; characters have the high %%KBD-MOUSE bit on.
                    (return (greekify-character tem greek-flag top-flag shift-flag char)))
                   (t (return ())))))))) 

;Given a character, return the greek or top equivalent of it according to
;the specified flags.  If the flags are all NIL, the original character is returned.

(defun greekify-character (start-char greek-flag top-flag shift-flag &optional (metabits 0))
  (cond
    ((and top-flag greek-flag) NIL)
    (greek-flag
     (let* ((greek-char
             (dotimes (i 200)
               (and
                (or (= start-char (aref si:kbd-ti-table 0 i))
                    (= start-char (aref si:kbd-ti-table 1 i)))
                (if shift-flag (return (aref si:kbd-ti-table 4 i))
                    (return (aref si:kbd-ti-table 3 i)))))))
       (and greek-char (not (logtest (lsh 1 15) greek-char)) (logior metabits greek-char))))
    ((and shift-flag (<= (char-code #\A)
			 (ldb %%kbd-char start-char)
			 (char-code #\Z)));; Shift on a letter lowercasifies.
     (logior metabits (char-downcase start-char)))
    ;; Otherwise SHIFT is only allowed with GREEK.
    (shift-flag NIL)
    (top-flag
     (let* ((top-char
             (dotimes (i 200)
               (and (= start-char (aref si:kbd-ti-table 1 i)) (return (aref si:kbd-ti-table 2 i)))
               (and (= start-char (aref si:kbd-ti-table 0 i)) (return (aref si:kbd-ti-table 2 i))))))
       (and top-char (not (logtest (lsh 1 15) top-char)) (logior metabits top-char))))
    (t (logior metabits start-char)))) 


(defun xr-#^-macro (stream ignore &optional ignore)
  (let ((ch (internal-read-char stream t () t)))
    (dpb 1 %%kbd-control (char-upcase ch)))) 


(defun xr-#q-macro (stream ignore &optional ignore);For Lispm, gobble frob.
  (values (read-preserving-whitespace stream t () t))) 


(defun xr-#m-macro (stream ignore &optional ignore);For Maclisp.  Flush frob.
  (let ((*read-suppress* t))
    (read-preserving-whitespace stream t () t))
  (values)) 


(defun xr-#n-macro (stream ignore &optional ignore);For NIL.  Flush frob.
  (let ((*read-suppress* t))
    (read-preserving-whitespace stream t () t))
  (values)) 

;#FOO ... represents an instance of flavor FOO.
;The flavor FOO should have a :READ-INSTANCE method, which is called
; with SELF bound to nil, and arguments :READ-INSTANCE, the flavor name, and the stream.
;It should return the constructed instance
; with the terminating  as the next character to be read.
;Alternatively, the symbol FOO should have a SI:READ-INSTANCE property.
;This property overrides the use of the flavor method.
;Using a property enables you to put it on any symbol you like,
;not necessarily the name of the (or any) flavor.  For example, you can
;put it in USER: this way, making it unnecessary to use a package prefix when you print.

;;PAD 3/11/87 don't do unread-char if char is nil (end of file).
(defun xr-#-macro (stream ignore  ignore)
  (if *read-suppress* (progn
                        (read-delimited-list #\ stream t)
                        ())
      (let* ((flavor-name (let ((*package* si:pkg-user-package))
                            (read-preserving-whitespace stream t () t)))
             (instance
              (let ((handler
                     (or (si:get flavor-name 'read-instance)
                         (si:get-flavor-handler-for flavor-name ':read-instance)))
                    (self NIL))
                (funcall handler ':read-instance flavor-name stream)))
             (char (internal-read-char stream nil () t)))
	;; Make sure that the read-instance function read as much as it was supposed to.
        (if (eql char #\) instance
            (progn
              (when char (unread-char char  stream))
              (cerror ':no-action () 'sys:read-error-1
                      "Malformatted #~S... encountered during READ." flavor-name)))))) 


(defun sharp-vertical-bar (stream ignore  ignore)
  (prog ((n 0))
    (go home)
    sharp
    (case (internal-read-char stream nil () t)
      (#\# (go sharp))
      (#\| (setq n (1+ n)))
      (#\/ (internal-read-char stream nil () t))
      (NIL (go barf)))
    home
    (case (internal-read-char stream nil () t)
      (#\| (go bar))
      (#\# (go sharp))
      (#\/ (internal-read-char stream nil () t) (go home))
      (NIL (go barf))
      (t (go home)))
    bar
    (case (internal-read-char stream nil () t)
      (#\# (cond
             ((zerop n) (return (values)))
             (t (setq n (1- n)) (go home))))
      (#\| (go bar))
      (#\/ (internal-read-char stream nil () t) (go home))
      (NIL (go barf))
      (t (go home)))
    barf
    (cerror ':no-action () 'sys:read-error-1
            "The end of file was reached while reading a #| comment."))) 

;  Read-time conditionalization macros
;  <feature-form> ::= <symbol-or-number> | (NOT <feature-form>)
;		     | (AND . <feature-forms>) | (OR . <feature-forms>)

;  As an example, (AND MACSYMA (OR LISPM AMBER)) is a feature form
;  which represents the predicate
;  (AND (STATUS FEATURE MACSYMA) (OR (STATUS FEATURE LISPM) (STATUS FEATURE AMBER))).
;  The use of these forms in conjuction with the #+ reader macro
;  enables the read-time environment to conditionalize the
;  reading of forms in a file.

;  #+<FEATURE-FORM> <FORM> is read as <FORM> if <FEATURE-FORM> is true,
;  i.e. if the predicate associated with <FEATURE-FORM> is non-NIL when
;  evaluated in the read-time environment.
;  #+<FEATURE-FORM> <FORM> is read as whitespace if <FEATURE-FORM> is false.

;  #+LISPM <FORM> makes <FORM> exist if being read by the Lisp Machine.
;  #+(OR LISPM LISPM-COMPILER) <FORM> makes <FORM> exist if being
;  read either by the Lisp Machine or by QCMP.  This is equivalent
;  to #Q <FORM>.  Similarly, #+(AND MACLISP (NOT LISPM-COMPILER)) is
;  equivalent to #M.


(defun sharp-plus (stream ignore  ignore)
  (let ((feature (let ((*package* *keyword-package*)
                       (*read-base* 10)
		       (sys::*restrict-internal-symbols* nil))
                   (read-preserving-whitespace stream t () t))));feature or feature list
    (cond
      (*read-suppress* (values))
      ((not (xr-feature-present feature))
       (let ((*read-suppress* t))
         (read-preserving-whitespace stream t () t)) (values))
      (t (values (read-preserving-whitespace stream t () t)))))) 

;  #-<FEATURE-FORM> is equivalent to #+(NOT FEATURE-FORM).


(defun sharp-minus (stream ignore  ignore)

  (let ((feature (let ((*package* *keyword-package*)
                       (*read-base* 10)
		       (sys::*restrict-internal-symbols* nil))
                   (read-preserving-whitespace stream t () t))));feature or feature list

        
    (cond
      (*read-suppress* (values))
      ((xr-feature-present feature) (let ((*read-suppress* t))
                                      (read-preserving-whitespace stream t () t))
       (values))
      (t (values (read-preserving-whitespace stream t () t)))))) 
 

;  Here, FEATURE is either a symbol to be looked up in (STATUS FEATURES) or
;  a list whose car is either AND, OR, or NOT.
;  Numbers may also be used--they are always taken to be decimal.
;  This is useful since people tend to name computers with numbers for some reason.


(defun xr-feature-present (feature)
  (cond
    ((symbolp feature) (member feature *features* :test #'string-equal))
    ((numberp feature) (member feature *features* :test #'equal))
    ((atom feature)
     (cerror ':no-action () 'sys:read-error-1 "Unknown form ~S in #+ or #- feature list." feature))
    ((eq (car feature) ':not) (not (xr-feature-present (cadr feature))))
    ((eq (car feature) ':and) (every #'xr-feature-present (cdr feature)))
    ((eq (car feature) ':or) (some #'xr-feature-present (cdr feature)))
    (t (cerror ':no-action () 'sys:read-error-1 "Unknown form ~S in #+ or #- feature list." feature)))) 

;;;Lisp Mode Reader Macro 


(defun xr-#!-macro (stream ignore &optional ignore)
  (case (internal-read-char stream)
    ((#\C #\c)
     (with-common-lisp-on
        (values (read-preserving-whitespace stream t () t))))
    ((#\Z #\z)
     (with-zetalisp-on
        (values (read-preserving-whitespace stream t () t))))
    (t (cerror ':no-action () 'sys:read-error-1 "Unknown Lisp Mode option in #! Reader Macro"))))

(defun sharp-illegal (ignore sub-char ignore)
  (cerror :no-action () 'sys:read-error-1 "Illegal sharp character ~S" sub-char))