;;; Definitions for the -*- Mode:LISP; Package:SI; Base:8; Readtable:ZL -*- machine reader

;;; WARNING! if you change anything in this file, not only might you
;;; have to recompile READ and PRINT, but RTC as well, and then you
;;; may have to load RTC and recompile the readtable from RDTBL
;;; using RTC-FILE.

(DEFSTRUCT (READTABLE :ARRAY-LEADER :NAMED
		      (:CONSTRUCTOR MAKE-RDTBL)
		      (:MAKE-ARRAY (:DIMENSIONS (RDTBL-ARRAY-DIMS) :TYPE 'ART-16B))
		      (:DEFAULT-POINTER RDTBL)
		      (:SIZE-MACRO RDTBL-SIZE))
  ;; first slot is sacred
  (RDTBL-FSM NIL :DOCUMENTATION
    "The readtable's finite-state machine")
  (RDTBL-N-STATES 0 :DOCUMENTATION
    "Number of states in RDTBL-FSM")
  (RDTBL-N-BUCKETS 0 :DOCUMENTATION
   "Number of buckets in RDTBL-FSM")
  (RDTBL-STARTING-STATE 0 :DOCUMENTATION
   "Starting state for the RDTBL-FSM")
  (RDTBL-SLASH-CODE NIL :DOCUMENTATION
   "Code used for escape-quoted characters")
  (RDTBL-EOF-CODE NIL :DOCUMENTATION
   "Code used to indicate EOF read")
  (RDTBL-BREAK-CODE NIL :DOCUMENTATION
   "Code used to indicate breaks")
  (RDTBL-MACRO-ALIST NIL :DOCUMENTATION
   "Alist of character and macro reader it invokes.")
  (RDTBL-READ-FUNCTION-PROPERTY NIL :DOCUMENTATION
   "")
  (RDTBL-PLIST NIL :DOCUMENTATION
   "Random useful information about this readtable.")
  (RDTBL-DEFINITION NIL :DOCUMENTATION
   "The list structure from which RTC made this readtable.")
  (RDTBL-MAKE-SYMBOL NIL :DOCUMENTATION
   "")
  (RDTBL-MAKE-SYMBOL-BUT-LAST NIL :DOCUMENTATION
   "")
; (RDTBL-SLASH nil :documentation "Not used")
  ;; used in xr-xrtyi and peek-char
  (RDTBL-WHITESPACE NIL :DOCUMENTATION
   "Stuff which is to be counted a whitespace by the reader when using this readtable")
; (RDTBL-CIRCLECROSS nil :documentation "Not used")
  (RDTBL-ESCAPE-CODE		#// :DOCUMENTATION
   "The code representing the character used to quote single characters")
  (RDTBL-MULTIPLE-ESCAPE-CODE	#/| :DOCUMENTATION
   "The code representing the character used to quote multiple characters")
  (RDTBL-CHARACTER-CODE-ESCAPE-CODE #/ :DOCUMENTATION
   "The code representing the character used to read
arbitrary character codes as an octal number")
  (RDTBL-NAMES NIL :DOCUMENTATION
    "A list of strings which are names for this readtable")
  (PTTBL-SPACE			#/SPACE  :DOCUMENTATION
   "The character for printing a space")
  (PTTBL-NEWLINE		#/RETURN :DOCUMENTATION
   "The character to use for printing a newline")
  (PTTBL-CONS-DOT 		" . " :DOCUMENTATION
   "The string to print meaning /"cons-dot/" in lists")
  (PTTBL-MINUS-SIGN 		#/- :DOCUMENTATION
   "The character to print for a minus sign")
  (PTTBL-DECIMAL-POINT	 	#/. :DOCUMENTATION
   "The character to print for a decimal point")
  (PTTBL-SLASH 			#// :DOCUMENTATION
   "The character to print to escape a single character")
  (PTTBL-PRINLEVEL 		"#" :DOCUMENTATION
   "The string to print to indicate the list printing is being abbreviated
because the list structure was too deeply nested.")
  (PTTBL-PRINLENGTH 		"..." :DOCUMENTATION
   "The string to print to indicate that list printing is being truncated
because the list was too long.")				
  (PTTBL-RANDOM 		'("#<" . ">") :DOCUMENTATION
   "Car is the string to print to indicate the start of a random (unreadable) object.
Cdr is string to print to indicate end.")
  (PTTBL-OPEN-PAREN 		#/( :DOCUMENTATION
   "The character to print for an open parenthesis")
  (PTTBL-CLOSE-PAREN 		#/) :DOCUMENTATION
   "The character to print for a close parenthesis")
  (PTTBL-OPEN-QUOTE-STRING 	#/" :DOCUMENTATION
   "The character to print at the start of a quoted string")
  (PTTBL-CLOSE-QUOTE-STRING	#/" :DOCUMENTATION
   "The character to print at the end of a quoted string")
  (PTTBL-OPEN-QUOTE-SYMBOL 	#/| :DOCUMENTATION
   "The character to print at the start of a quoted symbol")
  (PTTBL-CLOSE-QUOTE-SYMBOL 	#/| :DOCUMENTATION
   "The character to print at the end of a quoted symbol")
  (PTTBL-PACKAGE-PREFIX		":" :DOCUMENTATION
   "The string to print between a package name and the symbol's pname
for symbols which are /"directly accessible/" from the current")
  (PTTBL-PACKAGE-INTERNAL-PREFIX":" :DOCUMENTATION
   "The string to print between a package name and the symbol's pname
for symbols which are not /"directly accessible/" from the current package")
  (PTTBL-CHARACTER		'("#" "//") :DOCUMENTATION
   "Cons of The string to print to start a character,
and the string to print between the character font and the character name")
  (PTTBL-RATIONAL-INFIX		#/\ :DOCUMENTATION
   "The character to print between the numerator and denominator of a ratio")
  (PTTBL-COMPLEX		'("" NIL "i") :DOCUMENTATION
   "A three-element list describing how to print complex numbers.
The CAR is a string to print before the number.
The CADR is the string to print between the real imaginary parts,
 or NIL, meaning to print either a /"+/" if the imaginary part is positive, else a /"-/"
The CADDR is the string to print after the number")
; (PTTBL-RATIONAL-RADIX		10. :documentation
;  "The radix in which to print ratios, or NIL, meaning to use the value of *PRINT-BASE*")
  (PTTBL-VECTOR			'("#(" . ")") :DOCUMENTATION
   "Cons of the string to start vectors and the string to terminate vectors")
  (PTTBL-ARRAY			'("#" :RANK "A" :SEQUENCES) :DOCUMENTATION
   "A list describing how to print arrays when *print-array* is non-NIL.
Look in the code for SI:PRINT-ARRAY to find out how this is used.")
  (PTTBL-BIT-VECTOR		'("#*" :SEQUENCES "") :DOCUMENTATION
   "The string to print to start a bit-vector")
  (PTTBL-UNINTERNED-SYMBOL-PREFIX "#:" :DOCUMENTATION
   "The string to print to start unintered symbols, if *PRINT-GENSYM* is non-NIL")
  (PTTBL-STRUCTURE		'("#S(" :TYPE :SLOTS ")") :DOCUMENTATION
   "Don't know what this should mean yet.")
  )

(DEFSUBST RDTBL-SYMBOL-SUBSTITUTIONS (&OPTIONAL (READTABLE RDTBL))
  (GETF (RDTBL-PLIST READTABLE) 'SYMBOL-SUBSTITUTIONS))
(DEFSUBST RDTBL-NAME (&OPTIONAL (READTABLE RDTBL))
  (CAR (RDTBL-NAMES READTABLE)))
(DEFSUBST RDTBL-SHORT-NAME (&OPTIONAL (READTABLE RDTBL))
  (OR (CADR (RDTBL-NAMES READTABLE))
      (CAR (RDTBL-NAMES READTABLE))))

;;; old names in case there are any old callers of these
(DEFSUBST RDTBL-SLASH (&OPTIONAL (READTABLE RDTBL))
  (RDTBL-ESCAPE-CODE READTABLE))
(DEFSUBST RDTBL-CIRCLECROSS (&OPTIONAL (READTABLE RDTBL))
  (RDTBL-CHARACTER-CODE-ESCAPE-CODE READTABLE))

(DEFVAR RDTBL-ARRAY-SIZE #o240)

(DEFMACRO RDTBL-ARRAY (&OPTIONAL (P 'RDTBL))
  P)

(DEFMACRO RDTBL-ARRAY-DIMS ()
  `',(LIST 3 RDTBL-ARRAY-SIZE))

(DEFMACRO RDTBL-BITS (RDTBL CHAR)
  `(AREF ,RDTBL 0 ,CHAR))

(DEFMACRO RDTBL-CODE (RDTBL CHAR)
  `(AREF ,RDTBL 1 ,CHAR))

(DEFMACRO RDTBL-TRANS (RDTBL CHAR)
  `(AREF ,RDTBL 2 ,CHAR))

;;; Names of special characters, as an a-list.  FORMAT searches this list to
;;; get the inverse mapping (numbers to names), so the preferred name for a value
;;; should be earliest in the list.  New-keyboard names are preferred.  Names (not
;;; necessarily the prefered ones) should include those in the manual, in "The Lisp Machine
;;; Character Set".  This variable is used by quite a few other programs as well, even though
;;; it may look like it is internal to READ.  Here rather than in READ, because this
;;; expression cannot be evaluated in the cold-load.

(DEFCONST %%XR-SPECIAL-CHARACTER-NAMES-MOUSE-BIT #o2401
  "This should be used ONLY for defining XR-SPECIAL-CHARACTER-NAMES.")

(DEFCONST XR-SPECIAL-CHARACTER-NAMES
  (APPEND '((:NULL . #o200) (:NULL-CHARACTER . #o200)
	    (:BREAK . #o201) (:SUSPEND . #o201)
	    (:CLEAR-INPUT . #o202) (:CLEAR . #o202) (:CLR . #o202)
	    (:CALL . #o203)
	    (:TERMINAL . #o204) (:ESC . #o204) (:ESCAPE . #o204) (:TERMINAL-ESCAPE . #o204)
				(:FUNCTION . #o204)
	    (:MACRO . #o205) (:BACK-NEXT . #o205) (:BACKNEXT . #o205)
	    (:HELP . #o206)
	    (:RUBOUT . #o207)
	    (:OVERSTRIKE . #o210) (:BACKSPACE . #o210) (:BS . #o210)
	    (:TAB . #o211)
	    (:LINE . #o212) (:LF . #o212) (:LINEFEED . #o212) (:LINE-FEED . #o212)
	    (:DELETE . #o213) (:VT . #o213)
	    ;; The keyboard says "CLEAR SCREEN", but it should type out as "PAGE".
	    (:PAGE . #o214) (:CLEAR-SCREEN . #o214) (:FORM . #o214) (:FF . #o214)
	    (:RETURN . #o215) (:NEWLINE . #o215) (:CR . #o215)
	    (:QUOTE . #o216)
	    (:HOLD-OUTPUT . #o217)
	    (:STOP-OUTPUT . #o220)
	    (:ABORT . #o221)
	    (:RESUME . #o222)
	    (:STATUS . #o223)
	    (:END . #o224)
	    (:ROMAN-I . #o225) (:ROMAN-II . #o226) (:ROMAN-III . #o227) (:ROMAN-IV . #o230)
	    (:HAND-UP . #o231) (:HAND-DOWN . #o232)
	    (:HAND-LEFT . #o233) (:HAND-RIGHT . #o234)
	    (:SYSTEM . #o235) (:SELECT . #o235)
	    (:NETWORK . #o236)

	    (:CENTER-DOT . 0) (:CENTRE-DOT . 0)	;Amerikans can't spell...
	    (:DOWN-ARROW . 1)
	    (:ALPHA . 2) (:BETA . 3) (:AND-SIGN . 4) (:NOT-SIGN . 5)
	    (:EPSILON . 6) (:PI . 7) (:LAMBDA . #o10) (:GAMMA . #o11) (:DELTA . #o12)
	    (:UP-ARROW . #o13) (:UPARROW . #o13)
	    (:PLUS-MINUS . #o14) (:CIRCLE-PLUS . #o15)
	    (:INFINITY . #o16) (:PARTIAL-DELTA . #o17)
	    (:LEFT-HORSESHOE . #o20) (:RIGHT-HORSESHOE . #o21) 
	    (:UP-HORSESHOE . #o22) (:DOWN-HORSESHOE . #o23)
	    (:UNIVERSAL-QUANTIFIER . #o24) (:FOR-ALL . #o24)
	    (:EXISTENTIAL-QUANTIFIER . #o25) (:THERE-EXISTS . #o25)
	    (:CIRCLE-X . #o26) (:CIRCLE-CROSS . #o26) (:TENSOR . #o26)
	    (:DOUBLE-ARROW . #o27) (:LEFT-ARROW . #o30) (:RIGHT-ARROW . #o31)
	    (:NOT-EQUAL . #o32)(:NOT-EQUALS . #o32)
	    (:ALTMODE . #o33) (:ALT . #o33) (:DIAMOND . #o33)
	    (:LESS-OR-EQUAL . #o34) (:GREATER-OR-EQUAL . #o35) (:EQUIVALENCE . #o36)
	    (:OR-SIGN . #o37) (:OR . #o37)

	    (:SPACE . #o40) (:SP . #o40)
	    (:INTEGRAL . #o177)
	    (:COKE-BOTTLE . 259.) (:COKEBOTTLE . 259.)
	    )
	  (MAPCAR (LAMBDA (X) (CONS (CAR X)
				    (DPB 1 %%XR-SPECIAL-CHARACTER-NAMES-MOUSE-BIT
					 (CDR X))))
	      '((:MOUSE-L . 0) (:MOUSE-L-1 . 0) (:MOUSE-L-2 . #o10) (:MOUSE-L-3 . #o20)
		(:MOUSE-M . 1) (:MOUSE-M-1 . 1) (:MOUSE-M-2 . #o11) (:MOUSE-M-3 . #o21)
		(:MOUSE-R . 2) (:MOUSE-R-1 . 2) (:MOUSE-R-2 . #o12) (:MOUSE-R-3 . #o22)
		(:MOUSE-1-1 . 0) (:MOUSE-1-2 . #o10)
		(:MOUSE-2-1 . 1) (:MOUSE-2-2 . #o11)
		(:MOUSE-3-1 . 2) (:MOUSE-3-2 . #o12))))
  "Alist of names of special characters, in the form of symbols in the keyword pkg,
and the character values they correspond to.")

(DEFMACRO PRINTING-RANDOM-OBJECT ((OBJECT STREAM . OPTIONS) &BODY BODY)
  "A macro for aiding in the printing of random objects.
This macro generates a form which:
   1.  Uses the print-table to find the things in which to enclose your randomness.
   2.  (by default) includes the virtual address in the printed representation.
   3.  Obeys PRINT-READABLY
 Options are	:NO-POINTER to suppress the pointer
		:TYPE prin1s the TYPE-OF of the object first.

 Example:
 (DEFSELECT ((:PROPERTY HACKER :NAMED-STRUCTURE-INVOKE))
   (:PRINT-SELF (HACKER STREAM IGNORE IGNORE)
     (SI:PRINTING-RANDOM-OBJECT (HACKER STREAM :TYPE)
       (PRIN1 (HACKER-NAME HACKER) STREAM))))
 ==> #<HACKER /"Mly/" 6172536765>"
  (declare (arglist ((object stream &key no-pointer type) &body body)))
  (LET ((%POINTER T)
	(TYPE NIL))
    (IF (EQ STREAM T) (SETQ STREAM '*STANDARD-OUTPUT*))	;inconsistent with decode-print-arg...
    (DO ((L OPTIONS (CDR L)))
	((NULL L))
      (CASE (CAR L)
	(:NO-POINTER (SETQ %POINTER NIL))
	((:TYPE :TYPEP) (SETQ TYPE T))
	;; hysterical lossage.  Perhaps nobody uses this.  They shouldn't!
	(:FASTP (SETQ L (CDR L)))
	(T (FERROR "~S is an unknown keyword in ~S"
		   (CAR L) 'PRINTING-RANDOM-OBJECT))))
    `(progn
       (print-random-object-prefix ,object ,stream ,type ,(not (not (and type body))))
       ,@body
       (print-random-object-suffix ,object ,stream ,(not %pointer))
       ,object)))

(DEFSUBST DECODE-PRINT-ARG (ARG)
  (COND ((EQ ARG NIL) *STANDARD-OUTPUT*)
	((EQ ARG T) *TERMINAL-IO*)
	(T ARG)))

(DEFSUBST DECODE-READ-ARG (ARG)
  (COND ((EQ ARG NIL) *STANDARD-INPUT*)
	((EQ ARG T) *TERMINAL-IO*)
	(T ARG)))

(DEFSELECT ((:PROPERTY READTABLE NAMED-STRUCTURE-INVOKE) IGNORE)
  (:DESCRIBE (RDTBL) (DESCRIBE-DEFSTRUCT RDTBL))
  (:PRINT-SELF (RDTBL STREAM IGNORE &OPTIONAL IGNORE)
    (IF *PRINT-ESCAPE*
	(SYS:PRINTING-RANDOM-OBJECT (RDTBL STREAM :TYPE :NO-POINTER)
	  (FORMAT STREAM "~@[~A ~]~O" (RDTBL-NAME RDTBL) (%POINTER RDTBL)))
      (IF (RDTBL-NAME RDTBL)
	  (FORMAT STREAM "~A readtable" (RDTBL-NAME RDTBL))
	(FORMAT STREAM "#<Readtable ~O>" (%POINTER RDTBL)))))
  ((:GET :GET-LOCATION-OR-NIL :GET-LOCATION :GETL :PUTPROP :REMPROP :PUSH-PROPERTY :PLIST
    :PROPERTY-LIST :PLIST-LOCATION :PROPERTY-LIST-LOCATION :SETPLIST :SET)
   . READTABLE-PROPERTY-LIST-HANDLER)
  (:FASD-FIXUP (RDTBL)
    (IF (RDTBL-NAMES RDTBL)
	(PUSHNEW RDTBL *ALL-READTABLES* :TEST #'EQ))))
(DEFUN READTABLE-PROPERTY-LIST-HANDLER (OP RDTBL &REST ARGS)
  (APPLY 'PROPERTY-LIST-HANDLER OP (LOCF (RDTBL-PLIST RDTBL)) ARGS))