;;;  SHARPM 	   -*-mode:lisp;package:si-*-			    -*-LISP-*-
;;;  *************************************************************************
;;;  ***** NIL ****** NIL/MACLISP/LISPM Compatible # Macro  ******************
;;;  *************************************************************************
;;;  ******** (c) Copyright 1981 Massachusetts Institute of Technology *******
;;;  ************ this is a read-only file! (all writes reserved) ************
;;;  *************************************************************************

(herald SHARPM /82)

;;Note well:  FORMAT versions > 700 use the list /#-SYMBOLIC-CHARACTERS-TABLE,
;; defined on the next page, to invert character names.  For any given 
;; character value, the first entry is used, so that should be the preferred 
;; full name of the character. (The ordering by character code is gratuitous.)

(eval-when (eval compile)
  (cond ((status feature MacLISP)
	  (or (get 'SUBLOAD 'VERSION)
	      (load '((lisp) subload)))
	  (setq USE-STRT7 'T)))
  (cond ((or (not (status feature NIL))
	     (and (status feature NILAID)
		  (not (status feature FOR-NIL))))
	  (if (status feature COMPLR)
	      (special *:TRUTH /#-MACRO-DATALIST))
	   ;;Canonical way to get at boolean truthity
	  (setq *:TRUTH 'T)
	   ;;An A-list for associating readtables with their #-macro-datalists.
	  (if (or (not (boundp '/#-MACRO-DATALIST))
		  (null /#-MACRO-DATALIST))
	      (setq /#-MACRO-DATALIST (list `(,READTABLE . ()))))))
 )

(eval-when (eval compile load)
  (cond ((status feature MacLISP)
	  (cond ((and (status feature COMPLR) (fboundp '*lexpr)) 
		  (*lexpr SETSYNTAX-SHARP-MACRO)
		  (*expr SI:FEATUREP? SI:GET-FEATURE-SET))))
	('T (globalize "DEFSHARP")
	    (globalize "SETSYNTAX-SHARP-MACRO")))
  )


;;;;Defvar's

(defvar  /#-SYMBOLIC-CHARACTERS-TABLE 
	  '((NULL . 0)
	    (ALPHA . 2)
	    (BETA . 3)
	    (EPSILON . 6)
	    (BELL . 7.)
	    (BACKSPACE . 8.) (BS . 8)
	    (TAB . 9)
	    (LINEFEED . 10.) (LF . 10.)
	    (VT . 11.)
	    (FORM . 12.) (FORMFEED . 12.) (FF . 12.)
	    (RETURN . 13.) (NEWLINE . 13.) (CR . 13.) (NL . 13.)
	    (ALTMODE . 27.) (ALT . 27.)
	    (BACK-NEXT . 31.) 
	    (SPACE . 32.) (SP . 32.)  
	    (DELETE . 127.) (RUBOUT . 127.)
	    (HELP . 2120.)
	    ))


(defvar |#-C-M-bits| '(128.  256. 384.)
  "List of control and meta bits	;2^7, 2^8, 2^7+2^8 ")


(defvar TARGET-FEATURES 'LOCAL  
  "To allow for smooth interface to SHARPCONDITIONALS package.")
(defvar SI:FEATUREP? () 
  "Used to communicate caller's function name to function SI:FEATUREP?")

(defvar SI:/#-TEST () 
  "Used to block out certain errors if reading 'under' one of #N, #Q, or #M.")


;;;; Temporary MACROS and "Scotch-tape"


(eval-when (eval compile)

(setq defmacro-for-compiling () )

(cond ((or (not (status feature NIL))
	   (and (status feature NILAID)
		(not (status feature FOR-NIL))))
        (defsimplemac CHARACTER (c)
	  `(CASEQ (TYPEP ,c)
	     (FIXNUM ,c)
	     (SYMBOL (GETCHARN ,c 1))
	     (T (ERROR "Not a character - CHARACTER" ,c))))
	(defmacro *:FIXNUM-TO-CHARACTER (x) x)
	(defmacro CHARACTERIFY (x) x)
	(defmacro CHARACTERIZE (x) `(ASCII ,x))
	(defmacro /#SUB-READ (&rest x) x '(READ))
	(defmacro READ-TOKEN (simplep ttt b () ) 
	  `(*read-token ,simplep ,(and (eq ttt '~*) ''*) ,b () ))
	(defmacro READTABLE-sharp-macro-list (x) 
	  `(CDR (ASSOC ,x /#-MACRO-DATALIST)))
	(defmacro /#TYI (&rest ()) `(TYI))
	(defmacro /#TYIPEEK (&rest ()) `(TYIPEEK)))
      ('T 
        (defvar NON-DECDIGIT-TABLE () 
	  "Should be set up by READER.")
	(defmacro /#SUB-READ (&rest x) 
	   ;;In order to "bootstrap"-read this file, we must start out using
	   ;;   maclisp's old reader - when it is fully in, then the definition
	   ;;   of /#SUB-READ is changed to be SUB-READ
	  (cond ((and (status feature NILAID)
		      (not (status feature FOR-NIL)))
		 `(OLD-READ))			;bootstrap case, with NILAID
		('T `(SUB-READ ,.x))) 		;standard NIL case
	  )
	(defmacro CHARACTERIFY (x) `(*:FIXNUM-TO-CHARACTER ,x))
	(defmacro CHARACTERIZE (x) `(*:FIXNUM-TO-CHARACTER ,x))
	(defmacro /#TYI (&rest w) `(*:CHARACTER-TO-FIXNUM (READER-INCH ,.w)))
	(defmacro /#TYIPEEK (&rest w) 
	  `(*:CHARACTER-TO-FIXNUM (READER-INCHPEEK ,.w)))))

(setq defmacro-for-compiling 'T)

)



;;;; DEFSHARP and SETSYNTAX-SHARP-MACRO

 (eval-when (eval compile)
   (setq defmacro-for-compiling 'T defmacro-displace-call () )
   (and (status feature MacLISP) 
	(status feature COMPLR)
	(own-symbol  SETSYNTAX-SHARP-MACRO  DEFSHARP))
   )

(defmacro DEFSHARP (C &REST BODY)
      (LET ((NAME (IMPLODE (APPEND '(/# - M A C R O -) (LIST C)))) 
	    (IND (COND ((MEMQ (CAR BODY) 
			      '(MACRO SPLICING PEEK PEEK-MACRO PEEK-SPLICING))
			(PROG2 () (CAR BODY) (SETQ BODY (CDR BODY))))
		       ('MACRO))))
	     ;Standardize on character representation as fixnum
	   `(PROGN 'COMPILE
		   (DEFUN ,name ,. body)
		   (SETSYNTAX-SHARP-MACRO ',c ',ind ',name))))


(defun SETSYNTAX-SHARP-MACRO (C IND FUN &OPTIONAL (RT READTABLE) )
  (declare (special READTABLE))
  (LET ((SPLICEP (IF (MEMQ IND '(SPLICING PEEK-SPLICING))
		     'SPLICING 
		     'MACRO))
	(PEEKP (AND (MEMQ IND '(PEEK PEEK-MACRO PEEK-SPLICING)) 'T))
	(MDL (prog2 (if (and (status feature MacLISP) 
			     (null (assoc rt /#-MACRO-DATALIST)))
			(push `(,rt . () ) /#-MACRO-DATALIST))
		    (READTABLE-sharp-macro-list RT))))
    (SETQ C (CHARACTER C))
     ;;Upper-casify if necessary
    (AND (NOT (< C #/a))
	 (NOT (> C #/z))
	 (SETQ C (- C (- #/a #/A))))
    (SETQ C (CHARACTERIFY C))
     ;;Delete any previous entries
    (DO ((Y (ASSOC C MDL) (ASSOC C MDL)))
	((NULL Y))
      (SETQ MDL (DELQ Y MDL)))
    (AND FUN (PUSH `(,c ,peekp ,splicep . ,fun) MDL))
    (SETF (READTABLE-sharp-macro-list RT) MDL)
    FUN))


;;;; +INTERNAL-/#-MACRO and helpers

(eval-when (compile)
  (and (status feature MacLISP)
       (own-symbol  +INTERNAL-/#-MACRO  /#+--TEST-FOR-FEATURE 
		    /#-CNTRL-META-IFY  /#-FLUSH-CHARS-NOT-SET ))
)

 ;The # macro works by keying off a second character, with possibly an
 ;  argument in between.  Currently, the permissible arguments are
 ;   (1) digits, for a numeric argument
 ;   (2) ^B, ^C, or ^F   to signify "add control, meta, or control-meta"
 ;The alist from /#-MACRO-DATALIST holds for each valid "second" character
 ;  a 4-list:
 ;  	(<char-code>  <peekp>  <type>  <function>)
 ;   <function>   takes one argument, as described above [or () if none]
 ;   <type>  	  is either MACRO or SPLICING
 ;   <peekp>      is a flag which, if non-null, means don't flush the "second"
 ;		  character from the input stream before running <function>.
 ;   <char-code>  is the numeric encodeing of the character


(eval-when (eval compile)
  (if (status feature MacLISP)
      (defmacro make-/#-macro-fun ()
	'(DEFUN +INTERNAL-/#-MACRO () 
	   (SI:/#-MACRO-1 () )))
      (defmacro make-/#-macro-fun ()
	'(DEFUN +INTERNAL-/#-MACRO (C S)
	   (AND (OR (NOT (EQ C ~/#)) (NOT (EQ S READ-STREAM)))
		(READER-ERROR S))
	   (SI:/#-MACRO-1 S))))
)

(make-/#-macro-fun)

(defun SI:/#-MACRO-1 (S)
  (declare (special READTABLE) 
	   (fixnum c))
  (LET ((C (/#TYIPEEK S)) 
	(MDL (READTABLE-sharp-macro-list READTABLE) )
	MACRO-ARG PEEKP MACRO-TYPE MACRO-FUN UC TMP)
     ;;MACRO-ARG accumulates an "infix" argument, like a number in the 
     ;;  #16R... case.   The argument is the item between the "#" and 
     ;;  the dispatchable character.
    (IF (COND ((<= #/0 C #/9)
	       (SETQ MACRO-ARG (READ-TOKEN 'FIXNUMP NON-DECDIGIT-TABLE 10. S))
	       'T)
	      ((SETQ MACRO-ARG (CASEQ C
				 (2 (/#TYI S) 'CONTROL)		;#/ (alpha)
				 (3 (/#TYI S) 'META)		;#/ (beta)
				 (6 (/#TYI S) 'CONTROL-META)	;#/ (epsilon)
				 (T () )))
	       'T))
	(SETQ C (/#TYIPEEK S)))
     ;;Find flags/function for this character
    (SETQ UC (if (AND (NOT (< C #/a)) (NOT (> C #/z)))
		  ;;Upper-casify if necessary
		 (- C (- #/a #/A))
		 C))
    (SETQ UC (CHARACTERIFY UC))
    (COND ((SETQ TMP (ASSOC UC MDL)))
	  ('T (/#TYI S) 			;flush the character
	      (ERROR '|Unknown dispatch character after #|
		     (CHARACTERIZE C))))
    (DESETQ ( ()  PEEKP  MACRO-TYPE . MACRO-FUN ) TMP)
    (AND (OR (NULL MACRO-FUN) 
	     (NOT (MEMQ MACRO-TYPE '(MACRO SPLICING))))
	 (ERROR '"Garbage format in #-MACRO-DATALIST" (CHARACTERIZE C)))
    (AND (NOT PEEKP) (/#TYI S)) 
    (SETQ MACRO-ARG (FUNCALL MACRO-FUN MACRO-ARG))
    (CASEQ MACRO-TYPE 
      (MACRO     (LIST MACRO-ARG))
      (SPLICING  MACRO-ARG))))


;;;; Helper funs

(DEFUN /#+--TEST-FOR-FEATURE (F)
   (COND ((ATOM F) 
	   (MEMQ F (STATUS FEATURES)))
	 ((EQ (CAR F) 'NOT) 
	   (IF (OR (NULL (CDR F))		; Disallow #+(NOT)
		   (CDDR F))			; Disallow #+(NOT f1 f2 ...)
	       (ERROR '|Bad features list for #+ or #-| F))
	   (NOT (/#+--TEST-FOR-FEATURE (CADR F))))
	 ((EQ (CAR F) 'AND)	
	   (do ((l (cdr f) (cdr l)))
	       ((null l) 'T)
	     (if (not (/#+--TEST-FOR-FEATURE (car l)))
		 (return () ))))
	 ((EQ (CAR F) 'OR)
	   (do ((l (cdr f) (cdr l)))
	       ((null l) () )
	     (if (/#+--TEST-FOR-FEATURE (car l))
		 (return 'T))))
	  ;If we ever decide to make #+(MACLISP BIBOP) default
	  ; to anything, here is the place to do it
	 ('T (ERROR '|Bad features list for #+ or #-| F))))


(DEFUN /#-CNTRL-META-IFY (MACRO-ARG N CHAR)
   (COND ((NULL MACRO-ARG) N)
	 ((EQ MACRO-ARG 'CONTROL) (+ N (CAR |#-C-M-bits|)))	    ;Cntrl bit
	 ((EQ MACRO-ARG 'META) (+ N (CADR |#-C-M-bits|)))	    ;Meta bit
	 ((EQ MACRO-ARG 'CONTROL-META) (+ N (CADDR |#-C-M-bits|)))  ;Both bits
	 ('T (ERROR '|Bad argument to a # function|
		    (LIST MACRO-ARG CHAR)))))



(eval-when (eval compile)
		 
(cond ((or (not (status feature NIL))
	   (and (status feature NILAID)
		(not (status feature FOR-NIL))))
        (defmacro make-non-NIL-helper-funs () 
	  `(progn 'compile 

(defun |#-MACRO-T| (() )	;#T is "truthity", not false
  (if (and (not (status feature NIL))
	   (not (eq SI:/#-TEST 'N)))
      (error '|Unknown dispatch character after #| 'T))
  *:TRUTH)
;; An open-coding of DEFSHARP, with added crinkle about EXTEND package
(or (and (get 'EXTEND 'VERSION) 
	 (assoc #/T (READTABLE-sharp-macro-list READTABLE)))
    (setsyntax-sharp-macro #/T 'MACRO '|#-MACRO-T|))


(defun *READ-TOKEN (simplep gobble-terminatorp b () )
   (declare (fixnum n c b*))
   (and (or (not (eq (typep b) 'FIXNUM))
	    (< b 1)
	    (> b 36.)
	    (not (memq simplep '(FIXNUMP NUMBERP))))
	(+internal-lossage () '*READ-TOKEN (list simplep b)))
   (caseq simplep 
	  (FIXNUMP
	   (do ((c (tyipeek) (tyipeek)) 
		(n 0 (+ (- c #/0) 
			(if (eq gobble-terminatorp '*)
			     ;; losing #*...* format is octal
			    (lsh n 3)
			    (* n b))))
		(b* (+ b #/0)))
	       ((or (< c #/0) (not (< c b*)))
		(and gobble-terminatorp (tyi))
		n)
	     (tyi)))
	  (NUMBERP 
	   (let ((save (status /+)) (ibase b) ans)
		(setq ans (cond (save (read))
				((unwind-protect 
				  (prog2 (sstatus /+ 'T ) (read))
				  (sstatus /+ save)))))
		(or (numberp ans) 
		    (error '"Numeric token expected by some #-function" ans))
		ans))))

(defsharp /: splicing (() )  (/#-flush-chars-not-set #/: 'T) () )

(defun /#-flush-chars-not-set (s finalp)
       (do ((c (tyipeek) (tyipeek)) 
	    (fixp (eq (typep s) 'fixnum)))
	   ((cond (fixp (= c s))
		  ((member c s)))
	    (and finalp (tyi))
	    (list () ))
	 (and (= c #//) (tyi))
	 (tyi)))


(defun /#-bs-reader (x lbb char)
    ;; "lbb" is Log-Binary-Base; e.g. 1 for binary, 3 for octal, and 4 for hex
   (and x (error '|Bad argument to a # function| (list '/#  char x)))
   (cond ((not (= (tyipeek) #/")) 
	   (read-token 'NUMBERP 
		       token-terminator-table  
		       (^ 2 lbb) 
		       () ))
	 ('T (/#-/#B-reader lbb))))

(if (status feature MacLISP)
    (def-or-autoloadable /#-/#B-reader BITS))

)))

	('T (defmacro make-non-NIL-helper-funs ()
		`(defsharp #/T (() ) *:TRUTH)))
))

(make-non-NIL-helper-funs)



;;;; Lesser used sharps


;;; "controlify", which for 7-bit ascii means just to complement the 100 bit.
(defsharp /^  (() )
   (let ((c (tyi)))
	(or (< c #/a)		;lower case "a"
	    (> c #/z)		;lower case "z"
	    (setq c (- c (- #/a #/A))))
	(boole 6 1_6 c)))


(defsharp /* (() ) (read-token 'FIXNUMP ~* 8 READ-STREAM))

(defsharp /| SPLICING (() ) 
  (prog (n )
	(declare (fixnum n))
	(setq n 0)
	(go home)
  sharp (caseq (/#tyi READ-STREAM)
	  (#/# (go sharp))
	  (#/| (setq n (1+ n)))
	  (#// (/#tyi READ-STREAM))
	  (-1   (go barf)))
   home (caseq (/#tyi READ-STREAM)
	  (#/| (go bar))
	  (#/# (go sharp))
	  (#// (/#tyi READ-STREAM)
	       (go home))
	  (-1  (go barf))
	  (T   (go home)))
    bar (caseq (/#tyi READ-STREAM)
	  (#/# (cond ((= n 0) (return () ))
		     (T (setq n (1- n))
			(go home))))
	  (#/| (go bar))
	  (#// (/#tyi READ-STREAM)
	       (go home))
	  (-1 (go barf))
	  (T  (go home)))
   barf (error () "EOF within read of # comment")))

(defsharp /R (macro-arg)
  (if (or (not (eq (typep macro-arg) 'FIXNUM))
	  (< macro-arg 1) 
	  (> macro-arg 36.))
      (error "Bad numeric base for #nR" macro-arg))
  (read-token 'NUMBERP
	      token-terminator-table 
	      macro-arg 
	      read-stream))

(defsharp /B (c) 		;#B"..."  for BITS's in binary form
    (/#-bs-reader c 1 'B))


;;;; Common /# macros - definitions

(defsharp /'  (() ) `(FUNCTION ,(/#sub-read () READ-STREAM)))

(defsharp // (macro-arg)  (/#-cntrl-meta-ify macro-arg (tyi) '//))

(defsharp /% (() ) (macroexpand (/#sub-read () READ-STREAM)))

(defsharp /.  (() ) (eval (/#sub-read () READ-STREAM)))

(defsharp /,  (() ) 
   (let ((form (/#sub-read () READ-STREAM)))
	(declare (special squid))
	(cond ((memq COMPILER-STATE '(NIL () TOPLEVEL))
	       (eval form))
	      ('T `(,squid ,form)))))

(defsharp /\  (macro-arg)
   (let ((n (/#-/\-parse)))
	(/#-cntrl-meta-ify macro-arg n '/\)))

(defun /#-/\-parse () 
   (let* ((ob (/#sub-read () READ-STREAM))
	  (n (do ((l (and (symbolp ob) /#-SYMBOLIC-CHARACTERS-TABLE) (cdr l)))
		 ((null l) () )
	       (and (samepnamep ob (caar l)) (return (cdar l))))))
     (and (null n) 
	  (caseq SI:/#-TEST 
	    (M (status feature MacLISP))
	    (Q (status feature LISPM))
	    (N (status feature NIL)))
	  (error '"Unknown symbolic name to #\" ob))
     n))



(defsharp /+ SPLICING (())
  (si:/#+or-read (/#sub-read () READ-STREAM) 'T () ))

(defsharp /- SPLICING (())
  (si:/#+or-read (/#sub-read () READ-STREAM) () () ))

(defun SI:/#+OR-READ (features polarity SI:/#-TEST)
   (if (null SI:/#-TEST)
       (let ((z (assq features '((MacLISP . M) (LISPM . Q) (NIL . N)))))
	 (if z (setq SI:/#-TEST (cdr z)))))
   (let ((form (/#sub-read () READ-STREAM)))
     (if (cond ((get 'SHARPCONDITIONALS 'VERSION) 
		(let ((SI:FEATUREP? 'SI:/#+OR-READ))
		  (si:featurep? 
		      features 
		      (si:get-feature-set TARGET-FEATURES 'SI:/#+OR-READ) 
		      polarity)))
	       ((/#+--test-for-feature features) polarity)
	       ('T (not polarity)))
	 (list form))))


(defsharp /M SPLICING (()) (SI:/#+OR-READ 'MacLISP 'T 'M))
(defsharp /N SPLICING (()) (SI:/#+OR-READ 'NIL 'T 'N))
(defsharp /Q SPLICING (()) (SI:/#+OR-READ 'LISPM 'T 'Q))

(defsharp /O (c) (/#-bs-reader c 3 'O))
(defsharp /X (c) (/#-bs-reader c 4 'X))

(cond ((status feature MacLISP)
        (defprop function (lambda () (readmacroinverse |#'|)) grindmacro)
	 (defprop function readmacroinverse-predict grindpredict)
	 (or (status macro /#)
	     (setsyntax '/# 'SPLICING '+INTERNAL-/#-MACRO))))