(FILECREATED "13-Jan-85 01:07:29" {ERIS}<LISPCORE>SOURCES>LLREAD.;3 21393
changes to: (FNS \APPLYREADMACRO)
previous date: "20-Mar-84 22:09:39" {ERIS}<LISPCORE>SOURCES>LLREAD.;2)
(* Copyright (c) 1981, 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LLREADCOMS)
(RPAQQ LLREADCOMS ((FNS INREADMACROP LASTC PEEKC RATEST RATOM READ READC READP RSTRING
SETREADMACROFLG SKIPSEPRS \APPLYREADMACRO \RSTRING2 \SUBREAD)
(DECLARE: DONTCOPY (CONSTANTS * READTYPES)
(MACROS FIXDOT RBCONTEXT PROPRB \RDCONC))
(DECLARE: DONTCOPY (EXPORT (MACROS \CHECKEOLC \INCHAR)))
(VARS (\RefillBufferFn (FUNCTION \READCREFILL)))
(* Act like READC if there is no binding of \RefillBufferFn--we must be doing a
raw BIN (or PEEKBIN?))
(LOCALVARS . T)
(SPECVARS \RefillBufferFn)))
(DEFINEQ
(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])
(LASTC
[LAMBDA (FILE) (* rmk: " 7-NOV-83 23:08")
(* 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 (STREAM (\GETSTREAM FILE (QUOTE INPUT]
(RETURN (FCHARACTER
(SELCHARQ (SETQ C (\BACKPEEKBIN STREAM))
(CR (SELECTC (fetch EOLCONVENTION of STREAM)
(CR.EOLC (CHARCODE EOL))
C))
(LF (SELECTC (fetch EOLCONVENTION of STREAM)
(LF.EOLC (CHARCODE EOL))
(CRLF.EOLC (COND
([EQ (CHARCODE CR)
(UNINTERRUPTABLY
(AND (\BACKFILEPTR STREAM)
(PROG1 (\BACKPEEKBIN STREAM)
(\BIN STREAM))))]
(CHARCODE EOL))
(T C)))
C))
(NIL 0)
C])
(PEEKC
[LAMBDA (FILE FLG) (* rmk: "21-OCT-83 12:11")
(* FLG says to proceed as if Control were T--not
implemented correctly here NIL)
(PROG [(\RefillBufferFn (FUNCTION \PEEKREFILL))
(STREAM (\GETSTREAM FILE (QUOTE INPUT]
(DECLARE (SPECVARS \RefillBufferFn))
(RETURN (FCHARACTER (\CHECKEOLC (\PEEKBIN STREAM)
(fetch EOLCONVENTION of STREAM)
STREAM T])
(RATEST
[LAMBDA (FLG) (* rmk: " 5-DEC-79 23:03")
(DECLARE (GLOBALVARS \SEPRFLG \BRKFLG \PERCENTFLG))
(SELECTQ FLG
(T \SEPRFLG)
(NIL \BRKFLG)
(1 \PERCENTFLG)
NIL])
(RATOM
[LAMBDA (FILE RDTBL) (* rmk: "21-OCT-83 12:15")
(DECLARE (GLOBALVARS \PERCENTFLG \BRKFLG \SEPRFLG))
(GLOBALRESOURCE \PNAMESTRING (PROG ((STREAM (\GETSTREAM FILE (QUOTE INPUT)))
(#CURRENTRDTBL# (\GTREADTABLE RDTBL))
(\RefillBufferFn (QUOTE \RATOM/RSTRING-REFILL))
(PBASE (SELECTQ (SYSTEMTYPE)
(D (fetch (STRINGP BASE) of \PNAMESTRING))
\PNAMESTRING))
(J 0)
SA CH SNX)
(DECLARE (SPECVARS #CURRENTRDTBL# \RefillBufferFn))
(SETQ \BRKFLG (SETQ \PERCENTFLG NIL))
(SETQ SA (fetch READSA of #CURRENTRDTBL#))
(COND
[[EQ SEPRCHAR.RC (SETQ SNX (\SYNCODE SA (SETQ CH
(\BIN STREAM]
(SETQ \SEPRFLG T)
(while (EQ SEPRCHAR.RC (SETQ SNX (\SYNCODE SA
(SETQ CH
(\BIN STREAM]
(T (SETQ \SEPRFLG NIL)))
SCANLOOP
[COND
((EQ SNX OTHER.RC))
[(fetch STOPATOM of SNX)
(RETURN (SELECTQ J
(0 (SETQ \BRKFLG T)
(* Atom is a single break (Sepr doesn't get here cause
of while-loop above))
(FCHARACTER CH))
(1 (\BACKFILEPTR STREAM)
(* One-character case done separately for efficiency)
(FCHARACTER (\GETBASEBYTE PBASE 0)))
(PROGN (\BACKFILEPTR STREAM)
(\MKATOM PBASE 0 J]
((AND (EQ SNX ESCAPE.RC)
(fetch ESCAPEFLG of #CURRENTRDTBL#))
(SETQ \PERCENTFLG T)
(SETQ CH (\BIN STREAM))
(SETQ CH (\CHECKEOLC CH (fetch EOLCONVENTION of STREAM)
STREAM]
(COND
((EQ J \PNAMELIMIT)
(LISPERROR "ATOM TOO LONG" NIL)))
(\PUTBASEBYTE PBASE J CH)
(add J 1)
[COND
((AND (NOT (\INTERMP STREAM))
(\EOFP STREAM))
(* This differs from the 10: Treat EOF as an atom
terminator without causing error.)
(RETURN (\MKATOM PBASE 0 J]
[SETQ SNX (\SYNCODE SA (SETQ CH (\BIN STREAM]
(GO SCANLOOP])
(READ
[LAMBDA (FILE RDTBL FLG) (* rmk: "21-OCT-83 11:52")
(DECLARE (SPECVARS FLG)
(GLOBALVARS \BRKFLG \PERCENTFLG)) (* FLG is used freely by \FILLBUFFER)
(PROG ((#CURRENTRDTBL# (\GTREADTABLE RDTBL))
(\RefillBufferFn (FUNCTION \READREFILL)))
(DECLARE (SPECVARS #CURRENTRDTBL# \RefillBufferFn))
(SETQ \BRKFLG (SETQ \PERCENTFLG NIL))
(RETURN (GLOBALRESOURCE \PNAMESTRING (\SUBREAD (\GETSTREAM FILE (QUOTE INPUT))
(fetch READSA of #CURRENTRDTBL#)
READ.RT \PNAMESTRING])
(READC
[LAMBDA (FILE RDTBL) (* rmk: " 8-NOV-83 11:35")
(PROG ((#CURRENTRDTBL# (\GTREADTABLE RDTBL))
(\RefillBufferFn (FUNCTION \READCREFILL)))
(DECLARE (SPECVARS #CURRENTRDTBL# \RefillBufferFn))
(RETURN (FCHARACTER (\INCHAR (\INSTREAMARG FILE])
(READP
[LAMBDA (FILE FLG) (* rmk: "22-OCT-83 12:35")
(* The 10 does not do the EOL check on the peeked
character.)
(PROG ((STREAM (\GETSTREAM FILE (QUOTE INPUT)))
DEVICE)
(SETQ DEVICE (ffetch (STREAM DEVICE) of STREAM))
(RETURN (COND
((ffetch (FDEV READP) of DEVICE) (* Here's the new code -- runs the READP function if
there is one)
(FDEVOP (QUOTE READP)
DEVICE STREAM FLG))
(T (\GENERIC.READP STREAM FLG])
(RSTRING
[LAMBDA (FILE RDTBL) (* rmk: "21-OCT-83 11:52")
(PROG ((#CURRENTRDTBL# (\GTREADTABLE RDTBL))
(\RefillBufferFn (QUOTE \RATOM/RSTRING-REFILL)))
(DECLARE (SPECVARS #CURRENTRDTBL# \RefillBufferFn))
(RETURN (GLOBALRESOURCE \PNAMESTRING (\RSTRING2 (\GETSTREAM FILE (QUOTE INPUT))
(fetch READSA of #CURRENTRDTBL#)
T \PNAMESTRING])
(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])
(SKIPSEPRS
[LAMBDA (FILE RDTBL) (* rmk: "21-OCT-83 11:53")
(* 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 (STREAM ←(\GETSTREAM FILE (QUOTE INPUT)))
(SA ←(fetch (READTABLEP READSA) of (\GTREADTABLE RDTBL)))
(\RefillBufferFn ←(QUOTE \PEEKREFILL)) declare (SPECVARS \RefillBufferFn)
while [EQ SEPRCHAR.RC (\SYNCODE SA (SETQ C (OR (\PEEKBIN STREAM T)
(RETURN]
do (\BIN STREAM) finally (RETURN (FCHARACTER C])
(\APPLYREADMACRO
[LAMBDA (STREAM MACDEF ANSCELL) (* edited: "13-Jan-85 00:56")
(* INREADMACROP searches for this framename)
(DECLARE (USEDFREE #CURRENTRDTBL#))
(APPLY* (fetch MACROFN of MACDEF)
(LET ((FULLNAME (fetch FULLNAME of STREAM)))
(if (EQ FULLNAME T)
then FULLNAME
else STREAM))
#CURRENTRDTBL# ANSCELL])
(\RSTRING2
[LAMBDA (STREAM SA RSFLG PNSTR) (* rmk: "21-OCT-83 12:17")
(* PNSTR is an instance of the global resource
\PNAMESTRING, which we can reuse without confusion.)
(DECLARE (USEDFREE #CURRENTRDTBL#))
(PROG (CH SNX ANSTR (EOLC (fetch EOLCONVENTION of STREAM))
(PBASE (SELECTQ (SYSTEMTYPE)
(VAX PNSTR)
(fetch (STRINGP BASE) of PNSTR)))
(J 0))
RS2LP
(SETQ CH (\CHECKEOLC (\BIN STREAM)
EOLC STREAM))
(SETQ SNX (\SYNCODE SA CH))
[COND
((EQ SNX OTHER.RC))
[(EQ SNX ESCAPE.RC)
(AND (fetch ESCAPEFLG of #CURRENTRDTBL#)
(SETQ CH (\CHECKEOLC (\BIN STREAM)
EOLC STREAM]
((COND
(RSFLG (* if called from RSTRING, end check is break or sepr)
(fetch STOPATOM of SNX))
(T (* otherwise, end check is dbl quote)
(EQ SNX STRINGDELIM.RC)))
(COND
(RSFLG (* if from RSTRING must put delim back)
(\BACKFILEPTR STREAM)))
(RETURN (\SMASHSTRING (COND
(ANSTR (\SMASHSTRING (ALLOCSTRING (IPLUS (fetch (STRINGP LENGTH)
of ANSTR)
J))
0 ANSTR))
(T (ALLOCSTRING J)))
(COND
(ANSTR (fetch (STRINGP LENGTH) of ANSTR))
(T 0))
PNSTR J]
(COND
((EQ J \PNAMELIMIT) (* FILLED PNSTR)
[SETQ ANSTR (COND
(ANSTR (\SMASHSTRING (\SMASHSTRING (ALLOCSTRING (IPLUS (fetch (STRINGP LENGTH)
of ANSTR)
\PNAMELIMIT))
0 ANSTR)
(fetch (STRINGP LENGTH) of ANSTR)
PNSTR))
(T (\SMASHSTRING (ALLOCSTRING \PNAMELIMIT)
0 PNSTR]
(SETQ J 0)))
(PUTBASEBYTE PBASE J CH)
(SETQ J (ADD1 J))
(GO RS2LP])
(\SUBREAD
[LAMBDA (STREAM SA READTYPE PNSTR) (* rmk: "21-OCT-83 12:20")
(* 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), and PROPRB.RT if propagation is not suppressed (sublist beginning with
left-paren). 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 (READTYPE=READ.RT) -
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 #CURRENTRDTBL# \RBFLG)
(GLOBALVARS \PERCENTFLG \BRKFLG \SEPRFLG))
(PROG [CH J SNX LST END ELT DOTLOC (PBASE (SELECTQ (SYSTEMTYPE)
(VAX PNSTR)
(fetch (STRINGP BASE) of PNSTR]
[COND
((EQ READTYPE READ.RT)
(COND
([EQ SEPRCHAR.RC (SETQ SNX (\SYNCODE SA (SETQ CH (\BIN STREAM]
(SETQ \SEPRFLG T))
(T (SETQ \SEPRFLG NIL)
(GO STARTATOM]
SEPRLOOP
(AND [EQ SEPRCHAR.RC (SETQ SNX (\SYNCODE SA (SETQ CH (\BIN STREAM]
(GO SEPRLOOP))
STARTATOM
(COND
((EQ SNX OTHER.RC)
(SETQ J 0)
(COND
([AND (EQ CH (CHARCODE %.))
(fetch STOPATOM of (\SYNCODE SA (\PEEKBIN STREAM]
(* 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 FIRSTCHAR))
((fetch STOPATOM of SNX)
(GO BREAK))
((AND (SELECTC (fetch MACROCONTEXT of SNX)
(FIRST.RMC T)
[ALONE.RMC (fetch STOPATOM of (\SYNCODE SA (\PEEKBIN STREAM]
NIL)
(fetch READMACROFLG of #CURRENTRDTBL#))
(GO MACRO)))
(SETQ J 0)
SCANLOOP
[COND
((AND (EQ SNX ESCAPE.RC)
(fetch ESCAPEFLG of #CURRENTRDTBL#))
(AND (EQ READTYPE READ.RT)
(SETQ \PERCENTFLG T)) (* Only set PERCENTFLG at the top level of read)
(SETQ CH (\CHECKEOLC (\BIN STREAM)
(fetch EOLCONVENTION of STREAM)
STREAM]
OTHER
(COND
((EQ J \PNAMELIMIT) (* Skip length check on the first char)
(LISPERROR "ATOM TOO LONG" NIL)))
FIRSTCHAR
(PUTBASEBYTE PBASE J CH)
(add J 1)
[COND
((AND (EQ READTYPE READ.RT)
(NOT (\INTERMP STREAM))
(\EOFP STREAM))
(RETURN (\MKATOM PBASE 0 J]
(COND
([EQ OTHER.RC (SETQ SNX (\SYNCODE SA (SETQ CH (\BIN STREAM]
(GO OTHER))
[(fetch STOPATOM of SNX)
[SETQ ELT (COND
((EQ J 1) (* One-char case special for efficiency)
(FCHARACTER (GETBASEBYTE PBASE 0)))
(T (\MKATOM PBASE 0 J]
(\RDCONC ELT (\BACKFILEPTR STREAM) (* Put back the terminating character)
(RETURN ELT))
(COND
((EQ SNX SEPRCHAR.RC) (* Examine the terminating character)
(GO SEPRLOOP))
(T (GO BREAK]
(T (GO SCANLOOP)))
BREAK
[SELECTC SNX
[LEFTPAREN.RC (COND
((PROG1 (PROPRB (SETQ ELT (\SUBREAD STREAM SA PROPRB.RT PNSTR)))
(\RDCONC ELT (RETURN ELT)))
(FIXDOT)
(RETURN LST]
(LEFTBRACKET.RC (SETQ ELT (\SUBREAD STREAM SA NOPROPRB.RT PNSTR))
(\RDCONC ELT (RETURN ELT)))
[(LIST RIGHTPAREN.RC RIGHTBRACKET.RC)
(RETURN (COND
((NEQ READTYPE READ.RT)
(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 #CURRENTRDTBL#)))
(SETQ ELT (FCHARACTER CH)) (* A breakchar or a disabled always macro)
(\RDCONC ELT (SETQ \BRKFLG T)
(RETURN ELT)))
(T (GO MACRO]
(GO SEPRLOOP)
MACRO
(SELECTQ (fetch MACROTYPE of (SETQ SNX (\GETREADMACRODEF CH #CURRENTRDTBL#)))
[MACRO (COND
((PROPRB (SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR (\APPLYREADMACRO
STREAM SNX)))
(* Ignore right-bracket if macro is called at top-level
read)
(\RDCONC ELT (AND \RBFLG (\BACKFILEPTR STREAM))
(* Back over right-bracket and return instead of setting
free \RBFLG)
(RETURN ELT)))
(FIXDOT)
(RETURN LST]
[INFIX (COND
[(EQ READTYPE READ.RT)
[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)
(EQ READTYPE READ.RT))
(* 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 SEPRLOOP))
((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 SEPRLOOP])
)
(DECLARE: DONTCOPY
(RPAQQ READTYPES (READ.RT NOPROPRB.RT PROPRB.RT))
(DECLARE: EVAL@COMPILE
(RPAQQ READ.RT NIL)
(RPAQQ NOPROPRB.RT T)
(RPAQQ PROPRB.RT 0)
(CONSTANTS READ.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)
(COND
[LST (RPLACD END (SETQ END (CONS ELT]
((EQ READTYPE READ.RT) . TOPFORMS)
(T (SETQ LST (SETQ END (CONS ELT])
)
)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(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.)
(AND (QUOTE COUNTERVAR)
(SETQ COUNTERVAR (SUB1 COUNTERVAR)))
(SELCHARQ CH
(CR (SELECTC EOLC
(CR.EOLC (CHARCODE EOL))
[CRLF.EOLC (COND
[PEEKBINFLG
(* T from \PEEKBIN, compile-time constant.
In this case, must leave the fileptr where it was.
NIL)
(COND
([EQ (CHARCODE LF)
(UNINTERRUPTABLY
(\BIN STREAM)
(* Read the CR)
(PROG1 (\PEEKBIN STREAM T)
(\BACKFILEPTR 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)
(\CHECKEOLC (\BIN STREAM)
(fetch EOLCONVENTION of STREAM)
STREAM NIL COUNTERVAR)))
)
(* END EXPORTED DEFINITIONS)
)
(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)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS \RefillBufferFn)
)
(PUTPROPS LLREAD COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (867 18156 (INREADMACROP 877 . 1351) (LASTC 1353 . 2483) (PEEKC 2485 . 3021) (RATEST
3023 . 3275) (RATOM 3277 . 5570) (READ 5572 . 6183) (READC 6185 . 6509) (READP 6511 . 7152) (RSTRING
7154 . 7596) (SETREADMACROFLG 7598 . 7885) (SKIPSEPRS 7887 . 8542) (\APPLYREADMACRO 8544 . 9036) (
\RSTRING2 9038 . 11112) (\SUBREAD 11114 . 18154)))))
STOP