(FILECREATED "12-Sep-86 22:26:17" {ERIS}<LISPCORE>LIBRARY>CMLREAD.;72 42526
changes to: (VARS CMLREADCOMS)
(FUNCTIONS HASH-STAR HASH-COLON)
previous date: "12-Sep-86 14:45:20" {ERIS}<LISPCORE>LIBRARY>CMLREAD.;71)
(* 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)
(COMS (* READ-PRESERVING-WHITESPACE definitely needs more work. Other functions in this
COMS may. *)
(FNS READ-PRESERVING-WHITESPACE READ-DELIMITED-LIST READ-LINE READ-CHAR
UNREAD-CHAR PEEK-CHAR LISTEN READ-CHAR-NO-HANG CLEAR-INPUT READ-FROM-STRING
READ-BYTE WRITE-BYTE))
(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 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)
(*READ-DEFAULT-FLOAT-FORMAT* (QUOTE SINGLE-FLOAT)))
(COMS (* "Attempt to build a CommonLisp readtable. Most features simulated for the basic reading, but macros need work"
)
(FNS CMLRDTBL INIT-CML-READTABLES SET-DEFAULT-HASHMACRO-SETTINGS CMLREADSEMI)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (INIT-CML-READTABLES))))
(COMS (* "Crude means to aid reading and printing things in same reader environment. There are some fns and an INITRECORDS for this on ATBL to get it early in the loadup"
)
(RECORDS READER-ENVIRONMENT)
(FUNCTIONS WITH-READER-ENVIRONMENT)
(ADDVARS (SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*))
(PROP INFO WITH-READER-ENVIRONMENT)
(GLOBALVARS *COMMON-LISP-READ-ENVIRONMENT*)
(INITVARS (*COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REPACKAGE ←
(FIND-PACKAGE "USER")
REREADTABLE ← CMLRDTBL REBASE ← 10))))
(PROP FILETYPE CMLREAD)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA WRITE-BYTE READ-BYTE READ-FROM-STRING CLEAR-INPUT READ-CHAR-NO-HANG
LISTEN PEEK-CHAR UNREAD-CHAR READ-CHAR READ-LINE
READ-PRESERVING-WHITESPACE 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*)
TO-READTABLE) (* bvm: "11-Sep-86 17:59")
(* If FROM-READTABLE is NIL, then a
copy of a standard Common Lisp
readtable is made. *)
(if (AND (NULL FROM-READTABLE)
(NULL TO-READTABLE))
then (* ; "just make a brand new one")
(CMLRDTBL)
else (SETQ FROM-READTABLE (\DTEST (OR FROM-READTABLE (CMLRDTBL))
(QUOTE READTABLEP)))
(if TO-READTABLE
then (RESETREADTABLE (\DTEST TO-READTABLE (QUOTE READTABLEP))
FROM-READTABLE)
TO-READTABLE
else (COPYREADTABLE FROM-READTABLE)))))
)
(* READ-PRESERVING-WHITESPACE definitely needs more work. Other functions in this COMS may. *)
(DEFINEQ
(READ-PRESERVING-WHITESPACE
(CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*)
(EOF-ERRORP T)
(EOF-VALUE NIL)
(RECURSIVEP NIL)) (* bvm: "11-Sep-86 17:46")
(* Reads from stream and returns the
object read, preserving the whitespace
that followed the object.
*)
(LET ((RESULT (CL:READ STREAM EOF-ERRORP EOF-VALUE RECURSIVEP)))
(if (SYNTAXP (LASTC STREAM)
(QUOTE SEPRCHAR))
then (\BACKCHAR STREAM))
RESULT)))
(READ-DELIMITED-LIST
(LAMBDA (CHAR INPUT-STREAM RECURSIVE-P) (* bvm: " 8-Sep-86 12:37")
(* * "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 (OR (FIXP CHAR)
(CHAR-CODE CHAR)))
(INSTREAM (\GETSTREAM INPUT-STREAM (QUOTE INPUT))))
(until (EQ (SKIPSEPRCODES INSTREAM)
ENDCODE) collect (READ INSTREAM) finally (* Consume the terminating character)
(READCCODE INSTREAM)))))
(READ-LINE
(CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*)
(EOF-ERRORP T)
EOF-VALUE RECURSIVE-P) (* bvm: "11-Sep-86 15:08")
(* Returns a line of text read from
the STREAM as a string, discarding the
newline character. *)
(DECLARE (IGNORE RECURSIVE-P))
(LET ((RESULT (RSTRING STREAM READ-LINE-RDTBL)))
(if (\EOFP STREAM)
then (if (EQ (NCHARS RESULT)
0)
then (* ;
"eof before anything read, so observe EOF-ERRORP")
(if EOF-ERRORP
then (\EOF.ACTION STREAM)
else EOF-VALUE)
else (VALUES RESULT T))
else (* ; "consume the eol")
(READCCODE STREAM)
(VALUES RESULT NIL)))))
(READ-CHAR
(CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*)
(EOF-ERRORP T)
EOF-VALUE RECURSIVE-P) (* bvm: "11-Sep-86 15:17")
(* Inputs a character from STREAM and
returns it. *)
(DECLARE (IGNORE RECURSIVE-P))
(LET ((STREAM (\GETSTREAM STREAM (QUOTE INPUT))))
(CL:IF (AND (NOT EOF-ERRORP)
(\EOFP STREAM))
EOF-VALUE
(CODE-CHAR (READCCODE STREAM))))))
(UNREAD-CHAR
(CL:LAMBDA (CHARACTER &OPTIONAL (INPUT-STREAM *STANDARD-INPUT*))
(* bvm: "11-Sep-86 15:18")
(* Puts the CHARACTER back on the
front of the input STREAM.
According to the manual,
"One may apply UNREAD-CHAR only to the character most recently read from INPUT-STREAM."
*)
(\BACKCHAR (\GETSTREAM INPUT-STREAM (QUOTE INPUT)))
NIL))
(PEEK-CHAR
(CL:LAMBDA (&OPTIONAL (PEEK-TYPE NIL)
(STREAM *STANDARD-INPUT*)
(EOF-ERRORP T)
EOF-VALUE RECURSIVE-P) (* bvm: "11-Sep-86 17:27")
(* Peeks at the next character in the
input Stream. See manual for details.
*)
(DECLARE (IGNORE RECURSIVE-P))
(LET ((STREAM (\GETSTREAM STREAM (QUOTE INPUT)))
CHAR)
(SELECTQ PEEK-TYPE
(NIL (* ; "standard case--return next char")
(if (SETQ CHAR (\PEEKCCODE STREAM (NULL EOF-ERRORP)))
then (CODE-CHAR CHAR)
else EOF-VALUE))
(T (* ; "skip whitespace before peeking")
(if (SETQ CHAR (SKIPSEPRCODES STREAM))
then (CODE-CHAR CHAR)
elseif EOF-ERRORP
then (\EOF.ACTION STREAM)
else EOF-VALUE))
(if (CHARACTERP PEEK-TYPE)
then (LET ((DESIREDCHAR (CHAR-CODE PEEK-TYPE))
(NOERROR (NULL EOF-ERRORP)))
(until (EQ (SETQ CHAR (\PEEKCCODE STREAM NOERROR))
DESIREDCHAR) do (if (NULL CHAR)
then (RETURN EOF-VALUE))
(READCCODE STREAM)
finally (RETURN PEEK-TYPE)))
else (\ILLEGAL.ARG PEEK-TYPE))))))
(LISTEN
(CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*)) (* bvm: "11-Sep-86 17:31")
(* Returns T if a character is
availible on the given STREAM *)
(READP (\GETSTREAM STREAM (QUOTE INPUT)))))
(READ-CHAR-NO-HANG
(CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*)
(EOF-ERRORP T)
EOF-VALUE RECURSIVE-P) (* kbr: "18-Aug-86 19:53")
(* Returns the next character from the
STREAM if one is availible, or NIL *)
(DECLARE (IGNORE RECURSIVE-P))
(CL:IF (LISTEN STREAM)
(READ-CHAR STREAM EOF-ERRORP EOF-VALUE)
NIL)))
(CLEAR-INPUT
(CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*)) (* bvm: "12-Sep-86 14:32")
(* Clears any buffered input
associated with the Stream.
*)
(CLEARBUF (\GETSTREAM STREAM (QUOTE INPUT)))))
(READ-FROM-STRING
(CL:LAMBDA (STRING &OPTIONAL EOF-ERROR-P EOF-VALUE &KEY START END PRESERVE-WHITESPACE)
(* bvm: "11-Sep-86 17:41")
(LET ((STREAM (OPENSTRINGSTREAM (if END
then (SUBSTRING STRING 1 END)
else (MKSTRING STRING)))))
(if START
then (SETFILEPTR STREAM START))
(VALUES (CL:IF PRESERVE-WHITESPACE (READ-PRESERVING-WHITESPACE STREAM EOF-ERROR-P
EOF-VALUE)
(CL:READ STREAM EOF-ERROR-P EOF-VALUE))
(\GETFILEPTR STREAM)))))
(READ-BYTE
(CL:LAMBDA (BINARY-INPUT-STREAM &OPTIONAL (EOF-ERRORP T)
EOF-VALUE) (* bvm: "11-Sep-86 17:43")
(* Returns the next byte of the
BINARY-INPUT-STREAM *)
(LET ((STREAM (\GETSTREAM BINARY-INPUT-STREAM (QUOTE INPUT))))
(CL:IF (AND (NOT EOF-ERRORP)
(\EOFP STREAM))
EOF-VALUE
(\BIN STREAM)))))
(WRITE-BYTE
(CL:LAMBDA (INTEGER BINARY-OUTPUT-STREAM) (* kbr: "18-Aug-86 20:22")
(* Outputs the INTEGER to the binary
BINARY-OUTPUT-STREAM *)
(BOUT BINARY-OUTPUT-STREAM INTEGER)
INTEGER))
)
(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 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 ((*READTABLE* RDTBL)
(DISP-TABLE (CDR (ASSOC CHAR (fetch (READTABLEP DISPATCHMACRODEFS) of RDTBL))))
INDEX NEXTCHAR)
(* * 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)))))
(COND
((NOT DISP-TABLE)
(CL:ERROR "~S is not a dispatch macro character" CHAR))
(T (* DISPATCHMACRODEFS is a list of
A-lists)
(while (DIGITCHARP (SETQ NEXTCHAR (READCCODE STREAM RDTBL)))
do (* ; "read the optional numeric arg")
(SETQ INDEX (PLUS (TIMES (OR INDEX 0)
10)
(DIFFERENCE NEXTCHAR (CHARCODE 0)))))
(LET* ((DISP-CHARACTER (CHAR-UPCASE (CODE-CHAR NEXTCHAR)))
(DISP-FUNCTION (CDR (ASSOC DISP-CHARACTER DISP-TABLE))))
(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-DELIMITED-LIST |\) STREAM T)))
(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 (READ-EXTENDED-TOKEN STREAM *READTABLE* T)))
(DEFUN HASH-COMMA (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM)
(LIST (QUOTE LOADTIMECONSTANT)
(READ STREAM)))
(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 "Unreadable object #<~A>" (CL:READ STREAM)))
(DEFUN HASH-MINUS (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM)
(COND
((CMLREAD.FEATURE.PARSER (CL:READ STREAM))
(CL:READ STREAM)))
(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)))
(CL:READ STREAM)))
(VALUES))
(DEFUN HASH-QUOTE (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM)
(LIST (QUOTE FUNCTION)
(CL:READ STREAM)))
(DEFUN HASH-R (STREAM CHAR PARAM) (if PARAM
then (READNUMBERINBASE STREAM PARAM)
else (CL:ERROR "No base supplied for #R")))
(DEFUN HASH-S (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM)
(CREATE-STRUCTURE (READ STREAM)))
(DEFUN HASH-STAR (STREAM CHAR PARAM)
(LET* ((CONTENTS (READ-EXTENDED-TOKEN STREAM))
(LEN (NCHARS CONTENTS)))
(if (AND (EQ LEN 0)
PARAM
(NEQ PARAM 0))
then (CL:ERROR "No contents specified for bit vector #~A*" PARAM)
elseif (AND PARAM (> LEN PARAM))
then (CL:ERROR "Bit vector contents longer than specified length in #~A*~A" PARAM
CONTENTS)
else (LET ((BITARRAY (MAKE-ARRAY (OR PARAM LEN)
:ELEMENT-TYPE
(QUOTE BIT)
:INITIAL-ELEMENT
(if PARAM
then (SELCHARQ (NTHCHARCODE CONTENTS -1)
(0 0)
(1 1)
(CL:ERROR "Illegal bit vector element in #~A*~A"
PARAM CONTENTS))
else 0))))
(DOTIMES (I LEN)
(SETF (AREF BITARRAY I)
(SELCHARQ (NTHCHARCODE CONTENTS (1+ I))
(0 0)
(1 1)
(CL:ERROR "Illegal bit vector element in #~A*~A" PARAM
CONTENTS))))
BITARRAY))))
(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)
(RPAQ? *READ-DEFAULT-FLOAT-FORMAT* (QUOTE SINGLE-FLOAT))
(*
"Attempt to build a CommonLisp readtable. Most features simulated for the basic reading, but macros need work"
)
(DEFINEQ
(CMLRDTBL
(LAMBDA NIL (* bvm: "11-Sep-86 17:57")
(* ;; "Creates a vanilla common-lisp read table")
(PROG ((TBL (COPYREADTABLE (QUOTE ORIG))))
(* * "First reset the table")
(for I from 0 to \MAXTHINCHAR 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 USESILPACKAGE)
NIL)
(READTABLEPROP TBL (QUOTE ESCAPECHAR)
(CHARCODE "\"))
(READTABLEPROP TBL (QUOTE MULTIPLE-ESCAPECHAR)
(CHARCODE "|"))
(SET-DEFAULT-HASHMACRO-SETTINGS TBL)
(SETSYNTAX (CHARCODE %")
(QUOTE STRINGDELIM)
TBL)
(SETSYNTAX (CHARCODE "`")
(QUOTE (MACRO ALWAYS READBQUOTE))
TBL)
(SETSYNTAX (CHARCODE ",")
(QUOTE (MACRO ALWAYS READBQUOTECOMMA))
TBL)
(RETURN TBL))))
(INIT-CML-READTABLES
(LAMBDA NIL (* bvm: "11-Sep-86 18:00")
(READTABLEPROP (SETQ CMLRDTBL (CMLRDTBL))
(QUOTE NAME)
"LISP")
(SETQ *COMMON-LISP-READ-ENVIRONMENT* (MAKE-READER-ENVIRONMENT *LISP-PACKAGE* CMLRDTBL 10))
(LET ((FILETBL (COPYREADTABLE CMLRDTBL))) (*
"Make one for files that has font indicators as seprs")
(for I from 1 to 26 do (SETSYNTAX I (QUOTE SEPRCHAR)
FILETBL))
(READTABLEPROP FILETBL (QUOTE NAME)
"XCL"))
(SETQ READ-LINE-RDTBL (COPYREADTABLE (QUOTE ORIG)))
(SETBRK (CHARCODE (EOL))
NIL READ-LINE-RDTBL)
(SETSEPR NIL NIL READ-LINE-RDTBL)))
(SET-DEFAULT-HASHMACRO-SETTINGS
(LAMBDA (RDTBL) (* bvm: "11-Sep-86 14:49")
(READTABLEPROP RDTBL (QUOTE HASHMACROCHAR)
(CHARCODE "#"))
(MAKE-DISPATCH-MACRO-CHARACTER |\# T RDTBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\( (QUOTE HASH-LEFTPAREN)
RDTBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\' (QUOTE HASH-QUOTE)
RDTBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\. (QUOTE HASH-DOT)
RDTBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\, (QUOTE HASH-COMMA)
RDTBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\\ (QUOTE HASH-BACKSLASH)
RDTBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\* (QUOTE HASH-STAR)
RDTBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\: (QUOTE HASH-COLON)
RDTBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\O (QUOTE HASH-O)
RDTBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\B (QUOTE HASH-B)
RDTBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\X (QUOTE HASH-X)
RDTBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\R (QUOTE HASH-R)
RDTBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\A (QUOTE HASH-A)
RDTBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\S (QUOTE HASH-S)
RDTBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\C (QUOTE HASH-C)
RDTBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\+ (QUOTE HASH-PLUS)
RDTBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\- (QUOTE HASH-MINUS)
RDTBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\| (QUOTE HASH-VBAR)
RDTBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\< (QUOTE HASH-LEFTANGLE)
RDTBL)
(SET-DISPATCH-MACRO-CHARACTER |\# |\" (QUOTE HASH-DOUBLEQUOTE)
RDTBL)
RDTBL))
(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)))
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(INIT-CML-READTABLES)
)
(*
"Crude means to aid reading and printing things in same reader environment. There are some fns and an INITRECORDS for this on ATBL to get it early in the loadup"
)
[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))
(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*)
(PUTPROPS WITH-READER-ENVIRONMENT INFO EVAL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *COMMON-LISP-READ-ENVIRONMENT*)
)
(RPAQ? *COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REPACKAGE ← (FIND-PACKAGE "USER")
REREADTABLE ← CMLRDTBL REBASE ← 10))
(PUTPROPS CMLREAD FILETYPE COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA WRITE-BYTE READ-BYTE READ-FROM-STRING CLEAR-INPUT READ-CHAR-NO-HANG LISTEN PEEK-CHAR
UNREAD-CHAR READ-CHAR READ-LINE READ-PRESERVING-WHITESPACE COPY-READTABLE
CL:READ)
)
(PUTPROPS CMLREAD COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3872 5205 (CL:READ 3882 . 4108) (COPY-READTABLE 4110 . 5203)) (5309 14932 (
READ-PRESERVING-WHITESPACE 5319 . 6172) (READ-DELIMITED-LIST 6174 . 7198) (READ-LINE 7200 . 8501) (
READ-CHAR 8503 . 9157) (UNREAD-CHAR 9159 . 9872) (PEEK-CHAR 9874 . 11835) (LISTEN 11837 . 12192) (
READ-CHAR-NO-HANG 12194 . 12768) (CLEAR-INPUT 12770 . 13194) (READ-FROM-STRING 13196 . 13977) (
READ-BYTE 13979 . 14561) (WRITE-BYTE 14563 . 14930)) (34341 39236 (CMLRDTBL 34351 . 36359) (
INIT-CML-READTABLES 36361 . 37198) (SET-DEFAULT-HASHMACRO-SETTINGS 37200 . 38951) (CMLREADSEMI 38953
. 39234)))))
STOP