(FILECREATED "19-JUL-83 03:31:31" {PHYLUM}<LISPCORE>SOURCES>LLREAD.;18 18359
changes to: (FNS READP)
previous date: " 9-JUN-83 19:36:24" {PHYLUM}<LISPCORE>SOURCES>LLREAD.;17)
(* Copyright (c) 1981, 1982, 1983 by Xerox Corporation)
(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 CHECKCRMODE))
(VARS (\RefillBufferFn (FUNCTION \READREFILL)))
(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: "27-OCT-81 21:30")
(* 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 OFD field.)
(PROG [C (OFD (\GETOFD FILE (QUOTE INPUT]
(RETURN (FCHARACTER (COND
((NULL (SETQ C (\BACKPEEKBIN OFD)))
0)
([AND (EQ C (CHARCODE LF))
(EQ (CHARCODE CR)
(UNINTERRUPTABLY
(AND (\BACKFILEPTR OFD)
(PROG1 (\BACKPEEKBIN OFD)
(\BIN OFD))))]
(* Linefeed preceded by CR)
(CHARCODE EOL))
(T C])
(PEEKC
[LAMBDA (FILE FLG) (* lmm " 5-MAR-83 18:24")
(* FLG SAYS TO PROCEED AS IF CONTROL WERE T -
NOT IMPLEMENTED CORRECTLY HERE)
(PROG ((\RefillBufferFn (FUNCTION \PEEKREFILL))
CHR OFD)
(DECLARE (SPECVARS \RefillBufferFn)
(LOCALVARS CHR OFD))
(SETQ CHR (CHECKCRMODE [\PEEKBIN (SETQ OFD (\GETOFD FILE (QUOTE INPUT]
OFD T))
(RETURN (FCHARACTER CHR])
(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) (* lmm " 5-MAR-83 18:52")
(DECLARE (GLOBALVARS \PERCENTFLG \BRKFLG \SEPRFLG))
(GLOBALRESOURCE \PNAMESTRING
(PROG ((OFD (\GETOFD 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 OFD]
(SETQ \SEPRFLG T)
(while (EQ SEPRCHAR.RC (SETQ SNX (\SYNCODE SA (SETQ CH (\BIN OFD]
(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 OFD)
(* One-character case done separately for efficiency)
(FCHARACTER (\GETBASEBYTE PBASE 0)))
(PROGN (\BACKFILEPTR OFD)
(\MKATOM PBASE 0 J]
((AND (EQ SNX ESCAPE.RC)
(fetch ESCAPEFLG of #CURRENTRDTBL#))
(SETQ \PERCENTFLG T)
(SETQ CH (\BIN OFD]
(COND
((EQ J \PNAMELIMIT)
(LISPERROR "ATOM TOO LONG" NIL)))
(\PUTBASEBYTE PBASE J (CHECKCRMODE CH OFD))
(add J 1)
[COND
((AND (NOT (\INTERMP OFD))
(\EOFP OFD))
(* 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 OFD]
(GO SCANLOOP)))])
(READ
[LAMBDA (FILE RDTBL FLG) (* rmk: " 4-NOV-81 21: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 (\GETOFD FILE (QUOTE INPUT))
(fetch READSA of #CURRENTRDTBL#)
READ.RT \PNAMESTRING))])
(READC
[LAMBDA (FILE RDTBL) (* lmm " 5-MAR-83 19:12")
(PROG (CH (OFD (\GETOFD FILE (QUOTE INPUT)))
(#CURRENTRDTBL# (\GTREADTABLE RDTBL))
(\RefillBufferFn (FUNCTION \READCREFILL)))
(DECLARE (SPECVARS #CURRENTRDTBL# \RefillBufferFn))
(RETURN (FCHARACTER (CHECKCRMODE (\BIN OFD)
OFD])
(READP
(LAMBDA (FILE FLG) (* JonL "19-JUL-83 03:17")
(DECLARE (GLOBALVARS \PRIMTERMSA)) (* 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: " 4-NOV-81 22:01")
(PROG ((#CURRENTRDTBL# (\GTREADTABLE RDTBL))
(\RefillBufferFn (QUOTE \RATOM/RSTRING-REFILL)))
(DECLARE (SPECVARS #CURRENTRDTBL# \RefillBufferFn))
(RETURN (GLOBALRESOURCE \PNAMESTRING
(\RSTRING2 (\GETOFD FILE (QUOTE INPUT))
(fetch READSA of #CURRENTRDTBL#)
T \PNAMESTRING))])
(SETREADMACROFLG
[LAMBDA (FLG) (* edited: "25-MAY-79 14:56")
(PROG1 \INREADMACROFLG (SETQ \INREADMACROFLG FLG])
(SKIPSEPRS
[LAMBDA (FILE RDTBL) (* rmk: " 6-NOV-81 17:41")
(* 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 (OFD ←(\GETOFD 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 OFD T)
(RETURN]
do (\BIN OFD) finally (RETURN (FCHARACTER C])
(\APPLYREADMACRO
[LAMBDA (OFD MACDEF ANSCELL) (* rmk: " 6-NOV-81 17:40")
(* INREADMACROP searches for this framename)
(DECLARE (USEDFREE #CURRENTRDTBL#))
(APPLY* (fetch MACROFN of MACDEF)
(fetch FULLNAME of OFD)
#CURRENTRDTBL# ANSCELL])
(\RSTRING2
[LAMBDA (OFD SA RSFLG PNSTR) (* lmm " 5-MAR-83 20:01")
(* PNSTR is an instance of the global resource \PNAMESTRING, which we can reuse
without confusion.)
(DECLARE (USEDFREE #CURRENTRDTBL#))
(PROG (CH SNX ANSTR (PBASE (SELECTQ (SYSTEMTYPE)
(VAX PNSTR)
(fetch (STRINGP BASE) of PNSTR)))
(J 0))
RS2LP
(SETQ CH (CHECKCRMODE (\BIN OFD)
OFD))
(SETQ SNX (\SYNCODE SA CH))
[COND
((EQ SNX OTHER.RC))
[(EQ SNX ESCAPE.RC) (* Probably should do CR checking on this \BIN)
(AND (fetch ESCAPEFLG of #CURRENTRDTBL#)
(SETQ CH (\BIN OFD]
((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 OFD)))
(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 (OFD SA READTYPE PNSTR)
(* dav: "28-JUN-82 11:30")
(* 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 OFD]
(SETQ \SEPRFLG T))
(T (SETQ \SEPRFLG NIL)
(GO STARTATOM]
SEPRLOOP
(AND [EQ SEPRCHAR.RC (SETQ SNX (\SYNCODE SA (SETQ CH (\BIN OFD]
(GO SEPRLOOP))
STARTATOM
(COND
((EQ SNX OTHER.RC)
(SETQ J 0)
(COND
([AND (EQ CH (CHARCODE %.))
(fetch STOPATOM of (\SYNCODE SA (\PEEKBIN OFD]
(* 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 OFD]
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 (CHECKCRMODE (\BIN OFD)
OFD]
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 OFD))
(\EOFP OFD))
(RETURN (\MKATOM PBASE 0 J]
(COND
([EQ OTHER.RC (SETQ SNX (\SYNCODE SA (SETQ CH (\BIN OFD]
(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 OFD)
(* 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 OFD SA PROPRB.RT PNSTR)))
(\RDCONC ELT (RETURN ELT)))
(FIXDOT)
(RETURN LST]
(LEFTBRACKET.RC (SETQ ELT (\SUBREAD OFD 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 OFD 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
OFD SNX)))
(* Ignore right-bracket if macro is called at top-level read)
(\RDCONC ELT (AND \RBFLG (\BACKFILEPTR OFD))
(* 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 OFD 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 OFD SNX
(CONS LST END]
(FIXDOT)
(RETURN (CAR ELT]
(SETQ LST (CAR ELT))
(SETQ END (CDR ELT]
[SPLICE [RBCONTEXT (SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR (\APPLYREADMACRO
OFD 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)))))))
(PUTPROPS CHECKCRMODE MACRO (OPENLAMBDA (CH OFD CHWASPEEKED)
(SELECTQ (SYSTEMTYPE)
(D CH)
(VAX (COND
((OR (\NONTTYLFP CH OFD)
(AND \TTYMODE (EQ CH (CHARCODE CR))))
(CHARCODE EOL))
(T CH)))
(NIL (COND
((AND (EQ CH (CHARCODE CR))
(NOT (\EOFP OFD))
(EQ (\PEEKBIN OFD)
(CHARCODE LF)))
(\BIN OFD)
(CHARCODE EOL))
(T CH)))
(HELP))))
)
)
(RPAQ \RefillBufferFn (FUNCTION \READREFILL))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS \RefillBufferFn)
)
(PUTPROPS LLREAD COPYRIGHT ("Xerox Corporation" 1981 1982 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (659 16641 (INREADMACROP 669 . 1143) (LASTC 1145 . 2080) (PEEKC 2082 . 2556) (RATEST
2558 . 2810) (RATOM 2812 . 4736) (READ 4738 . 5360) (READC 5362 . 5715) (READP 5717 . 6366) (RSTRING
6368 . 6822) (SETREADMACROFLG 6824 . 6993) (SKIPSEPRS 6995 . 7638) (\APPLYREADMACRO 7640 . 8017) (
\RSTRING2 8019 . 9872) (\SUBREAD 9874 . 16639)))))
STOP