(FILECREATED "12-Sep-86 14:43:08" {ERIS}<LISPCORE>SOURCES>LLREAD.;20 53942
changes to: (FNS \RSTRING2)
previous date: " 3-Aug-86 15:46:46" {ERIS}<LISPCORE>SOURCES>LLREAD.;19)
(* Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LLREADCOMS)
(RPAQQ LLREADCOMS ((FNS LASTC PEEKC PEEKCCODE RATOM READ READC READCCODE READP SETREADMACROFLG
SKIPSEPRCODES SKIPSEPRS \NSIN.24BITENCODING.ERROR)
(FNS RSTRING \RSTRING2)
(FNS \SUBREAD \READ.SYMBOL \INVALID.SYMBOL \APPLYREADMACRO INREADMACROP)
(DECLARE: DONTCOPY (CONSTANTS * READTYPES)
(MACROS FIXDOT RBCONTEXT PROPRB \RDCONC)
(EXPORT (MACROS \BACKCHAR \BACKNSCHAR \CHECKEOLC \INCHAR \INCCODE
\PEEKCCODE \NSIN \NSPEEK))
(SPECVARS \RefillBufferFn)
(GLOBALVARS *KEYWORD-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)))
(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 FLG) (* rmk: " 5-Apr-85 09:31")
(* 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))
(\PEEKCCODE STREAM])
(RATOM
[LAMBDA (FILE RDTBL) (* bvm: " 2-May-86 13:59")
(* * Like READ except interpret break characters as single character atoms.
I.e., always returns an atom)
(LET ((*READTABLE* (\GTREADTABLE RDTBL))
(\RefillBufferFn (FUNCTION \RATOM/RSTRING-REFILL)))
(DECLARE (SPECVARS *READTABLE* \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: " 2-May-86 14:03")
(DECLARE (SPECVARS FLG)) (* FLG is used freely by \FILLBUFFER)
(LET ((*READTABLE* (\GTREADTABLE RDTBL))
(\RefillBufferFn (FUNCTION \READREFILL)))
(DECLARE (SPECVARS *READTABLE* \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])
)
(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])
(\RSTRING2
[LAMBDA (STREAM SA RSFLG PNSTR) (* bvm: "12-Sep-86 14:39")
(* * "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
(if (AND (EQ RSFLG T)
(\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))
(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))
(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])
)
(DEFINEQ
(\SUBREAD
[LAMBDA (STREAM SA READTYPE PNSTR CASEBASE) (* bvm: "15-May-86 11:38")
(* 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 -
-
The \RBFLG is propagated for top-level calls, in case they are embedded in
read-macros. -
\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 -
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.)
(DECLARE (USEDFREE *READTABLE* \RBFLG))
(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 PACKAGE NCOLONS)
NEWTOKEN
(* * Here ready to scan a new token. First skip over separator characters)
(SETQ J 0)
(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*)
(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)
(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)
(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")
(\INVALID.SYMBOL PBASE 0 J NCOLONS PACKAGE)
(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.)
(\INVALID.SYMBOL PBASE 0 J NCOLONS PACKAGE)
(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: "14-May-86 18:38")
(* * Called when scanning a symbol that has more than 2 colons, or more than 1
non-consecutive colon. If return from here, will continue reading the escaped
symbol)
NIL])
(\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])
)
(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*)
)
)
(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)
)
(PUTPROPS LLREAD COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1351 11370 (LASTC 1361 . 3361) (PEEKC 3363 . 3942) (PEEKCCODE 3944 . 4512) (RATOM 4514
. 5319) (READ 5321 . 6074) (READC 6076 . 6394) (READCCODE 6396 . 6863) (READP 6865 . 7472) (
SETREADMACROFLG 7474 . 7880) (SKIPSEPRCODES 7882 . 9183) (SKIPSEPRS 9185 . 10494) (
\NSIN.24BITENCODING.ERROR 10496 . 11368)) (11371 18067 (RSTRING 11381 . 11892) (\RSTRING2 11894 .
18065)) (18068 38943 (\SUBREAD 18078 . 36483) (\READ.SYMBOL 36485 . 37587) (\INVALID.SYMBOL 37589 .
37936) (\APPLYREADMACRO 37938 . 38357) (INREADMACROP 38359 . 38941)))))
STOP