(FILECREATED " 6-Aug-86 01:29:54" {ERIS}<LISPCORE>LIBRARY>CMLREAD.;58 36928
changes to: (VARS CMLREADCOMS)
(FUNCTIONS IL-UNWRAP-MACRO CL-UNWRAP-MACRO IL-MACRO-WRAPPED-P CL-WRAP-MACRO
IL-WRAP-MACRO CL-MACRO-WRAPPED-P GET-MACRO-CHARACTER FIND-MACRO-FUNCTION
SET-MACRO-CHARACTER MAKE-DISPATCH-MACRO-CHARACTER CMLREADQUOTE
DO-DISPATCH-MACRO GET-DISPATCH-MACRO-CHARACTER HASH-LEFTPAREN
SET-DISPATCH-MACRO-CHARACTER)
(FNS CMLRDTBL)
previous date: " 6-Aug-86 00:19:34" {ERIS}<BANE>LISP>CMLREAD.;5)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLREADCOMS)
(RPAQQ CMLREADCOMS
((* "This is a collection of hacks designed to make our reader handle some subset of Common Lisp syntax. It doesn't really work right"
)
(COMS (FNS CL:READ COPY-READTABLE READ-DELIMITED-LIST)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (MOVD? (QUOTE NILL)
(QUOTE CMLTRANSLATE))))
(* "must turn off packed version of CLISP infix")
(VARS (CLISPCHARS (LDIFFERENCE CLISPCHARS (QUOTE (- * :))))
(CLISPCHARRAY (MAKEBITTABLE CLISPCHARS))
(DWIMINMACROSFLG)))
(FUNCTIONS CL-MACRO-WRAPPED-P CL-UNWRAP-MACRO CL-WRAP-MACRO CMLREADBQUOTE CMLREADBQUOTECOMMA
CMLREADQUOTE IL-MACRO-WRAPPED-P IL-UNWRAP-MACRO IL-WRAP-MACRO PARSE-INTEGER)
(* "Common Lisp readtable interface functions and supplied hash macro functions")
(FUNCTIONS SET-SYNTAX-FROM-CHAR DO-DISPATCH-MACRO FIND-MACRO-FUNCTION
GET-DISPATCH-MACRO-CHARACTER GET-MACRO-CHARACTER HASH-LEFTPAREN HASH-A HASH-B
HASH-BACKSLASH HASH-C HASH-COLON HASH-COMMA HASH-DOT HASH-DOUBLEQUOTE
HASH-ILLEGAL-HASH-CHAR HASH-LEFTANGLE HASH-MINUS HASH-NO-PARAMETER-ERROR HASH-O
HASH-PLUS HASH-QUOTE HASH-R HASH-S HASH-STAR HASH-VBAR HASH-X
MAKE-DISPATCH-MACRO-CHARACTER SET-DISPATCH-MACRO-CHARACTER SET-MACRO-CHARACTER)
(INITVARS (*STANDARD-INPUT* NIL))
(COMS (* "Attempt to build a CommonLisp readtable. Most features simulated for the basic reading, but macros need work"
)
(FNS CMLRDTBL CMLREADSEMI)
(VARS (CMLRDTBL (CMLRDTBL))))
(COMS (* "Crude means to aid reading and printing things in same reader environment")
(RECORDS READER-ENVIRONMENT)
(FNS MAKE-READER-ENVIRONMENT EQUAL-READER-ENVIRONMENT)
(FUNCTIONS WITH-READER-ENVIRONMENT)
(ADDVARS (SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*))
(INITVARS (*OLD-INTERLISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REREADTABLE ←
FILERDTBL REBASE ← 10)))
(PROP INFO WITH-READER-ENVIRONMENT))
(PROP FILETYPE CMLREAD)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA COPY-READTABLE
CL:READ)))))
(*
"This is a collection of hacks designed to make our reader handle some subset of Common Lisp syntax. It doesn't really work right"
)
(DEFINEQ
(CL:READ
(CL:LAMBDA (&OPTIONAL INPUT-STREAM EOF-ERROR-P EOF-VALUE RECURSIVE-P)
(* bvm: "14-May-86 10:50")
(CMLTRANSLATE (READ INPUT-STREAM))))
(COPY-READTABLE
(CL:LAMBDA (&OPTIONAL (FROM-READTABLE *READTABLE* FROM-READTABLE-SUPPLIEDP)
(TO-READTABLE NIL TO-READTABLE-SUPPLIEDP))
(* kbr: " 2-Jul-86 16:56")
(LET* ((OLDRDTBL (COND
(FROM-READTABLE-SUPPLIEDP (\GTREADTABLE FROM-READTABLE T))
(T (* If FROM-READTABLE is NIL, then a
copy of a standard Common Lisp
readtable is made. *)
CMLRDTBL)))
(NEWRDTBL (RESETREADTABLE (COND
(TO-READTABLE-SUPPLIEDP (\GTREADTABLE TO-READTABLE T))
(T (create READTABLEP)))
OLDRDTBL))) (*
"Need to copy dispatch list since it is destructively munged")
(REPLACE (READTABLEP DISPATCHMACRODEFS) OF NEWRDTBL WITH (COPY (FETCH (READTABLEP
DISPATCHMACRODEFS
) OF OLDRDTBL))
)
NEWRDTBL)))
(READ-DELIMITED-LIST
[LAMBDA (CHAR INPUT-STREAM RECURSIVE-P) (* bvm: "25-Jul-86 23:59")
(* * "Read a list of elements terminated by CHAR. CHAR must not be a separator char, and ideally should not be a constituent char (if it is, it must be preceded by whitespace for READ-DELIMITED-LIST to work)")
(* * "Note: this is not quite right, because it loses if the terminator is preceded by a macro character that returns zero values, for example, a semi-colon. It also ignores RECURSIVE-P. When the real reader is written, this should be integrated with it.")
(LET [(ENDCODE (CHAR-CODE CHAR))
(INSTREAM (\GETSTREAM INPUT-STREAM (QUOTE INPUT]
(until (EQ (SKIPSEPRCODES INSTREAM)
ENDCODE) collect (READ INSTREAM) finally (* Consume the terminating character)
(READCCODE INSTREAM])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(MOVD? (QUOTE NILL)
(QUOTE CMLTRANSLATE))
)
(* "must turn off packed version of CLISP infix")
(RPAQ CLISPCHARS (LDIFFERENCE CLISPCHARS (QUOTE (- * :))))
(RPAQ CLISPCHARRAY (MAKEBITTABLE CLISPCHARS))
(RPAQQ DWIMINMACROSFLG NIL)
(DEFUN CL-MACRO-WRAPPED-P (FORM)
(* * "Predicate that checks for forms built by CL-WRAP-MACRO")
(AND (CONSP FORM)
(EQ (CAR FORM)
(QUOTE CL:LAMBDA))
(CONSP (CDR FORM))
(CL:EQUAL (CADR FORM)
(QUOTE (STREAM READTABLE Z)))
(CONSP (CDDR FORM))
(NULL (CDDDR FORM))
(CONSP (CADDR FORM))
(EQ (CAADDR FORM)
(QUOTE FUNCALL))))
(DEFUN CL-UNWRAP-MACRO (FORM)
(* * "Fetches CL function out wrapped by CL-WRAP-MACRO")
(CADR (CADR (CADDR FORM))))
(DEFUN CL-WRAP-MACRO (CL:FUNCTION CHAR)
(* * "Wraps a form around a CL readmacro to make it acceptable as an IL readmacro")
(BQUOTE (CL:LAMBDA (STREAM READTABLE Z)
(FUNCALL (QUOTE (\, CL:FUNCTION))
STREAM
(\, CHAR)))))
(DEFUN CMLREADBQUOTE (STREAM CHAR) (READBQUOTE STREAM *READTABLE*))
(DEFUN CMLREADBQUOTECOMMA (STREAM CHAR) (READBQUOTECOMMA STREAM *READTABLE*))
(DEFUN CMLREADQUOTE (STREAM CHAR) (READQUOTE STREAM *READTABLE*))
(DEFUN IL-MACRO-WRAPPED-P (FORM)
(* * "Predicate that checks for forms built by IL-WRAP-MACRO")
(AND (CONSP FORM)
(EQ (CAR FORM)
(QUOTE CL:LAMBDA))
(CONSP (CDR FORM))
(EQUAL (CADR FORM)
(QUOTE (STREAM CHAR)))
(CONSP (CDDR FORM))
(NULL (CDDDR FORM))
(CONSP (CADDR FORM))
(EQ (CAADDR FORM)
(QUOTE FUNCALL))
(EQ (CADDR (CADDR FORM))
(QUOTE STREAM))))
(DEFUN IL-UNWRAP-MACRO (FORM) (CADR (CADR (CADDR FORM))))
(DEFUN IL-WRAP-MACRO (FORM)
(* * "Wraps a form around an IL readmacro to make it acceptable as a CL readmacro")
(BQUOTE (CL:LAMBDA (STREAM CHAR)
(FUNCALL (QUOTE (\, FORM))
STREAM))))
(DEFUN PARSE-INTEGER (STRING &KEY (START 0)
(END (CL:LENGTH STRING))
(RADIX 10)
JUNK-ALLOWED)
(PROG (SA BASE OFFST FATP LEN INDEX CHAR STATE MAXDIGITCODE SIGN STARTINT ENDINT VALUE ANSWER)
(SETQ SA (fetch (READTABLEP READSA) of *READTABLE*))
(SETQ BASE (fetch (STRINGP BASE) of STRING))
(SETQ LEN (fetch (STRINGP LENGTH) of STRING))
(SETQ OFFST (fetch (STRINGP OFFST) of STRING))
(SETQ FATP (fetch (STRINGP FATSTRINGP) of STRING))
(SETQ INDEX START)
(while (AND (< INDEX END)
(EQ (\SYNCODE SA (SETQ CHAR (\GETBASECHAR FATP BASE (+ OFFST INDEX))))
SEPRCHAR.RC)) do (SETQ INDEX (1+ INDEX)))
(CL:IF (> INDEX END)
(CL:IF JUNK-ALLOWED (RETURN-FROM PARSE-INTEGER (VALUES NIL END))
(CL:ERROR "No non-whitespace characters in number.")))
(SETQ STATE (QUOTE INIT))
(SETQ MAXDIGITCODE (+ (CHARCODE 0)
RADIX -1))
(while (< INDEX END) do (SETQ STATE (OR (SELCHARQ (SETQ CHAR (\GETBASECHAR FATP BASE
(+ OFFST INDEX)))
(- (AND (NOT SIGN)
(SELECTQ STATE
(INIT (SETQ SIGN (QUOTE -))
STATE)
NIL)))
(+ (AND (NOT SIGN)
(SELECTQ STATE
(INIT (SETQ SIGN (QUOTE +))
STATE)
NIL)))
NIL)
(COND
((AND (IGEQ CHAR (CHARCODE 0))
(ILEQ CHAR MAXDIGITCODE))
(* digit)
(SELECTQ STATE
(INIT (SETQ STARTINT INDEX)
(QUOTE INITDIGIT))
(INITDIGIT (QUOTE INITDIGIT))
NIL)))
(RETURN)))
(SETQ INDEX (1+ INDEX)))
(OR ENDINT (SETQ ENDINT INDEX))
(while (AND (< INDEX END)
(EQ (\SYNCODE SA (SETQ CHAR (\GETBASECHAR FATP BASE (+ OFFST INDEX))))
SEPRCHAR.RC)) do (SETQ INDEX (1+ INDEX)))
(SETQ ANSWER (COND
((AND (EQ STATE (QUOTE INITDIGIT))
(= INDEX END))
(\MKINTEGER BASE STARTINT ENDINT (EQ SIGN (QUOTE -))
RADIX FATP))
(JUNK-ALLOWED NIL)
((EQ STATE (QUOTE INIT))
(CL:ERROR "There aren't any digits in this integer string: ~S." STRING))
(T (CL:ERROR "There Is junk in this integer string: ~S." STRING))))
(RETURN (VALUES ANSWER INDEX))))
(* "Common Lisp readtable interface functions and supplied hash macro functions")
(DEFUN SET-SYNTAX-FROM-CHAR (TO-CHAR FROM-CHAR &OPTIONAL (TO-READTABLE *READTABLE*)
(FROM-READTABLE CMLRDTBL)) (SETSYNTAX (CHAR-CODE TO-CHAR)
(GETSYNTAX (CHAR-CODE FROM-CHAR)
FROM-READTABLE)
TO-READTABLE))
(DEFUN DO-DISPATCH-MACRO (CHAR STREAM RDTBL) (LET (INDEX NEXTCHAR (*READTABLE* RDTBL))
(* * Temporarily hiding the kludge until I ask Bill what to do about it
(READFN (COND ((fetch (READTABLEP COMMONLISP) of RDTBL)
(* Kludge: if we have to recursively read something that will not end up as the
resulting list structure, use the reader that passes thru CMLTRANSLATE)
(CL:FUNCTION CL:READ)) (T (CL:FUNCTION CL:READ)))))
(while (DIGITCHARP (SETQ NEXTCHAR (PEEKCCODE STREAM
RDTBL)))
do (SETQ INDEX (PLUS (TIMES (OR INDEX 0)
10)
(DIFFERENCE (READCCODE
STREAM RDTBL)
(CHARCODE 0)))))
(LET* ((DISP-CHARACTER (CHAR-UPCASE
(CODE-CHAR (PEEKCCODE
STREAM RDTBL)))
)
(DISP-TABLE
(CDR (ASSOC CHAR (fetch (READTABLEP
DISPATCHMACRODEFS
)
of RDTBL))))
(DISP-FUNCTION (CDR (ASSOC DISP-CHARACTER
DISP-TABLE))))
(* * Special hack here -
this will go away when UNREAD-CHAR works)
(COND
((NOT DISP-TABLE)
(CL:ERROR
"~S is not a dispatch macro character"
CHAR))
((EQ DISP-CHARACTER (QUOTE |\())
(FUNCALL DISP-FUNCTION STREAM
(CODE-CHAR (CHARCODE %())
INDEX))
(T
(* DISPATCHMACRODEFS is a list of
A-lists; the first one is always the
A-list for #)
(READCCODE STREAM RDTBL)
(if DISP-FUNCTION
then (FUNCALL DISP-FUNCTION STREAM
DISP-CHARACTER INDEX)
else (CL:ERROR
"Undefined dispatch character ~S for dispatch macro character ~S"
DISP-CHARACTER CHAR)))))))
(DEFUN FIND-MACRO-FUNCTION (FORM) (COND
((CL-MACRO-WRAPPED-P FORM)
(CL-UNWRAP-MACRO FORM))
((FUNCTIONP FORM)
(IL-WRAP-MACRO FORM))))
(DEFUN GET-DISPATCH-MACRO-CHARACTER (DISP-CHAR SUB-CHAR &OPTIONAL (READTABLE *READTABLE*))
(LET* ((DISP-TABLE (ASSOC DISP-CHAR (fetch (READTABLEP DISPATCHMACRODEFS) of READTABLE)))
(DISP-CONS (ASSOC SUB-CHAR (CDR DISP-TABLE))))
(COND
((OR (NULL DISP-TABLE)
(NULL DISP-CONS))
NIL)
(T (CDR DISP-CONS)))))
(DEFUN GET-MACRO-CHARACTER (CHAR &OPTIONAL (READTABLE *READTABLE*))
(* * "insures entry is Common Lisp form - (MACRO {FIRST,ALWAYS} (LAMBDA (STREAM READTABLE) (FUNCALL <function> '<char> STREAM))))")
(LET ((TABENTRY (GETSYNTAX (CHAR-CODE CHAR)
READTABLE)))
(AND (CONSP TABENTRY)
(EQ (CAR TABENTRY)
(QUOTE MACRO))
(CONSP (CDR TABENTRY))
(OR (EQ (CADR TABENTRY)
(QUOTE FIRST))
(EQ (CADR TABENTRY)
(QUOTE ALWAYS)))
(CONSP (CDDR TABENTRY))
(NULL (CDDDR TABENTRY))
(VALUES (FIND-MACRO-FUNCTION (CADDR TABENTRY))
(NOT (EQ (CADR TABENTRY)
(QUOTE ALWAYS)))))))
(DEFUN HASH-LEFTPAREN (STREAM CHAR INDEX) (* jrb: "28-Jul-86 21:50")
(LET ((CONTENTS (READ STREAM)))
(COND
(INDEX (LET ((VEC (MAKE-ARRAY INDEX :INITIAL-ELEMENT (CAR (LAST CONTENTS)))))
(DOTIMES (I (LENGTH CONTENTS))
(SETF (AREF VEC I)
(POP CONTENTS)))
VEC))
(T (MAKE-ARRAY (LENGTH CONTENTS)
:INITIAL-CONTENTS CONTENTS)))))
(DEFUN HASH-A (STREAM CHAR PARAM) (LET ((CONTENTS (READ STREAM)))
(MAKE-ARRAY (ESTIMATE-DIMENSIONALITY PARAM CONTENTS)
:INITIAL-CONTENTS CONTENTS)))
(DEFUN HASH-B (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM)
(READNUMBERINBASE STREAM 2))
(DEFUN HASH-BACKSLASH (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM)
(CHARACTER.READ STREAM))
(DEFUN HASH-C (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM)
(DESTRUCTURING-BIND (NUM DEN)
(READ STREAM)
(COMPLEX NUM DEN)))
(DEFUN HASH-COLON (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM)
(* Uninterned symbol.
This definition may yet be wrong)
(MAKE-SYMBOL (RSTRING STREAM *READTABLE*)))
(DEFUN HASH-COMMA (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM)
(LIST (QUOTE LOADTIMECONSTANT)
(READ STREAM *READTABLE*)))
(DEFUN HASH-DOT (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM)
(EVAL (READ STREAM)))
(DEFUN HASH-DOUBLEQUOTE (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM)
(RSTRING STREAM *READTABLE* (QUOTE SKIP)))
(DEFUN HASH-ILLEGAL-HASH-CHAR (STREAM CHAR PARAM) (CL:ERROR "Illegal hash macro character ~S" CHAR))
(DEFUN HASH-LEFTANGLE (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM)
(CL:ERROR "Unreadble object #<~A>" (CL:READ STREAM)))
(DEFUN HASH-MINUS (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM)
(COND
((CMLREAD.FEATURE.PARSER (CL:READ STREAM *READTABLE*))
(CL:READ STREAM *READTABLE*)))
(VALUES))
(DEFUN HASH-NO-PARAMETER-ERROR (CHAR PARAM) (CL:WHEN PARAM (CL:ERROR
"Parameter ~D not allowed with hash macro ~S"
PARAM CHAR)))
(DEFUN HASH-O (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM)
(READNUMBERINBASE STREAM 8))
(DEFUN HASH-PLUS (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM)
(*
"Skip expression if feature not present")
(COND
((NOT (CMLREAD.FEATURE.PARSER (CL:READ STREAM *READTABLE*)))
(CL:READ STREAM *READTABLE*)))
(VALUES))
(DEFUN HASH-QUOTE (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM)
(LIST (QUOTE FUNCTION)
(READ STREAM *READTABLE*)))
(DEFUN HASH-R (STREAM CHAR PARAM) (READNUMBERINBASE STREAM PARAM))
(DEFUN HASH-S (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM)
(CREATE-STRUCTURE (READ STREAM)))
(DEFUN HASH-STAR (STREAM CHAR PARAM) (LET ((CONTENTS (while (MEMQ (PEEKCCODE STREAM *READTABLE*)
(CHARCODE (0 1)))
collect (IDIFFERENCE (READCCODE STREAM
*READTABLE*)
(CHARCODE 0)))))
(COND
(PARAM (LET ((BITARRAY (MAKE-ARRAY PARAM :ELEMENT-TYPE
(QUOTE BIT)
:INITIAL-ELEMENT
(CAR (LAST CONTENTS)))))
(DOTIMES (I (LENGTH CONTENTS))
(SETF (AREF BITARRAY I)
(POP CONTENTS)))
BITARRAY))
(T (MAKE-ARRAY (LENGTH CONTENTS)
:INITIAL-CONTENTS CONTENTS :ELEMENT-TYPE
(QUOTE BIT))))))
(DEFUN HASH-VBAR (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM)
(SKIP.HASH.COMMENT STREAM *READTABLE*)
(VALUES))
(DEFUN HASH-X (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM)
(READNUMBERINBASE STREAM 16))
(DEFUN MAKE-DISPATCH-MACRO-CHARACTER (CHAR &OPTIONAL NON-TERMINATING (READTABLE *READTABLE*))
(SETSYNTAX (CHAR-CODE CHAR)
(BQUOTE (MACRO (\, (CL:IF NON-TERMINATING (QUOTE FIRST)
(QUOTE ALWAYS)))
(LAMBDA (STREAM READTABLE Z)
(DO-DISPATCH-MACRO (\, CHAR)
STREAM READTABLE))))
READTABLE)
T)
(DEFUN SET-DISPATCH-MACRO-CHARACTER (DISP-CHAR SUB-CHAR CL:FUNCTION &OPTIONAL (READTABLE *READTABLE*)
) (CL:IF (CL:MEMBER SUB-CHAR
(QUOTE (|\0 |\1 |\2 |\3 |\4 |\5 |\6 |\7 |\8
|\9)))
(CL:ERROR
"Digit ~S illegal as a sub-character for a dispatching macro"
SUB-CHAR))
(CL:SETQ SUB-CHAR (CHAR-UPCASE SUB-CHAR))
(LET* ((DISP-TABLE
(OR (ASSOC DISP-CHAR (fetch (READTABLEP
DISPATCHMACRODEFS
)
of READTABLE))
(PROGN (push (fetch (READTABLEP
DISPATCHMACRODEFS
) of READTABLE)
(LIST DISP-CHAR))
(CAR (fetch (READTABLEP
DISPATCHMACRODEFS)
of READTABLE)))))
(DISP-CONS (OR (ASSOC SUB-CHAR (CDR DISP-TABLE))
(PROGN (push (CDR DISP-TABLE)
(CONS SUB-CHAR NIL))
(CADR DISP-TABLE)))))
(SETF (CDR DISP-CONS)
CL:FUNCTION)
T))
(DEFUN SET-MACRO-CHARACTER (CHAR CL:FUNCTION &OPTIONAL NON-TERMINATING (READTABLE *READTABLE*))
(SETSYNTAX (CHAR-CODE CHAR)
(BQUOTE (MACRO (\, (CL:IF NON-TERMINATING (QUOTE FIRST)
(QUOTE ALWAYS)))
(\, (COND
((IL-MACRO-WRAPPED-P CL:FUNCTION)
(IL-UNWRAP-MACRO CL:FUNCTION))
(T (CL-WRAP-MACRO CL:FUNCTION))))))
READTABLE))
(RPAQ? *STANDARD-INPUT* NIL)
(*
"Attempt to build a CommonLisp readtable. Most features simulated for the basic reading, but macros need work"
)
(DEFINEQ
(CMLRDTBL
(LAMBDA NIL (* jrb: " 6-Aug-86 00:32")
(* * "Attempt to set up common lisp read table")
(* * "Creates a copy of the `original' read-table.")
(PROG ((TBL (COPYREADTABLE (QUOTE ORIG))))
(* * "First reset the table")
(for I from 0 to 255 do (SETSYNTAX I (QUOTE OTHER)
TBL))
(* * "Install the goodies")
(SETSEPR (CHARCODE (SPACE CR ↑L LF TAB))
1 TBL)
(SETSYNTAX (CHARCODE "'")
(QUOTE (MACRO ALWAYS READQUOTE))
TBL) (* "Note that in cml, most of these macros are terminating, even though it would be nicer for us if they were not")
(SETSYNTAX (CHARCODE ";")
(QUOTE (MACRO ALWAYS CMLREADSEMI))
TBL)
(SETSYNTAX (CHARCODE %))
(QUOTE RIGHTPAREN)
TBL)
(SETSYNTAX (CHARCODE %()
(QUOTE LEFTPAREN)
TBL)
(READTABLEPROP TBL (QUOTE CASEINSENSITIVE)
T)
(READTABLEPROP TBL (QUOTE COMMONLISP)
T)
(READTABLEPROP TBL (QUOTE COMMONNUMSYNTAX)
T)
(READTABLEPROP TBL (QUOTE ESCAPECHAR)
(CHARCODE "\"))
(READTABLEPROP TBL (QUOTE MULTIPLE-ESCAPECHAR)
(CHARCODE "|"))
(READTABLEPROP TBL (QUOTE HASHMACROCHAR)
(CHARCODE "#"))
(MAKE-DISPATCH-MACRO-CHARACTER |\# T TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\( (CL:FUNCTION HASH-LEFTPAREN)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\' (CL:FUNCTION HASH-QUOTE)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\. (CL:FUNCTION HASH-DOT)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\, (CL:FUNCTION HASH-COMMA)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\\ (CL:FUNCTION HASH-BACKSLASH)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\* (CL:FUNCTION HASH-STAR)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\: (CL:FUNCTION HASH-COLON)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\O (CL:FUNCTION HASH-O)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\B (CL:FUNCTION HASH-B)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\X (CL:FUNCTION HASH-X)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\R (CL:FUNCTION HASH-R)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\A (CL:FUNCTION HASH-A)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\S (CL:FUNCTION HASH-S)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\C (CL:FUNCTION HASH-C)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\+ (CL:FUNCTION HASH-PLUS)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\- (CL:FUNCTION HASH-MINUS)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\| (CL:FUNCTION HASH-VBAR)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\< (CL:FUNCTION HASH-LEFTANGLE)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\" (CL:FUNCTION HASH-DOUBLEQUOTE)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\Space (CL:FUNCTION HASH-ILLEGAL-HASH-CHAR)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\Tab (CL:FUNCTION HASH-ILLEGAL-HASH-CHAR)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\Newline (CL:FUNCTION HASH-ILLEGAL-HASH-CHAR)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\Page (CL:FUNCTION HASH-ILLEGAL-HASH-CHAR)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\Newline (CL:FUNCTION HASH-ILLEGAL-HASH-CHAR)
TBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\% (CL:FUNCTION HASH-ILLEGAL-HASH-CHAR)
TBL)
(SETSYNTAX (CHARCODE %")
(QUOTE STRINGDELIM)
TBL)
(SETSYNTAX (CHARCODE "`")
(QUOTE (MACRO ALWAYS READBQUOTE))
TBL)
(SETSYNTAX (CHARCODE ",")
(QUOTE (MACRO ALWAYS READBQUOTECOMMA))
TBL)
(SETSYNTAX (CHARCODE "%%")
(QUOTE OTHER)
TBL) (* "redundant")
(RETURN TBL))))
(CMLREADSEMI
[LAMBDA (STREAM RDTBL) (* bvm: "14-May-86 17:35")
(* * Read and discard through end of line)
(until (EQ (READCCODE STREAM)
(CHARCODE NEWLINE)) do NIL)
(VALUES])
)
(RPAQ CMLRDTBL (CMLRDTBL))
(* "Crude means to aid reading and printing things in same reader environment")
[DECLARE: EVAL@COMPILE
(DATATYPE READER-ENVIRONMENT (REPACKAGE REREADTABLE REBASE RESPEC))
]
(/DECLAREDATATYPE (QUOTE READER-ENVIRONMENT)
(QUOTE (POINTER POINTER POINTER POINTER))
(QUOTE ((READER-ENVIRONMENT 0 POINTER)
(READER-ENVIRONMENT 2 POINTER)
(READER-ENVIRONMENT 4 POINTER)
(READER-ENVIRONMENT 6 POINTER)))
(QUOTE 8))
(DEFINEQ
(MAKE-READER-ENVIRONMENT
[LAMBDA (PACKAGE READTABLE BASE) (* bvm: "28-Jul-86 12:29")
(create READER-ENVIRONMENT
REPACKAGE ← (COND
(PACKAGE (\DTEST PACKAGE (QUOTE PACKAGE)))
(T *PACKAGE*))
REREADTABLE ← (COND
(READTABLE (\DTEST READTABLE (QUOTE READTABLEP)))
(T *READTABLE*))
REBASE ← (COND
(BASE (\CHECKRADIX BASE))
(T *READ-BASE*])
(EQUAL-READER-ENVIRONMENT
[LAMBDA (ENV1 ENV2) (* bvm: "31-Jul-86 12:54")
(AND (EQ (fetch (READER-ENVIRONMENT REREADTABLE) of ENV1)
(fetch (READER-ENVIRONMENT REREADTABLE) of ENV2))
(EQ (fetch (READER-ENVIRONMENT REPACKAGE) of ENV1)
(fetch (READER-ENVIRONMENT REPACKAGE) of ENV2))
(EQ (fetch (READER-ENVIRONMENT REBASE) of ENV1)
(fetch (READER-ENVIRONMENT REBASE) of ENV2])
)
(DEFMACRO WITH-READER-ENVIRONMENT (ENV . BODY) (BQUOTE ((CL:LAMBDA
(E)
(LET ((*PACKAGE* (ffetch (READER-ENVIRONMENT
REPACKAGE)
of E))
(*READTABLE* (ffetch (
READER-ENVIRONMENT
REREADTABLE)
of E))
(*READ-BASE* (ffetch (
READER-ENVIRONMENT
REBASE)
of E))
(*PRINT-BASE* (ffetch (
READER-ENVIRONMENT
REBASE)
of E)))
(\,@ BODY)))
(\DTEST (\, ENV)
(QUOTE READER-ENVIRONMENT)))))
(ADDTOVAR SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*)
(RPAQ? *OLD-INTERLISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REREADTABLE ← FILERDTBL REBASE ←
10))
(PUTPROPS WITH-READER-ENVIRONMENT INFO EVAL)
(PUTPROPS CMLREAD FILETYPE COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA COPY-READTABLE CL:READ)
)
(PUTPROPS CMLREAD COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3604 6387 (CL:READ 3614 . 3840) (COPY-READTABLE 3842 . 5405) (READ-DELIMITED-LIST 5407
. 6385)) (27992 32932 (CMLRDTBL 28002 . 32648) (CMLREADSEMI 32650 . 32930)) (33450 34565 (
MAKE-READER-ENVIRONMENT 33460 . 34027) (EQUAL-READER-ENVIRONMENT 34029 . 34563)))))
STOP