(FILECREATED "14-Oct-86 17:24:06" {ERIS}<LISPCORE>SOURCES>LLREAD.;26 73976
changes to: (VARS LLREADCOMS)
(FNS \SUBREAD \INVALID.SYMBOL)
(MACROS FIXDOT PROPRB \RDCONC \BACKCHAR \CHECKEOLC \INCHAR \INCCODE \NSIN \NSPEEK)
previous date: "26-Sep-86 12:51:03" {ERIS}<LISPCORE>SOURCES>LLREAD.;23)
(* "
Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT LLREADCOMS)
(RPAQQ LLREADCOMS ((COMS (* ; "Reader entrypoints")
(FNS LASTC PEEKC PEEKCCODE RATOM READ READC READCCODE READP SETREADMACROFLG
SKIPSEPRCODES SKIPSEPRS \NSIN.24BITENCODING.ERROR))
(COMS (* ; "reading strings")
(FNS RSTRING READ-EXTENDED-TOKEN \RSTRING2))
(COMS (* ; "Core of the reader")
(FNS \SUBREAD \READ.SYMBOL \INVALID.SYMBOL \APPLYREADMACRO INREADMACROP))
(COMS (* ; "Read macro for '")
(FNS READQUOTE))
(COMS (* ; "# macro")
(FNS READVBAR READHASHMACRO DEFMACRO-LAMBDA-LIST-KEYWORD-P DIGITBASEP
READNUMBERINBASE ESTIMATE-DIMENSIONALITY SKIP.HASH.COMMENT
CMLREAD.FEATURE.PARSER CREATE-STRUCTURE))
(DECLARE: DONTCOPY (CONSTANTS * READTYPES)
(MACROS FIXDOT RBCONTEXT PROPRB \RDCONC)
(EXPORT (MACROS \BACKCHAR \BACKNSCHAR \CHECKEOLC \INCHAR \INCCODE
\PEEKCCODE \NSIN \NSPEEK))
(SPECVARS \RefillBufferFn)
(GLOBALVARS *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*))
(INITVARS (*SIGNAL-24BIT-NSENCODING-ERROR*)
(\RefillBufferFn (FUNCTION \READCREFILL)))
(* ;
"Act like READC if there is no binding of \RefillBufferFn--we must be doing a raw BIN (or PEEKBIN?)"
)
(LOCALVARS . T)))
(* ; "Reader entrypoints")
(DEFINEQ
(LASTC
[LAMBDA (FILE) (* rmk: "27-Mar-85 16:50")
(* Be careful only to do BIN's if we first were able to back up, so that an EOF
doesn't happen. This is really an inadequate implementation, because it fails
for files that cannot be backed up. Eventually, we must change the character
reading functions READ, RATOM, READC to save the last character they read in an
STREAM field.)
(PROG [C SHIFTEDCHARSET (STREAM (\GETSTREAM FILE (QUOTE INPUT]
(SETQ SHIFTEDCHARSET (UNFOLD (ffetch CHARSET of STREAM)
256))
(RETURN
(FCHARACTER
(SELCHARQ (SETQ C (UNINTERRUPTABLY
(\BACKNSCHAR STREAM SHIFTEDCHARSET)
(\NSIN STREAM SHIFTEDCHARSET)))
(CR (SELECTC (ffetch EOLCONVENTION of STREAM)
(CR.EOLC (CHARCODE EOL))
C))
(LF (SELECTC (ffetch EOLCONVENTION of STREAM)
(LF.EOLC (CHARCODE EOL))
(CRLF.EOLC (COND
([EQ (CHARCODE CR)
(UNINTERRUPTABLY
(AND (\BACKNSCHAR STREAM SHIFTEDCHARSET)
(PROG1 (PROGN (\BACKNSCHAR STREAM SHIFTEDCHARSET
)
(\NSIN STREAM SHIFTEDCHARSET))
(\NSIN STREAM SHIFTEDCHARSET))))]
(CHARCODE EOL))
(T C)))
C))
(NIL 0)
C])
(PEEKC
[LAMBDA (FILE FLG) (* rmk: "10-Apr-85 11:55")
(* FLG says to proceed as if Control
were T--not implemented correctly here
NIL)
(LET [(\RefillBufferFn (FUNCTION \PEEKREFILL))
(STREAM (\GETSTREAM FILE (QUOTE INPUT]
(DECLARE (SPECVARS \RefillBufferFn))
(FCHARACTER (PEEKCCODE STREAM])
(PEEKCCODE
[LAMBDA (FILE NOERROR) (* bvm: "12-Sep-86 15:19")
(LET [(\RefillBufferFn (FUNCTION \PEEKREFILL))
(STREAM (\GETSTREAM FILE (QUOTE INPUT]
(DECLARE (SPECVARS \RefillBufferFn))
(\PEEKCCODE STREAM NOERROR])
(RATOM
[LAMBDA (FILE RDTBL) (* bvm: "12-Sep-86 21:23")
(* * Like READ except interpret break characters as single character atoms.
I.e., always returns an atom)
(SETQ RDTBL (\GTREADTABLE RDTBL))
(LET ((*READTABLE* RDTBL)
(*PACKAGE* (if (fetch (READTABLEP USESILPACKAGE) of RDTBL)
then *INTERLISP-PACKAGE*
else *PACKAGE*))
(\RefillBufferFn (FUNCTION \RATOM/RSTRING-REFILL)))
(DECLARE (SPECVARS *READTABLE* *PACKAGE* \RefillBufferFn))
(WITH-RESOURCE (\PNAMESTRING)
(\SUBREAD (\GETSTREAM FILE (QUOTE INPUT))
(fetch (READTABLEP READSA) of *READTABLE*)
RATOM.RT \PNAMESTRING (AND (fetch (READTABLEP CASEINSENSITIVE) of *READTABLE*)
(fetch (ARRAYP BASE) of UPPERCASEARRAY])
(READ
[LAMBDA (FILE RDTBL FLG) (* bvm: "12-Sep-86 21:23")
(DECLARE (SPECVARS FLG)) (* FLG is used freely by \FILLBUFFER)
(SETQ RDTBL (\GTREADTABLE RDTBL))
(LET ((*READTABLE* RDTBL)
(*PACKAGE* (if (fetch (READTABLEP USESILPACKAGE) of RDTBL)
then *INTERLISP-PACKAGE*
else *PACKAGE*))
(\RefillBufferFn (FUNCTION \READREFILL)))
(DECLARE (SPECVARS *READTABLE* *PACKAGE* \RefillBufferFn))
(WITH-RESOURCE (\PNAMESTRING)
(\SUBREAD (\GETSTREAM FILE (QUOTE INPUT))
(fetch (READTABLEP READSA) of *READTABLE*)
READ.RT \PNAMESTRING (AND (fetch (READTABLEP CASEINSENSITIVE) of *READTABLE*)
(fetch (ARRAYP BASE) of UPPERCASEARRAY])
(READC
[LAMBDA (FILE RDTBL) (* bvm: " 2-May-86 13:39")
(LET ((*READTABLE* (\GTREADTABLE RDTBL))
(\RefillBufferFn (FUNCTION \READCREFILL)))
(DECLARE (SPECVARS *READTABLE* \RefillBufferFn))
(FCHARACTER (\INCCODE (\INSTREAMARG FILE])
(READCCODE
[LAMBDA (FILE RDTBL) (* bvm: " 2-May-86 13:39")
(* * returns a 16 bit character code. \INCHAR does the EOL conversion and this
function converts to a 16 bit value)
(LET ((*READTABLE* (\GTREADTABLE RDTBL))
(\RefillBufferFn (FUNCTION \READCREFILL)))
(DECLARE (SPECVARS *READTABLE* \RefillBufferFn))
(\INCCODE (\INSTREAMARG FILE])
(READP
[LAMBDA (FILE FLG) (* rmk: " 5-Apr-85 09:09")
(* The 10 does not do the EOL check on
the peeked character.)
(LET* ((STREAM (\GETSTREAM FILE (QUOTE INPUT)))
(DEVICE (ffetch (STREAM DEVICE) of STREAM)))
(COND
((ffetch (FDEV READP) of DEVICE)
(FDEVOP (QUOTE READP)
DEVICE STREAM FLG))
(T (\GENERIC.READP STREAM FLG])
(SETREADMACROFLG
[LAMBDA (FLG) (* rmk: "25-OCT-83 16:13")
(* D doesn't cause the read-macro
context error, hence doesn't maintain
this flag)
NIL])
(SKIPSEPRCODES
[LAMBDA (FILE RDTBL) (* rmk: " 4-Apr-85 09:36")
(* Passes over non-separators to peek at the first non-separator on FILE.
Returns either last peeked character, or NIL if no non-seprs left in the file.)
(bind C SHIFTEDCHARSET (STREAM ← (\GETSTREAM FILE (QUOTE INPUT)))
(SA ← (fetch (READTABLEP READSA) of (\GTREADTABLE RDTBL)))
(\RefillBufferFn ← (QUOTE \PEEKREFILL)) first (SETQ SHIFTEDCHARSET
(UNFOLD (ffetch (STREAM CHARSET)
of STREAM)
256)) declare (SPECVARS
\RefillBufferFn)
while [EQ SEPRCHAR.RC (\SYNCODE SA (SETQ C (OR (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET T
)
(RETURN] do (\NSIN STREAM SHIFTEDCHARSET
SHIFTEDCHARSET)
finally (RETURN C])
(SKIPSEPRS
[LAMBDA (FILE RDTBL) (* rmk: "27-Mar-85 16:31")
(* Passes over non-separators to peek at the first non-separator on FILE.
Returns either last peeked character, or NIL if no non-seprs left in the file.)
(bind C SHIFTEDCHARSET (STREAM ← (\GETSTREAM FILE (QUOTE INPUT)))
(SA ← (fetch (READTABLEP READSA) of (\GTREADTABLE RDTBL)))
(\RefillBufferFn ← (QUOTE \PEEKREFILL)) first (SETQ SHIFTEDCHARSET
(UNFOLD (ffetch (STREAM CHARSET)
of STREAM)
256)) declare (SPECVARS
\RefillBufferFn)
while [EQ SEPRCHAR.RC (\SYNCODE SA (SETQ C (OR (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET T
)
(RETURN] do (\NSIN STREAM SHIFTEDCHARSET
SHIFTEDCHARSET)
finally (RETURN (FCHARACTER C])
(\NSIN.24BITENCODING.ERROR
[LAMBDA (STREAM) (* bvm: "12-Mar-86 15:35")
(DECLARE (USEDFREE *SIGNAL-24BIT-NSENCODING-ERROR*))
(* * Called if we see the sequence shift,shift on STREAM --
means shift to 24-bit character set, which we don't support.
Usually this just means we're erroneously reading a binary file as text.
If this function returns, its value is taken as a character set to shift to)
(COND
(*SIGNAL-24BIT-NSENCODING-ERROR* (* Only cause error if user/reader
cares)
(ERROR "24-bit NS encoding not supported" STREAM)))
(* Return charset zero)
0])
)
(* ; "reading strings")
(DEFINEQ
(RSTRING
[LAMBDA (FILE RDTBL RSFLG) (* bvm: "15-May-86 14:45")
(LET ((*READTABLE* (\GTREADTABLE RDTBL))
(\RefillBufferFn (QUOTE \RATOM/RSTRING-REFILL)))
(DECLARE (SPECVARS *READTABLE* \RefillBufferFn))
(WITH-RESOURCE (\PNAMESTRING)
(\RSTRING2 (\GETSTREAM FILE (QUOTE INPUT))
(fetch READSA of *READTABLE*)
(OR RSFLG T)
\PNAMESTRING])
(READ-EXTENDED-TOKEN
[LAMBDA (STREAM RDTBL ESCAPE-ALLOWED-P) (* bvm: "12-Sep-86 22:18")
(* ;; "This is a cross between RSTRING and \SUBREAD. Read a %"token%" from STREAM, as defined by the Common Lisp reader and the syntax in RDTBL. EOF terminates as well. If ESCAPE-ALLOWED-P is true, escapes are honored and if one appears, a second value of T is returned. Otherwise, escapes are treated as vanilla chars and the caller can barf on them itself if it desires.")
(SETQ RDTBL (\GTREADTABLE RDTBL))
(WITH-RESOURCE (\PNAMESTRING)
(PROG ((CASEBASE (AND (fetch (READTABLEP CASEINSENSITIVE) of RDTBL)
(fetch (ARRAYP BASE) of UPPERCASEARRAY)))
(PBASE (ffetch (STRINGP XBASE) of \PNAMESTRING))
(SHIFTEDCHARSET (UNFOLD (ffetch CHARSET of STREAM)
256))
(J 0)
(SA (fetch READSA of RDTBL))
CH SNX ANSLIST ANSTAIL ESCAPE-APPEARED ESCAPING FATSEEN)
LP (if (\EOFP STREAM)
then (* ;
"end of file terminates string just like a sepr/break")
(GO FINISH))
(SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET))
(* ; "NOTE: This should really be (\CHECKEOLC (\NSIN --) --), but eol is usually a break or sepr and the \BACKNSCHAR doesn't work right. Fix this when we unread correctly")
(SETQ SNX (\SYNCODE SA CH))
[COND
((AND ESCAPE-ALLOWED-P (SELECTC SNX
(ESCAPE.RC (SETQ CH (\CHECKEOLC (\NSIN STREAM
SHIFTEDCHARSET
SHIFTEDCHARSET)
(ffetch EOLCONVENTION
of STREAM)
STREAM))
(SETQ ESCAPE-APPEARED T))
(MULTIPLE-ESCAPE.RC
(SETQ ESCAPING (NOT ESCAPING))
(SETQ ESCAPE-APPEARED T)
(GO LP))
NIL)))
(ESCAPING (* ; "eat chars until next |"))
((fetch STOPATOM of SNX)
(\BACKNSCHAR STREAM SHIFTEDCHARSET)
(GO FINISH))
((AND CASEBASE (ILEQ CH \MAXTHINCHAR))
(SETQ CH (\GETBASEBYTE CASEBASE CH]
(COND
((EQ J \PNAMELIMIT) (* ;
"Filled PNSTR so have to save those chars away and start filling up a new buffer")
(SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN)
0 \PNAMESTRING J))
[COND
[ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL]
(T (SETQ ANSTAIL (SETQ ANSLIST (CONS J NIL]
(SETQ J 0)))
(\PNAMESTRINGPUTCHAR PBASE J CH)
(COND
((AND (NOT FATSEEN)
(IGREATERP CH \MAXTHINCHAR))
(SETQ FATSEEN T)))
(SETQ J (ADD1 J))
(GO LP)
FINISH
(SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN)
0 \PNAMESTRING J))
[COND
(ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL)))
(SETQ J (CONCATLIST ANSLIST]
(RETURN (if ESCAPE-APPEARED
then (* ;
"do it this way because multiple values are slow")
(VALUES J T)
else J])
(\RSTRING2
[LAMBDA (STREAM SA RSFLG PNSTR) (* bvm: "26-Sep-86 12:44")
(* ;;; "The main string reader. Reads characters from STREAM according to the syntax table SA and returns a string. PNSTR is an instance of the global resource \PNAMESTRING, which we can use all to ourselves as a buffer.")
(* ;;; "If RSFLG is T then the call is from RSTRING, in which case the string is terminated by a break or sepr in SA. If RSFLG is NIL then the string is terminated by a string delimiter. If RSFLG is SKIP then CR's and the following separator chars are discarded as an otherwise normal string is read")
(DECLARE (USEDFREE *READTABLE*))
(PROG ((EOLC (ffetch EOLCONVENTION of STREAM))
(PBASE (SELECTQ (SYSTEMTYPE)
(VAX PNSTR)
(ffetch (STRINGP XBASE) of PNSTR)))
(SHIFTEDCHARSET (UNFOLD (ffetch CHARSET of STREAM)
256))
(J 0)
CH SNX ANSLIST ANSTAIL FATSEEN SKIPPING)
RS2LP
(SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET))
(* ;; "NOTE: This should really be (\CHECKEOLC (\NSIN --) --), but eol is usually a break or sepr and the \BACKNSCHAR doesn't work right. Fix this when we unread correctly")
(SETQ SNX (\SYNCODE SA CH))
(SELECTC SNX
(OTHER.RC (* "Normal case, nothing to do"))
(ESCAPE.RC [COND
((fetch ESCAPEFLG of *READTABLE*)
(SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)
EOLC STREAM))
(COND
((AND (EQ RSFLG (QUOTE SKIP))
(EQ CH (CHARCODE CR))) (*
"Strip leading spaces after escaped returns, too, but leave the CR in the string")
(SETQ SKIPPING 0)
(GO PUTCHAR])
(SELECTQ RSFLG
(NIL (* "end check is dbl quote")
(COND
((EQ SNX STRINGDELIM.RC)
(GO FINISH))))
(T (*
"if called from RSTRING, end check is break or sepr, and we must leave delim in stream")
(COND
((fetch STOPATOM of SNX)
(\BACKNSCHAR STREAM SHIFTEDCHARSET)
(GO FINISH))))
(SKIP (*
"Like NIL but strip cr's and leading spaces")
(SELECTC SNX
(STRINGDELIM.RC
(GO FINISH))
(SEPRCHAR.RC (* "Assume that CR is a sepr")
(COND
[SKIPPING (COND
((EQ CH (CHARCODE EOL))
(*
"Multiple CR's while skipping are kept")
(COND
((EQ SKIPPING T)
(*
"Turn previous space back into CR. Note that J is guaranteed to be at least 1")
(\PNAMESTRINGPUTCHAR PBASE (SUB1 J)
CH)
(SETQ SKIPPING 0)))
(GO PUTCHAR))
(T (* "Continue skipping seprs")
(GO RS2LP]
((EQ CH (CHARCODE EOL))
(*
"Turn CR into space and start skipping seprs")
(SETQ SKIPPING T)
(SETQ CH (CHARCODE SPACE))
(GO PUTCHAR))))
NIL))
(SHOULDNT)))
(SETQ SKIPPING NIL)
PUTCHAR
(COND
((EQ J \PNAMELIMIT) (*
"Filled PNSTR so have to save those chars away and start filling up a new buffer")
(SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN)
0 PNSTR J))
[COND
[ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL]
(T (SETQ ANSTAIL (SETQ ANSLIST (CONS J NIL]
(SETQ J 0)))
(\PNAMESTRINGPUTCHAR PBASE J CH)
(COND
((AND (NOT FATSEEN)
(IGREATERP CH \MAXTHINCHAR))
(SETQ FATSEEN T)))
(SETQ J (ADD1 J))
(if (OR (NEQ RSFLG T)
(NOT (\EOFP STREAM)))
then (* ; "in RSTRING (RSFLG=T), if we've read something already, then end of file terminates string just like a sepr/break")
(GO RS2LP))
FINISH
(SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN)
0 PNSTR J))
(RETURN (COND
(ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL)))
(CONCATLIST ANSLIST))
(T J])
)
(* ; "Core of the reader")
(DEFINEQ
(\SUBREAD
[LAMBDA (STREAM SA READTYPE PNSTR CASEBASE) (* bvm: "13-Oct-86 23:18")
(* ;; "Values of READTYPE are: --- READ.RT for top level of READ, --- NOPROPRB.RT if right-bracket isn't to be propagated -- sublist beginning with left-bracket --- PROPRB.RT if propagation is not suppressed -- sublist beginning with left-paren --- RATOM.RT for call from RATOM --- PNSTR is an instance of the global resource \PNAMESTRING, acquired in READ and passed on from level to level. It is released during read-macro applications, then reacquired.--- \RBFLG is propagated for top-level calls, in case they are embedded in read-macros. ")
(DECLARE (USEDFREE *READTABLE* \RBFLG)) (* ;; "\RDCONC is a macro that adds a new element as specified by its first argument to the current sublist. Its other arguments will be executed instead if we are the top-level call")
(PROG ((TOPLEVELP (SELECTC READTYPE
((LIST READ.RT RATOM.RT)
T)
NIL))
(SHIFTEDCHARSET (UNFOLD (ffetch (STREAM CHARSET) of STREAM)
256))
(PBASE (SELECTQ (SYSTEMTYPE)
(VAX PNSTR)
(ffetch (STRINGP XBASE) of PNSTR)))
SNX LST END ELT DOTLOC CH J ESCAPEFLG INVALIDFLG PACKAGE NCOLONS)
NEWTOKEN
(* ;;
"Here ready to scan a new token. First skip over separator characters")
(SETQ J 0)
[SETQ INVALIDFLG (SETQ ESCAPEFLG (SETQ PACKAGE (SETQ NCOLONS NIL]
(repeatwhile (EQ [SETQ SNX (\SYNCODE SA (SETQ CH (\NSIN STREAM SHIFTEDCHARSET
SHIFTEDCHARSET]
SEPRCHAR.RC))
(COND
((EQ SNX OTHER.RC) (* ; "Start of an atom")
(COND
([AND (EQ CH (CHARCODE %.))
(fetch STOPATOM of (\SYNCODE SA (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET]
(* ;; "An isolated, unescaped dot. This special check on every atom could be eliminated if . had a special SNX code")
(SETQ DOTLOC END) (* ;
"DOTLOC points to CONS cell one before the dot, NIL for car of list, as desired.")
))
(GO GOTATOMCHAR))
[(fetch STOPATOM of SNX) (* ;
"This character definitely does not start an atom")
(COND
((EQ READTYPE RATOM.RT)
(GO SINGLECHARATOM))
(T (GO BREAK]
((EQ SNX PACKAGEDELIM.RC) (* ;
"Starting a symbol with a package delimiter -- must be a keyword")
(SETQ NCOLONS 1)
(SETQ PACKAGE *KEYWORD-PACKAGE*)
(SETQ ESCAPEFLG T)
(GO NEXTATOMCHAR))
[(AND (SELECTC (fetch MACROCONTEXT of SNX)
(FIRST.RMC T)
(ALONE.RMC (fetch STOPATOM of (\SYNCODE SA (\NSPEEK STREAM SHIFTEDCHARSET
SHIFTEDCHARSET))))
NIL)
(fetch READMACROFLG of *READTABLE*))
(COND
((EQ READTYPE RATOM.RT)
(GO SINGLECHARATOM))
(T (GO MACRO]
(T (* ;
"Some character that starts an atom but has non-trivial syntax attributes")
))
ATOMLOOP
(* ;; "At this point, we are accumulating an atom, and CH does not have syntax OTHER, so we have to check special cases")
(SELECTC SNX
(ESCAPE.RC (* ;
"Take next character to be alphabetic, case exact")
(COND
((fetch ESCAPEFLG of *READTABLE*)
(SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)
(ffetch EOLCONVENTION of STREAM)
STREAM))
(* ;
"No EOFP check needed -- it's an error to have escape char with nothing following")
(SETQ ESCAPEFLG T)
(GO PUTATOMCHAR))))
(MULTIPLE-ESCAPE.RC (* ;; "Take characters up to next multiple escape to be alphabetic, except that single escape chars still escape the next char")
(SETQ ESCAPEFLG T)
[bind ESCFLG do (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)
(ffetch EOLCONVENTION of STREAM)
STREAM))
(COND
([NOT (COND
(ESCFLG (SETQ ESCFLG NIL))
(T (SELECTC (SETQ SNX (\SYNCODE SA CH))
(MULTIPLE-ESCAPE.RC
(* ;
"Finished escaped sequence, resume normal processing")
(GO NEXTATOMCHAR))
(ESCAPE.RC
(* ; "Pass the next char thru verbatim")
(SETQ ESCFLG T))
NIL](* ; "All others are pname chars, quoted")
(COND
((EQ J \PNAMELIMIT)
(LISPERROR "ATOM TOO LONG" NIL)))
(\PNAMESTRINGPUTCHAR PBASE J CH)
(add J 1])
NIL)
GOTATOMCHAR
(* ;; "CH is a vanilla atom char to accumulate")
[COND
((AND CASEBASE (ILEQ CH \MAXTHINCHAR)) (* ; "Uppercase atom characters")
(SETQ CH (\GETBASEBYTE CASEBASE CH]
PUTATOMCHAR
(COND
((EQ J \PNAMELIMIT)
(LISPERROR "ATOM TOO LONG" NIL)))
(\PNAMESTRINGPUTCHAR PBASE J CH)
(add J 1)
NEXTATOMCHAR
[COND
((AND TOPLEVELP (NOT (\INTERMP STREAM))
(\EOFP STREAM)) (* ; "EOF terminates atoms at top level")
(if INVALIDFLG
then (\INVALID.SYMBOL PBASE 0 J NCOLONS PACKAGE))
(RETURN (\READ.SYMBOL PBASE 0 J \FATPNAMESTRINGP PACKAGE (EQ NCOLONS 1)
ESCAPEFLG]
(COND
((EQ [SETQ SNX (\SYNCODE SA (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET]
OTHER.RC)
(GO GOTATOMCHAR))
[(fetch STOPATOM of SNX) (* ; "Terminates atom")
(if INVALIDFLG
then (\INVALID.SYMBOL PBASE 0 J NCOLONS PACKAGE))
(SETQ ELT (\READ.SYMBOL PBASE 0 J \FATPNAMESTRINGP PACKAGE (EQ NCOLONS 1)
ESCAPEFLG))
(\RDCONC ELT (PROGN (* ;
"At top-level, put back the terminating character")
(\BACKNSCHAR STREAM SHIFTEDCHARSET)
(RETURN ELT)))
(COND
((EQ SNX SEPRCHAR.RC) (* ; "Terminated with sepr, go on to next char")
(GO NEWTOKEN))
(T (* ;
"Terminated with break, jump into the break char code")
(GO BREAK]
((NEQ SNX PACKAGEDELIM.RC)
(GO ATOMLOOP)))
GOTPACKAGEDELIM
(* ;; "Come here if CH is a package delimiter. Note that we have already scanned at least one character of the token, so this must be an interior delim")
(COND
[(EQ J 0) (* ;; "No chars accumulated, so must be 2 colons in a row. Note that the case where we've just started scanning a token happens up at NEWTOKEN")
(COND
((AND (EQ NCOLONS 1)
(NEQ PACKAGE *KEYWORD-PACKAGE*))
(* ; "Two colons in a row means internal symbol")
(SETQ NCOLONS 2))
(T (* ; "Error, e.g., `FOO:::BAZ' or `::BAR'")
(SETQ INVALIDFLG T)
(GO GOTATOMCHAR]
((NULL NCOLONS) (* ; "We have just scanned the package name")
(SETQ NCOLONS 1)
[SETQ PACKAGE (COND
((\FIND.PACKAGE.INTERNAL PBASE 0 J \FATPNAMESTRINGP))
(T (* ;
"Error, but don't signal yet -- save name as string for benefit of error handlers")
(\GETBASESTRING PBASE 0 J \FATPNAMESTRINGP]
(SETQ J 0))
(T (* ;
"Have alread seen one or more colons, and have scanned more symbol. This colon is an error.")
(SETQ INVALIDFLG T)
(GO GOTATOMCHAR)))
(SETQ ESCAPEFLG T) (* ; "Result MUST be a symbol now")
(GO NEXTATOMCHAR)
SINGLECHARATOM
(* ;;
"Come here to create a symbol whose single character is CH -- no package stuff to worry about")
(\PNAMESTRINGPUTCHAR PBASE 0 CH)
(SETQ ELT (\READ.SYMBOL PBASE 0 1 \FATPNAMESTRINGP))
(\RDCONC ELT (RETURN ELT))
(GO NEWTOKEN) (* ;; "End of atom scanning code")
BREAK
(* ;;
"At this point, we have just read a break character, stored in CH")
[SELECTC SNX
(LEFTPAREN.RC (COND
((PROG1 (PROPRB (SETQ ELT (\SUBREAD STREAM SA PROPRB.RT PNSTR CASEBASE
)))
(\RDCONC ELT (RETURN ELT)))
(* ;; "PROG1 is true if the subread encountered a right bracket, in which case we must return, propagating \RBFLG to our caller")
(FIXDOT)
(RETURN LST))))
(LEFTBRACKET.RC
(SETQ ELT (\SUBREAD STREAM SA NOPROPRB.RT PNSTR CASEBASE))
(\RDCONC ELT (RETURN ELT)))
((LIST RIGHTPAREN.RC RIGHTBRACKET.RC)
(RETURN (COND
(TOPLEVELP (* ; "Naked right paren/bracket returns NIL")
NIL)
(T (FIXDOT)
(AND (EQ SNX RIGHTBRACKET.RC)
(NEQ READTYPE NOPROPRB.RT)
(SETQ \RBFLG T))
LST))))
(STRINGDELIM.RC
(SETQ ELT (\RSTRING2 STREAM SA NIL PNSTR))
(\RDCONC ELT (RETURN ELT)))
(COND
((OR (EQ SNX BREAKCHAR.RC)
(NOT (fetch READMACROFLG of *READTABLE*)))
(* ; "A breakchar or a disabled always macro")
(GO SINGLECHARATOM))
(T (GO MACRO]
(GO NEWTOKEN)
MACRO
(SELECTQ (fetch MACROTYPE of (SETQ SNX (\GETREADMACRODEF CH *READTABLE*)))
(MACRO (COND
([PROPRB [SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR
(MULTIPLE-VALUE-LIST (\APPLYREADMACRO STREAM SNX]
(* ;
"Ignore right-bracket if macro is called at top-level read")
(COND
((NULL ELT) (* ; "Macro returned zero values, read as nothing")
)
(T (SETQ ELT (CAR ELT))
(\RDCONC ELT (COND
(\RBFLG
(* ;
"Back over right-bracket and return instead of setting free \RBFLG")
(\BACKNSCHAR STREAM SHIFTEDCHARSET)))
(RETURN ELT]
(* ;
"Encountered right bracket if we get here -- return what we have")
(FIXDOT)
(RETURN LST))))
(INFIX [COND
[TOPLEVELP [RBCONTEXT (SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR
(\APPLYREADMACRO STREAM SNX]
(* ;
"not reading a sublist, so don't need to handle rb")
(COND
((AND (LISTP ELT)
(CDR ELT))
(RETURN (COND
((EQ (CDR ELT)
(CAR ELT))
(CAAR ELT))
(T (CAR ELT]
(T (* ; "Reading sublist")
[COND
([PROPRB (SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR
(\APPLYREADMACRO STREAM SNX (CONS LST END]
(FIXDOT)
(RETURN (CAR ELT]
(SETQ LST (CAR ELT))
(SETQ END (CDR ELT])
(SPLICE [RBCONTEXT (SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR (\APPLYREADMACRO
STREAM SNX]
(* ;
"Note: we don't care if there was terminating right-bracket")
(COND
((OR (NULL ELT)
TOPLEVELP) (* ;; "On the 10, it actually returns ELT if it is a list and the next token is a closing paren or bracket. Hard to see how to get that behavior--rmk")
(GO NEWTOKEN))
((NLISTP ELT) (* ;
"The 10 throws initial non-lists away (What if LST/END aren't set?)")
(SETQ ELT (AND LST (LIST (QUOTE %.)
ELT)))
(SETQ DOTLOC END)))
(COND
(LST (RPLACD END ELT))
(T (SETQ LST ELT)))
(SETQ END (LAST ELT))
[COND
((CDR END) (* ; "A dotted pair")
(SETQ DOTLOC END)
(RPLACD END (CONS (QUOTE %.)
(SETQ END (CONS (CDR END])
(SHOULDNT))
(GO NEWTOKEN])
(\READ.SYMBOL
[LAMBDA (BASE OFFSET LEN FATP PACKAGE EXTERNALP NONNUMERICP)
(* bvm: " 3-Aug-86 15:25")
(* * "Read a number or symbol from the string defined by BASE OFFSET LEN FATP
PACKAGE is NIL if no package was specified, a package object or a string if an unknown package was typed (causes error). EXTERNALP is true if symbol was typed with one colon, which requires that the symbol exist and be external. NONNUMERICP is true if we know the symbol is not a number, e.g., some characters in it were escaped.")
(* * "For now a dummy definition")
(COND
(PACKAGE (* "For debugging")
(CONCAT PACKAGE (COND
(EXTERNALP ":")
(T "::"))
(\GETBASESTRING BASE OFFSET LEN FATP)))
(T (OR (AND (NOT NONNUMERICP)
(\PARSE.NUMBER BASE OFFSET LEN FATP))
(\MKATOM BASE OFFSET LEN FATP T])
(\INVALID.SYMBOL
[LAMBDA (BASE OFFSET LEN NCOLONS PACKAGE) (* bvm: "13-Oct-86 16:50")
(* ;;; "Called when scanning a symbol that has more than 2 colons, or more than 1 non-consecutive colon. If return from here, will read the symbol as though the extra colons were escaped.")
(CERROR "Treat the extra colon(s) as if they were escaped" "Invalid symbol syntax in %"~A%""
(CONCAT (if (AND PACKAGE (NEQ PACKAGE *KEYWORD-PACKAGE*))
then (PACKAGE-NAME PACKAGE)
else "")
(SELECTQ NCOLONS
(1 ":")
(2 "::")
"")
(\GETBASESTRING BASE OFFSET LEN \FATPNAMESTRINGP])
(\APPLYREADMACRO
[LAMBDA (STREAM MACDEF ANSCELL) (* bvm: " 4-May-86 16:38")
(* INREADMACROP searches for this
framename)
(DECLARE (USEDFREE *READTABLE*))
(APPLY* (fetch MACROFN of MACDEF)
STREAM *READTABLE* ANSCELL])
(INREADMACROP
[LAMBDA NIL (* edited: "26-MAY-79 00:12")
(PROG (TEM (\READDEPTH -1))
(DECLARE (SPECVARS \READDEPTH))
(COND
([NULL (SETQ TEM (STKPOS (QUOTE \APPLYREADMACRO]
(RETURN NIL)))
(MAPDL [FUNCTION (LAMBDA (NM POS)
(COND
((EQ NM (QUOTE \SUBREAD))
(SETQ \READDEPTH (ADD1 \READDEPTH]
TEM)
(RELSTK TEM)
(RETURN \READDEPTH])
)
(* ; "Read macro for '")
(DEFINEQ
(READQUOTE
[LAMBDA (FILE) (* bvm: "12-Sep-86 21:04")
(LIST (QUOTE QUOTE)
(READ FILE])
)
(* ; "# macro")
(DEFINEQ
(READVBAR
[LAMBDA (STREAM RDTBL) (* bvm: "14-May-86 17:31")
(* * Read Interlisp's %| macro. Originally this char was just a sepr in
FILERDTBL but was then extended in various hokey ways, because it was the only
character plausibly available for redefinition.
Today it is extended still further to be Common Lisp # in all the cases not
already taken by some other meaning)
(SELCHARQ (PEEKCCODE STREAM)
(' (* commonlisp defines "#'X" to mean
(FUNCTION X), but here its BQUOTE)
(READCCODE STREAM)
(READBQUOTE STREAM RDTBL))
((%( { ↑) (* Used by HPRINT)
(HREAD STREAM))
(# (READCCODE STREAM) (* "|#" = Common Lisp #)
(READHASHMACRO STREAM RDTBL))
((EOL TAB SPACE) (* CR or tab, treat as separator)
(VALUES))
(PROGN (* Everything else not already
preempted by old-style %| is
interpreted as Common Lisp)
(READHASHMACRO STREAM RDTBL])
(READHASHMACRO
[LAMBDA (STREAM RDTBL INDEX) (* jrb: "19-Sep-86 14:50")
(* * Implements the standard # macro dispatch --
reads next character to find out what to do.
Can return zero values if we just want to skip something)
(LET ([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)
(FUNCTION CL:READ))
(T (FUNCTION READ]
NEXTCHAR READVAL)
[while (DIGITCHARP (SETQ NEXTCHAR (PEEKCCODE STREAM RDTBL)))
do (SETQ INDEX (PLUS (TIMES (OR INDEX 0)
10)
(DIFFERENCE (READCCODE STREAM RDTBL)
(CHARCODE 0]
(SELCHARQ NEXTCHAR
("(" [LET ((CONTENTS (APPLY* READFN STREAM)))
(COND
(INDEX (FILL-VECTOR (MAKE-ARRAY INDEX)
CONTENTS))
(T (MAKE-ARRAY (LENGTH CONTENTS)
:INITIAL-CONTENTS CONTENTS])
(PROGN (* Those cases we left the dispatching
char in buffer for convenience of the
next read. Now eat it)
(SELCHARQ (READCCODE STREAM RDTBL)
(' (LIST (QUOTE FUNCTION)
(READ STREAM RDTBL)))
(%. (EVAL (APPLY* READFN STREAM)))
(, (LIST (QUOTE LOADTIMECONSTANT)
(READ STREAM RDTBL)))
(\ (CHARACTER.READ STREAM))
("*" (* Read bit vector)
[LET [(CONTENTS (while (MEMQ (PEEKCCODE STREAM RDTBL)
(CHARCODE (0 1)))
collect (IDIFFERENCE (READCCODE STREAM RDTBL)
(CHARCODE 0]
(COND
(INDEX (FILL-VECTOR (MAKE-ARRAY INDEX :ELEMENT-TYPE
(QUOTE BIT))
CONTENTS))
(T (MAKE-ARRAY (LENGTH CONTENTS)
:INITIAL-CONTENTS CONTENTS :ELEMENT-TYPE
(QUOTE BIT])
(":" (* Uninterned symbol.
This definition is very wrong)
(RSTRING STREAM RDTBL))
((O o)
(READNUMBERINBASE STREAM 8))
((B b)
(READNUMBERINBASE STREAM 2))
((X x)
(READNUMBERINBASE STREAM 16))
((R r)
(READNUMBERINBASE STREAM INDEX))
((A a)
(LET ((CONTENTS (APPLY* READFN STREAM)))
(MAKE-ARRAY (ESTIMATE-DIMENSIONALITY INDEX CONTENTS)
:INITIAL-CONTENTS CONTENTS)))
((S s)
(CREATE-STRUCTURE (APPLY* READFN STREAM)))
((C c)
(DESTRUCTURING-BIND (NUM DEN)
(APPLY* READFN STREAM)
(COMPLEX NUM DEN)))
(+ (* Skip expression if feature not
present)
(COND
((NOT (CMLREAD.FEATURE.PARSER (READ STREAM RDTBL)))
(CL:READ STREAM RDTBL)))
(VALUES))
(- (* Skip expression if feature IS
present)
(COND
((CMLREAD.FEATURE.PARSER (READ STREAM RDTBL))
(CL:READ STREAM RDTBL)))
(VALUES))
("|" (* special comment)
(SKIP.HASH.COMMENT STREAM RDTBL)
(VALUES))
(< (ERROR "#< construct is un-READ-able" (READ)))
((SPACE TAB NEWLINE PAGE RETURN %))
(ERROR "Illegal read syntax " (CHARCODE.UNDECODE NEXTCHAR)))
(%" (* An extension -- read string without
cr's and leading spaces)
(RSTRING STREAM RDTBL (QUOTE SKIP)))
(APPLY* (OR (GET (CHARACTER NEXTCHAR)
(QUOTE HASHREADMACRO))
(ERROR "Undefined hashmacro char" NEXTCHAR))
STREAM RDTBL])
(DEFMACRO-LAMBDA-LIST-KEYWORD-P
[LAMBDA (S) (* raf " 2-Jan-86 17:35")
(MEMBER S (QUOTE (&OPTIONAL &REST &KEY &ALLOW-OTHER-KEYS &AUX &BODY &WHOLE])
(DIGITBASEP
[LAMBDA (CODE RADIX) (* lmm "11-Jun-85 00:54")
(COND
((AND (GEQ CODE (CHARCODE 0))
(LESSP CODE (PLUS (CHARCODE 0)
RADIX)))
(DIFFERENCE CODE (CHARCODE 0)))
((GREATERP RADIX 10)
[COND
((AND (GEQ CODE (CHARCODE a))
(LEQ CODE (CHARCODE z)))
(add CODE (DIFFERENCE (CHARCODE A)
(CHARCODE a]
(COND
((AND (GEQ CODE (CHARCODE A))
(LEQ CODE (CHARCODE Z)))
[SETQ CODE (PLUS 10 (DIFFERENCE CODE (CHARCODE A]
(COND
((LESSP CODE RADIX)
CODE])
(READNUMBERINBASE
[LAMBDA (STREAM RADIX) (* bvm: " 2-Oct-86 17:18")
(PROG ((BODY (READ-EXTENDED-TOKEN STREAM))
(I 1)
CH VAL NUMERATOR SIGN BASE) (* ; "First check for leading sign")
(SELCHARQ (SETQ CH (NTHCHARCODE BODY 1))
(+ (GO NEXTCH))
(- (SETQ SIGN T)
(GO NEXTCH))
NIL)
LP (if (SETQ BASE (DIGITBASEP CH RADIX))
then (SETQ VAL (+ (TIMES (OR VAL 0)
RADIX)
BASE))
elseif (EQ CH (CHARCODE "/"))
then (* ; "Ratio marker")
(if (OR NUMERATOR (NULL VAL))
then (GO MALFORMED))
(SETQ NUMERATOR VAL)
(SETQ VAL NIL)
else (* ;
"Terminated by a character that is not a token delimiter")
(GO MALFORMED))
NEXTCH
(if (SETQ CH (NTHCHARCODE BODY (add I 1)))
then (GO LP)
else (* ; "end of token, fall thru"))
DONE
(if (NULL VAL)
then (GO MALFORMED))
(if NUMERATOR
then (SETQ VAL (%%/ NUMERATOR VAL)))
(RETURN (if SIGN
then (- VAL)
else VAL))
MALFORMED
(RETURN (CL:ERROR "Malformed base ~D rational ~S" RADIX BODY])
(ESTIMATE-DIMENSIONALITY
[LAMBDA (RANK CONTENTS) (* bvm: " 9-May-86 16:06")
(COND
((NULL RANK)
(ERROR "No rank found while reading array" NIL))
((EQ RANK 0)
NIL)
(T (to RANK as (D ← CONTENTS) by (CAR D) collect (LENGTH D])
(SKIP.HASH.COMMENT
[LAMBDA (STREAM RDTBL) (* bvm: "12-Sep-86 21:02")
(PROG NIL (* ;;
"a tiny fsm that recognizes #| ... |# with possible nestings of itself")
LP (SELCHARQ (READCCODE STREAM RDTBL)
("#" (GO SHARP))
("|" (GO VBAR))
(GO LP))
SHARP
(SELCHARQ (READCCODE STREAM RDTBL)
("|" (* ; "#| -- recursively skip nested section")
(SKIP.HASH.COMMENT STREAM RDTBL)
(GO LP))
("#" (GO SHARP))
(GO LP))
VBAR
(SELCHARQ (READCCODE STREAM RDTBL)
("|" (GO VBAR))
("#" (* ; "found closing |#")
(RETURN))
(GO LP])
(CMLREAD.FEATURE.PARSER
[LAMBDA (EXPR) (* bvm: "14-May-86 17:43")
(COND
((CONSP EXPR)
(CASE (CAR EXPR)
(AND (EVERY (CDR EXPR)
(FUNCTION CMLREAD.FEATURE.PARSER)))
(OR (SOME (CDR EXPR)
(FUNCTION CMLREAD.FEATURE.PARSER)))
[NOT (NOT (CMLREAD.FEATURE.PARSER (CADR EXPR]
(ERROR "Bad feature expression" EXPR)))
((FMEMB EXPR *FEATURES*)
T])
(CREATE-STRUCTURE
[CL:LAMBDA (STRUCTURE-FORM) (* lmm "16-Apr-86 12:56")
(APPLY (PACK* (QUOTE MAKE-)
(U-CASE (CAR STRUCTURE-FORM)))
(for TAIL on (CDR STRUCTURE-FORM) by (CDDR TAIL)
join (LIST (MAKE-KEYWORD (CAR TAIL))
(CADR TAIL])
)
(DECLARE: DONTCOPY
(RPAQQ READTYPES (READ.RT RATOM.RT NOPROPRB.RT PROPRB.RT))
(DECLARE: EVAL@COMPILE
(RPAQQ READ.RT NIL)
(RPAQQ RATOM.RT 1)
(RPAQQ NOPROPRB.RT T)
(RPAQQ PROPRB.RT 0)
(CONSTANTS READ.RT RATOM.RT NOPROPRB.RT PROPRB.RT)
)
(DECLARE: EVAL@COMPILE
[PUTPROPS FIXDOT MACRO (NIL (PROGN (* ; "Fix a non-first dot followed by a singleton")
(AND DOTLOC (CDDR DOTLOC)
(NULL (CDDDR DOTLOC))
(RPLACD DOTLOC (CADDR DOTLOC]
(PUTPROPS RBCONTEXT MACRO ((X . Y)
([LAMBDA (\RBFLG)
(DECLARE (SPECVARS \RBFLG))
(PROGN X . Y)
\RBFLG]
NIL)))
[PUTPROPS PROPRB MACRO ((X . Y)
(* ; "Propagates the right-bracket flag")
(AND (RBCONTEXT X . Y)
(OR (EQ READTYPE NOPROPRB.RT)
(SETQ \RBFLG T]
[PUTPROPS \RDCONC MACRO ((ELT . TOPFORMS)
(* ;; "Add ELT to the accumulating list to be returned by \SUBREAD. If at top level and no list accumulated, then run TOPFORMS"
)
(COND [LST (RPLACD END (SETQ END (CONS ELT]
(TOPLEVELP . TOPFORMS)
(T (SETQ END (SETQ LST (CONS ELT]
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
[PUTPROPS \BACKCHAR MACRO (OPENLAMBDA (STREAM)
(* ; "Backs up over an NS character")
(\BACKNSCHAR STREAM (UNFOLD (ffetch CHARSET of STREAM)
256]
[PUTPROPS \BACKNSCHAR MACRO ((STREAM SHIFTEDCHARSET COUNTERVAR)
(AND (\BACKFILEPTR STREAM)
(COND [[COND (SHIFTEDCHARSET (EQ SHIFTEDCHARSET (UNFOLD \NORUNCODE
256)))
(T (EQ \NORUNCODE (ffetch CHARSET of STREAM]
(COND ((\BACKFILEPTR STREAM)
(AND (QUOTE COUNTERVAR)
(add COUNTERVAR 2))
T)
((QUOTE COUNTERVAR)
(add COUNTERVAR 1]
((QUOTE COUNTERVAR)
(add COUNTERVAR 1]
(PUTPROPS \CHECKEOLC MACRO
(OPENLAMBDA (CH EOLC STREAM PEEKBINFLG COUNTERVAR)
(* ;; "Subtracts number of bytes read from COUNTERVAR, which may be NIL. In fact, should be NIL if PEEKBINFLG is T."
)
(SELCHARQ CH
(CR (SELECTC EOLC (CR.EOLC (CHARCODE EOL))
[CRLF.EOLC (COND [PEEKBINFLG
(* ;; "T from PEEKC, compile-time constant. In this case, must leave the fileptr where it was, except for possibly advancing over character set shifts"
)
(COND ([EQ (CHARCODE LF)
(UNINTERRUPTABLY
(\NSIN STREAM
(UNFOLD (ffetch CHARSET
of STREAM)
256))
(* ;; "Read the NS CR. We know that there aren't any font-shift characters in front of the CR, because they would have already been read by the \NSPEEK that got the CR character. Since we are going to NS back the CR character, we don't need to update the counter variable")
(PROG1 (\PEEKBIN STREAM T)
(* ;; "LF must be in next BYTE after NS CR, regardless of coding. Character-set shifting bytes can't intervene. Then we back up over the CR that was \NSINed above.")
(\BACKNSCHAR STREAM)))]
(CHARCODE EOL))
(T (CHARCODE CR]
((EQ (CHARCODE LF)
(\PEEKBIN STREAM T))
(\BIN STREAM)
(AND (QUOTE COUNTERVAR)
(SETQ COUNTERVAR (SUB1 COUNTERVAR)))
(CHARCODE EOL))
(T (CHARCODE CR]
(CHARCODE CR)))
[LF (COND ((EQ EOLC LF.EOLC)
(CHARCODE EOL))
(T (CHARCODE LF]
CH)))
(PUTPROPS \INCHAR MACRO (OPENLAMBDA (STREAM COUNTERVAR)
(* ; "returns a 16 bit character code")
(\CHECKEOLC (\NSIN STREAM (UNFOLD (ffetch CHARSET of STREAM)
256)
NIL COUNTERVAR)
(ffetch EOLCONVENTION of STREAM)
STREAM NIL COUNTERVAR)))
(PUTPROPS \INCCODE MACRO (OPENLAMBDA (STREAM COUNTERVAR)
(* ; "returns a 16 bit character code")
(\CHECKEOLC (\NSIN STREAM (UNFOLD (ffetch CHARSET of STREAM)
256)
NIL COUNTERVAR)
(ffetch EOLCONVENTION of STREAM)
STREAM NIL COUNTERVAR)))
(PUTPROPS \PEEKCCODE MACRO (OPENLAMBDA (STREAM NOERROR)
(\CHECKEOLC (\NSPEEK STREAM (UNFOLD (ffetch CHARSET of STREAM)
256)
NIL NOERROR)
(ffetch EOLCONVENTION of STREAM)
STREAM T)))
[PUTPROPS \NSIN MACRO ((STREAM SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR)
(* ;;; "returns a 16 bit character code. SHIFTEDCSET is STREAM's char set left shifted 8, SHIFTEDCSETVAR if non-NIL is the variable to set if char set changes. COUNTERVAR if non-NIL is decremented by number of bytes read. Doesn't do EOL conversion -- \INCHAR does that."
)
(LET ((CHAR (\BIN STREAM))
SCSET)
(COND [(EQ CHAR NSCHARSETSHIFT)
(* ; "Shifting character sets")
[freplace CHARSET of STREAM with
(SETQ SCSET (COND ((NEQ NSCHARSETSHIFT (SETQ CHAR
(\BIN STREAM))
)
(AND (QUOTE COUNTERVAR)
(SETQ COUNTERVAR (IDIFFERENCE
COUNTERVAR 2)))
CHAR)
((PROGN (* ;
"2 shift-bytes means not run-encoded"
)
(AND (QUOTE COUNTERVAR)
(SETQ COUNTERVAR
(IDIFFERENCE
COUNTERVAR 3)))
(EQ 0 (\BIN STREAM)))
\NORUNCODE)
(T (\NSIN.24BITENCODING.ERROR STREAM]
(SETQ CHAR (\BIN STREAM))
(SETQ SCSET (COND ((QUOTE SHIFTEDCSETVAR)
(* ; "CHARSETVAR=NIL means don't set")
(SETQ SHIFTEDCSETVAR (UNFOLD SCSET 256)))
(T (UNFOLD SCSET 256]
(T (SETQ SCSET SHIFTEDCSET)))
(COND ((EQ SCSET (UNFOLD \NORUNCODE 256))
(* ; "just read two bytes and combine them to a 16 bit value")
(AND (QUOTE COUNTERVAR)
(SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2)))
(LOGOR (UNFOLD CHAR 256)
(\BIN STREAM)))
(CHAR (AND (QUOTE COUNTERVAR)
(SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 1)))
(AND CHAR (LOGOR SCSET CHAR]
[PUTPROPS \NSPEEK MACRO ((STREAM SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR)
(* ;; "returns a 16 bit character code. Doesn't do EOL conversion--\INCHAR does that. May actually read the character-set shift, storing the result in the stream. COUNTERVAR, if given, is updated to reflect any such bytes that are actually read"
)
(PROG ((CHAR (\PEEKBIN STREAM NOERROR))
SCSET)
(COND ((NULL CHAR)
(RETURN NIL))
[(EQ CHAR NSCHARSETSHIFT)
(* ; "CHARSETVAR=NIL means don't set")
(\BIN STREAM)
(* ; "Consume the char shift byte")
[freplace CHARSET of STREAM with
(SETQ SCSET (COND ((NEQ NSCHARSETSHIFT (SETQ
CHAR
(\BIN STREAM)))
(* ;
"Note: no eof error check on this \BIN -- an eof in the middle of a charset shift is an error"
)
(AND (QUOTE COUNTERVAR)
(SETQ COUNTERVAR
(IDIFFERENCE COUNTERVAR 2)
))
CHAR)
((PROGN (* ;
"2 shift-bytes means not run-encoded"
)
(AND (QUOTE COUNTERVAR)
(SETQ COUNTERVAR
(IDIFFERENCE
COUNTERVAR 3
)))
(EQ 0 (\BIN STREAM)))
\NORUNCODE)
(T (\NSIN.24BITENCODING.ERROR STREAM]
[SETQ SCSET (COND ((QUOTE SHIFTEDCSETVAR)
(* ; "CHARSETVAR=NIL means don't set")
(SETQ SHIFTEDCSETVAR (UNFOLD SCSET 256)))
(T (UNFOLD SCSET 256]
(COND ((NULL (SETQ CHAR (\PEEKBIN STREAM NOERROR)))
(RETURN NIL]
(T (SETQ SCSET SHIFTEDCSET)))
(RETURN (COND ((EQ SCSET (UNFOLD \NORUNCODE 256))
(* ;; "just peek two bytes and combine them to a 16 bit value. Again, is an error if we hit eof in mid-character"
)
(\BIN STREAM)
(PROG1 (LOGOR (UNFOLD CHAR 256)
(\PEEKBIN STREAM NOERROR))
(\BACKFILEPTR STREAM)))
(T (LOGOR SHIFTEDCSET CHAR]
)
(* END EXPORTED DEFINITIONS)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS \RefillBufferFn)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*)
)
)
(RPAQ? *SIGNAL-24BIT-NSENCODING-ERROR* )
(RPAQ? \RefillBufferFn (FUNCTION \READCREFILL))
(* ;
"Act like READC if there is no binding of \RefillBufferFn--we must be doing a raw BIN (or PEEKBIN?)"
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(PRETTYCOMPRINT LLREADCOMS)
(RPAQQ LLREADCOMS [(COMS (* ; "Reader entrypoints")
(FNS LASTC PEEKC PEEKCCODE RATOM READ READC READCCODE READP SETREADMACROFLG
SKIPSEPRCODES SKIPSEPRS \NSIN.24BITENCODING.ERROR))
(COMS (* ; "reading strings")
(FNS RSTRING READ-EXTENDED-TOKEN \RSTRING2))
(COMS (* ; "Core of the reader")
(FNS \SUBREAD \READ.SYMBOL \INVALID.SYMBOL \APPLYREADMACRO INREADMACROP))
(COMS (* ; "Read macro for '")
(FNS READQUOTE))
(COMS (* ; "# macro")
(FNS READVBAR READHASHMACRO DEFMACRO-LAMBDA-LIST-KEYWORD-P DIGITBASEP
READNUMBERINBASE ESTIMATE-DIMENSIONALITY SKIP.HASH.COMMENT
CMLREAD.FEATURE.PARSER CREATE-STRUCTURE))
(DECLARE: DONTCOPY (CONSTANTS * READTYPES)
(MACROS FIXDOT RBCONTEXT PROPRB \RDCONC)
(EXPORT (MACROS \BACKCHAR \BACKNSCHAR \CHECKEOLC \INCHAR \INCCODE
\PEEKCCODE \NSIN \NSPEEK))
(SPECVARS \RefillBufferFn)
(GLOBALVARS *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*))
(INITVARS (*SIGNAL-24BIT-NSENCODING-ERROR*)
(\RefillBufferFn (FUNCTION \READCREFILL)))
(* ;
"Act like READC if there is no binding of \RefillBufferFn--we must be doing a raw BIN (or PEEKBIN?)"
)
(LOCALVARS . T)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA
CREATE-STRUCTURE
])
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA CREATE-STRUCTURE)
)
(PUTPROPS LLREAD COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2162 12335 (LASTC 2172 . 4172) (PEEKC 4174 . 4753) (PEEKCCODE 4755 . 5053) (RATOM 5055
. 6072) (READ 6074 . 7039) (READC 7041 . 7359) (READCCODE 7361 . 7828) (READP 7830 . 8437) (
SETREADMACROFLG 8439 . 8845) (SKIPSEPRCODES 8847 . 10148) (SKIPSEPRS 10150 . 11459) (
\NSIN.24BITENCODING.ERROR 11461 . 12333)) (12368 23755 (RSTRING 12378 . 12889) (READ-EXTENDED-TOKEN
12891 . 17487) (\RSTRING2 17489 . 23753)) (23791 44036 (\SUBREAD 23801 . 41108) (\READ.SYMBOL 41110 .
42212) (\INVALID.SYMBOL 42214 . 43029) (\APPLYREADMACRO 43031 . 43450) (INREADMACROP 43452 . 44034)) (
44070 44243 (READQUOTE 44080 . 44241)) (44268 56751 (READVBAR 44278 . 45808) (READHASHMACRO 45810 .
51822) (DEFMACRO-LAMBDA-LIST-KEYWORD-P 51824 . 52035) (DIGITBASEP 52037 . 52771) (READNUMBERINBASE
52773 . 54514) (ESTIMATE-DIMENSIONALITY 54516 . 54844) (SKIP.HASH.COMMENT 54846 . 55823) (
CMLREAD.FEATURE.PARSER 55825 . 56360) (CREATE-STRUCTURE 56362 . 56749)))))
STOP