(FILECREATED " 5-Aug-86 14:15:22" {ERIS}<LISPCORE>LIBRARY>CMLREAD.;53 35950
changes to: (FNS CMLRDTBL)
(FUNCTIONS MAKE-DISPATCH-MACRO-CHARACTER SET-MACRO-CHARACTER CMLREADQUOTE
DO-DISPATCH-MACRO GET-DISPATCH-MACRO-CHARACTER HASH-LEFTPAREN
SET-DISPATCH-MACRO-CHARACTER)
(VARS CMLREADCOMS)
previous date: " 5-Aug-86 13:39:08" {ERIS}<LISPCORE>LIBRARY>CMLREAD.;52)
(* 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 CMLREADBQUOTE CMLREADBQUOTECOMMA CMLREADQUOTE 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 CMLREADBQUOTE (STREAM CHAR) (READBQUOTE STREAM *READTABLE*))
(DEFUN CMLREADBQUOTECOMMA (STREAM CHAR) (READBQUOTECOMMA STREAM *READTABLE*))
(DEFUN CMLREADQUOTE (STREAM CHAR) (READQUOTE STREAM *READTABLE*))
(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) (FLET ((UNQUOTE (X)
(CL:IF (AND (CONSP X)
(EQ (CAR X)
(QUOTE QUOTE)))
(CADR X)
X)))
(CL:IF (AND (CONSP FORM)
(EQ (CAR FORM)
(QUOTE CL:LAMBDA))
(CONSP (CDR FORM))
(CL:EQUAL (CADR FORM)
(QUOTE (STREAM READTABLE)))
(CONSP (CDDR FORM))
(CONSP (CADDR FORM))
(EQ (CAADDR FORM)
(QUOTE FUNCALL)))
(CADR (CADDR 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))
(FIND-MACRO-FUNCTION (CADDR TABENTRY)))))
(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 CL:FIRST)
(QUOTE ALWAYS)))
(LAMBDA (STREAM READTABLE Z)
(FUNCALL (\, (CL:IF (SYMBOLP CL:FUNCTION)
(LIST (QUOTE QUOTE)
CL:FUNCTION)
CL:FUNCTION))
(\, CHAR)
STREAM))))
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: " 5-Aug-86 14:14")
(* * "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))
(SET-MACRO-CHARACTER |\' (FUNCTION CMLREADQUOTE)
NIL TBL) (* "Note that in cml, most of these macros are terminating, even though it would be nicer for us if they were not")
(SET-MACRO-CHARACTER |\; (FUNCTION CMLREADSEMI)
NIL 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)
(SET-MACRO-CHARACTER |\` (FUNCTION CMLREADBQUOTE)
NIL TBL)
(SET-MACRO-CHARACTER |\, (FUNCTION CMLREADBQUOTECOMMA)
NIL 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 (3306 6089 (CL:READ 3316 . 3542) (COPY-READTABLE 3544 . 5107) (READ-DELIMITED-LIST 5109
. 6087)) (27017 31954 (CMLRDTBL 27027 . 31670) (CMLREADSEMI 31672 . 31952)) (32472 33587 (
MAKE-READER-ENVIRONMENT 32482 . 33049) (EQUAL-READER-ENVIRONMENT 33051 . 33585)))))
STOP