;;; -*- Mode:common-lisp; Package:SYSTEM-INTERNALS; Base:8; Cold-Load:T -*- ;;; 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. ;;; Definitions for the Reader ;;; ;;; Change history: ;;; ;;; Date Author Description ;;; ------------------------------------------------------------------------------------- ;;; 06/25/87 AB Add PLUS-MINUS-SIGN, MIDDLE-DOT to XR-SPECIAL-CHARACTER-NAMES. ;;; 10/07/86 TWE Changed XR-SPECIAL-CHARACTER-NAMES to define the keypad characters. ;;; Also changed the characters following the place where the keypad ;;; characters were defined to remove the gap. ;;; 11/20/87 HW Put in names for special ISO characters. ;;; 12/01/86 TWE Added back the keypad characters to XR-SPECIAL-CHARACTER-NAMES. ;;; 12/17/86 HW Modified the names of some of the special ISO characters for consistency. ;;; 12/01/86 TWE Added back the keypad characters to XR-SPECIAL-CHARACTER-NAMES. ;;; 12/24/86 PHD Fixed generation of keypad characters, they should be fixnum instead of characters. ;;; 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. ;; This should be used ONLY for defining XR-SPECIAL-CHARACTER-NAMES. (Defconstant %%XR-SPECIAL-CHARACTER-NAMES-MOUSE-BIT 2701) ;;; Notes about things that need to be explained. ;;; The OVERSTRIKE key on the CADR/Lambda machines still has a ;;; corresponding character name. This is used by TELNET to back up one ;;; character, and needs to be > #o200. ;;; The character names beginning with KEYPAD- correspond to keys on the ;;; Explorer which form the keypad. ;;; The CENTER character name corresponds to the blank key in the middle ;;; of the arrow key group. ;;; The TERMINAL character name is now distinct from the ESCAPE ;;; character name, since the Explorer has an ESCAPE key. (DEFPARAMETER XR-SPECIAL-CHARACTER-NAMES (APPEND '( (:CENTER-DOT . 0) (:DOWN-ARROW . 1) (:HAND-DOWN . 1) (:ALPHA . 2) (:BETA . 3) (:AND-SIGN . 4) (:NOT-SIGN . 5) (:EPSILON . 6) (:PI . 7) (:LAMBDA . 10) (:GAMMA . 11) (:DELTA . 12) (:UP-ARROW . 13) (:UPARROW . 13) (:HAND-UP . 13) (:PLUS-MINUS . 14) (:CIRCLE-PLUS . 15) (:INFINITY . 16) (:PARTIAL-DELTA . 17) (:LEFT-HORSESHOE . 20) (:RIGHT-HORSESHOE . 21) (:UP-HORSESHOE . 22) (:DOWN-HORSESHOE . 23) (:UNIVERSAL-QUANTIFIER . 24) (:EXISTENTIAL-QUANTIFIER . 25) (:CIRCLE-X . 26) (:CIRCLE-CROSS . 26) (:TENSOR . 26) (:DOUBLE-ARROW . 27) (:LEFT-ARROW . 30) (:HAND-LEFT . 30) (:RIGHT-ARROW . 31) (:HAND-RIGHT . 31) (:NOT-EQUAL . 32) (:NOT-EQUALS . 32) (:ESCAPE . 33) (:ESC . 33) (:ALTMODE . 33) (:ALT . 33) (:DIAMOND . 33) (:LESS-OR-EQUAL . 34) (:GREATER-OR-EQUAL . 35) (:EQUIVALENCE . 36) (:OR-SIGN . 37) (:OR . 37) (:SPACE . 40) (:SP . 40) (:INTEGRAL . 177) (:NULL . 200) (:NULL-CHARACTER . 200) (:BREAK . 201) (:BRK . 201) (:CLEAR-INPUT . 202) (:CLEAR . 202) (:CLR . 202) (:CALL . 203) (:TERM . 204) (:TERMINAL . 204) (:MACRO . 205) (:BACK-NEXT . 205) (:BACKNEXT . 205) (:HELP . 206) (:RUBOUT . 207) (:OVERSTRIKE . 210) (:BACKSPACE . 210) (:BS . 210) (:TAB . 211) (:LINEFEED . 212) (:LINE . 212) (:LF . 212) (:LINE-FEED . 212) (:DELETE . 213) (:VT . 213) (:CLEAR-SCREEN . 214) (:PAGE . 214) (:FORM . 214) (:FF . 214) (:REFRESH . 214) (:RETURN . 215) (:CR . 215) (:NEWLINE . 215) (:QUOTE . 216) (:HOLD-OUTPUT . 217) (:STOP-OUTPUT . 220) (:ABORT . 221) (:RESUME . 222) (:STATUS . 223) (:END . 224) (:F1 . 225) (:FUNCTION-1 . 225) (:ROMAN-I . 225) ;hw (:F2 . 226) (:FUNCTION-2 . 226) (:ROMAN-II . 226) (:F3 . 227) (:FUNCTION-3 . 227) (:ROMAN-III . 227) (:F4 . 230) (:FUNCTION-4 . 230) (:ROMAN-IV . 230) (:LEFT . 231) (:MIDDLE . 232) (:RIGHT . 233) (:CENTER . 234) (:CENTER-ARROW . 234) (:SYSTEM . 235) (:NETWORK . 236) (:UNDO . 237) (:NO-BREAK-SPACE . 240) (:NBSP . 240) (:INVERTED-EXCLAMATION-MARK . 241) (:AMERICAN-CENT-SIGN . 242) (:CENT . 242) (:BRITISH-POUND-SIGN . 243) (:POUND . 243) (:CURRENCY-SIGN . 244) (:JAPANESE-YEN-SIGN . 245) (:YEN . 245) (:BROKEN-BAR . 246) (:SECTION-SYMBOL . 247) (:SECTION . 247) (:DIARESIS . 250) (:UMLAUT . 250) (:COPYRIGHT-SIGN . 251) (:COPYRIGHT . 251) (:FEMININE-ORDINAL-INDICATOR . 252) (:ANGLE-QUOTATION-LEFT . 253) ;;; (:NOT-SIGN . 254) Would like to put NOT-SIGN here (ISO), but we've already got one #o5 (:SOFT-HYPHEN . 255) (:SHY . 255) (:REGISTERED-TRADEMARK . 256) (:MACRON . 257) (:DEGREE-SIGN . 260) (:RING . 260) (:PLUS-MINUS-SIGN . 261) (:SUPERSCRIPT-2 . 262) (:SUPERSCRIPT-3 . 263) (:ACUTE-ACCENT . 264) (:GREEK-MU . 265) (:MU . 265) (:PARAGRAPH-SYMBOL . 266) (:PARAGRAPH . 266) (:PILCROW-SIGN . 266) (:MIDDLE-DOT . 267) (:CEDILLA . 270) (:SUPERSCRIPT-1 . 271) (:MASCULINE-ORDINAL-INDICATOR . 272) (:ANGLE-QUOTATION-RIGHT . 273) (:FRACTION-1/4 . 274) (:ONE-QUARTER . 274) (:FRACTION-1/2 . 275) (:ONE-HALF . 275) (:FRACTION-3/4 . 276) (:THREE-QUARTERS . 276) (:INVERTED-QUESTION-MARK . 277) (:MULTIPLICATION-SIGN . 327) (:ESZET . 337) (:DIVISION-SIGN . 367) ) (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 . 10) (:MOUSE-L-3 . 20) (:MOUSE-M . 1) (:MOUSE-M-1 . 1) (:MOUSE-M-2 . 11) (:MOUSE-M-3 . 21) (:MOUSE-R . 2) (:MOUSE-R-1 . 2) (:MOUSE-R-2 . 12) (:MOUSE-R-3 . 22) (:MOUSE-1-1 . 0) (:MOUSE-1-2 . 10) (:MOUSE-2-1 . 1) (:MOUSE-2-2 . 11) (:MOUSE-3-1 . 2) (:MOUSE-3-2 . 12))) (MAPCAR #'(LAMBDA (X) (CONS (CAR X) (char-int (DPB 1 %%KBD-KEYPAD (CDR X))))) '((:K-EQUAL . #\= ) (:KEYPAD-EQUAL . #\= ) (:K-PLUS . #\+ ) (:KEYPAD-PLUS . #\+ ) (:K-SPACE . #\SPACE ) (:KEYPAD-SPACE . #\SPACE ) (:K-TAB . #\TAB ) (:KEYPAD-TAB . #\TAB ) (:K-7 . #\7 ) (:KEYPAD-7 . #\7 ) (:K-8 . #\8 ) (:KEYPAD-8 . #\8 ) (:K-9 . #\9 ) (:KEYPAD-9 . #\9 ) (:K-MINUS . #\- ) (:KEYPAD-MINUS . #\- ) (:K-4 . #\4 ) (:KEYPAD-4 . #\4 ) (:K-5 . #\5 ) (:KEYPAD-5 . #\5 ) (:K-6 . #\6 ) (:KEYPAD-6 . #\6 ) (:K-COMMA . #\, ) (:KEYPAD-COMMA . #\, ) (:K-1 . #\1 ) (:KEYPAD-1 . #\1 ) (:K-2 . #\2 ) (:KEYPAD-2 . #\2 ) (:K-3 . #\3 ) (:KEYPAD-3 . #\3 ) (:K-ENTER . #\RETURN) (:KEYPAD-ENTER . #\RETURN) (:K-0 . #\0 ) (:KEYPAD-0 . #\0 ) (:K-PERIOD . #\. ) (:KEYPAD-PERIOD . #\. )))) "Alist of names of special characters, in the form of symbols in the keyword pkg, and the character values they correspond to.") (DEFSUBST DECODE-PRINT-ARG (ARG) (COND ((NULL ARG) *STANDARD-OUTPUT*) ((EQ ARG T) *TERMINAL-IO*) (T ARG))) (DEFSUBST DECODE-READ-ARG (ARG) (COND ((NULL ARG) *STANDARD-INPUT*) ((EQ ARG T) *TERMINAL-IO*) (T ARG))) ;;PHD 2/11/87 Fixed PTTBL-PACKAGE-INTERNAL-PREFIX. ;;PHD 2/23/87 Fixed PTTBL-PRINLEVEL. (defstruct (readtable (:conc-name nil) (:DEFAULT-POINTER RDTBL) (:predicate readtablep) (:copier nil)) (character-attribute-table (make-character-attribute-table) :type simple-vector) (character-macro-table (make-character-macro-table) :type simple-vector) (dispatch-tables () :type list) (PTTBL-SPACE #\space ) (PTTBL-NEWLINE #\newline) (PTTBL-CONS-DOT " . " ) (PTTBL-MINUS-SIGN #\- ) (PTTBL-DECIMAL-POINT #\. ) (PTTBL-SLASH #\\) (PTTBL-PRINLEVEL "#" ) (PTTBL-PRINLENGTH "..." ) (PTTBL-OPEN-RANDOM "#<" ) (PTTBL-CLOSE-RANDOM ">" ) (PTTBL-OPEN-PAREN #\( ) (PTTBL-CLOSE-PAREN #\) ) (PTTBL-OPEN-QUOTE-STRING #\" ) (PTTBL-CLOSE-QUOTE-STRING #\" ) (PTTBL-OPEN-QUOTE-SYMBOL #\| ) (PTTBL-CLOSE-QUOTE-SYMBOL #\| ) (PTTBL-PACKAGE-PREFIX ":" ) (PTTBL-PACKAGE-INTERNAL-PREFIX "::" ) (PTTBL-CHARACTER-PREFIX "\\" ) (PTTBL-CHARACTER-BEFORE-FONT "#" ) (PTTBL-RATIONAL-INFIX #\/ ) (Pttbl-COMPLEX '("#C(" " " ")")) (PTTBL-RATIONAL-RADIX 10. ) (PTTBL-OPEN-VECTOR "#(" ) (PTTBL-CLOSE-VECTOR ")" ) (PTTBL-ARRAY '("#" :RANK "A" :SEQUENCES)) (PTTBL-OPEN-BIT-VECTOR "#*" ) (PTTBL-UNINTERNED-SYMBOL-PREFIX "#:" ) ) ;; 3/23/89 DNG - Add use of CLASS-NAME when TYPE-OF doesn't return a symbol. (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 :TYPEP princs the typep of the object first. :FASTP if the variable happens to be sitting around. Example: (DEFSELECT ((:PROPERTY HACKER :NAMED-STRUCTURE-INVOKE)) (:PRINT-SELF (HACKER STREAM IGNORE IGNORE) (SI:PRINTING-RANDOM-OBJECT (HACKER STREAM :TYPEP) (PRIN1 (HACKER-NAME HACKER) STREAM)))) ==> #" (LET ((%POINTER T) (TYPEP NIL) (FASTP NIL)) (DO ((L OPTIONS (CDR L))) ((NULL L)) (CASE (CAR L) (:NO-POINTER (SETQ %POINTER NIL)) (:TYPEP (SETQ TYPEP T)) (:FASTP (SETQ L (CDR L) FASTP (CAR L))) (OTHERWISE (FERROR NIL "~S is an unknown keyword in PRINTING-RANDOM-OBJECT" (CAR L))))) `(PROGN (AND PRINT-READABLY (PRINT-NOT-READABLE ,OBJECT)) (PRINT-RAW-STRING (PTTBL-OPEN-RANDOM *READTABLE*) ,STREAM ,FASTP) ,@(AND TYPEP `((PRINT-PNAME-STRING (LET ((TYPE (TYPE-OF ,OBJECT))) (IF (CLASSP TYPE) (TICLOS:CLASS-NAME TYPE) TYPE)) ,STREAM ,FASTP))) ,@(AND TYPEP BODY `((FUNCALL ,STREAM ':TYO (PTTBL-SPACE *READTABLE*)))) ,@BODY ,@(AND %POINTER `((FUNCALL ,STREAM ':TYO (PTTBL-SPACE *READTABLE*)) (LET ((*PRINT-BASE* 8.) (*PRINT-RADIX* NIL) (*NOPOINT T)) (PRINT-FIXNUM (%POINTER ,OBJECT) ,STREAM)))) (PRINT-RAW-STRING (PTTBL-CLOSE-RANDOM *READTABLE*) ,STREAM ,FASTP) ,OBJECT))) (eval-when (compile load eval) (defconstant whitespace 0.) (defconstant terminating-macro 1.) (defconstant escape 2.) (defconstant constituent 3.) (defconstant constituent-dot 4.) (defconstant constituent-expt 5.) (defconstant constituent-slash 6.) (defconstant constituent-digit 7.) (defconstant constituent-sign 8.) (defconstant sharp-sign 9.) (defconstant multiple-escape 10.) (defconstant package-delimiter 11.) ;;fake attribute for use in read-unqualified-token (defconstant delimiter 12.)) ;;;macros and functions for character tables. (defmacro get-cat-entry (char rt) ;;only give this side-effect-free args. `(elt (the simple-vector (character-attribute-table ,rt)) (char-int ,char))) (defun set-cat-entry (char newvalue &optional (rt *readtable*)) (setf (elt (the simple-vector (character-attribute-table rt)) (char-int char)) newvalue)) (defmacro get-cmt-entry (char rt) `(elt (the simple-vector (character-macro-table ,rt)) (char-int ,char))) (defun set-cmt-entry (char newvalue &optional (rt *readtable*)) (setf (elt (the simple-vector (character-macro-table rt)) (char-int char)) newvalue)) (defun make-character-attribute-table () (make-array 256. :element-type t :initial-element '#.constituent)) (defun make-character-macro-table () (make-array 256. :element-type t :initial-element 'undefined-macro-char)) (defun undefined-macro-char (ignore char) (error "Undefined read-macro character ~S" char)) ;;;The character attribute table is a 256-long vector of integers. (defmacro test-attribute (char whichclass rt) `(= (get-cat-entry ,char ,rt) ,whichclass)) ;;;Predicates for testing character attributes (defmacro whitespacep (char &optional (rt '*readtable*)) `(and (test-attribute ,char #.whitespace ,rt) (setf last-whitespace ,char) t)) (defmacro constituentp (char &optional (rt '*readtable*)) `(>= (get-cat-entry ,char ,rt) #.constituent)) (defmacro terminating-macrop (char &optional (rt '*readtable*)) `(test-attribute ,char #.terminating-macro ,rt)) (defmacro escapep (char &optional (rt '*readtable*)) `(test-attribute ,char #.escape ,rt)) (defmacro multiple-escape-p (char &optional (rt '*readtable*)) `(test-attribute ,char #.multiple-escape ,rt)) (defmacro token-delimiterp (char &optional (rt '*readtable*)) ;;depends on actual attribute numbering above. `(<= (get-cat-entry ,char ,rt) #.terminating-macro))