(FILECREATED "12-Mar-86 15:46:24" {ERIS}<LISPCORE>BVM>LLREAD.;4 46097
changes to: (VARS LLREADCOMS READTYPES RATOM.RT)
(FNS \NSIN.24BITENCODING.ERROR RATOM \SUBREAD READ)
(MACROS \NSIN \NSPEEK \RDCONC)
previous date: " 9-May-85 14:49:14" {ERIS}<LISPCORE>SOURCES>LLREAD.;8)
(* Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LLREADCOMS)
(RPAQQ LLREADCOMS
((FNS INREADMACROP LASTC PEEKC PEEKCCODE RATOM READ READC READCCODE READP RSTRING
SETREADMACROFLG SKIPSEPRCODES SKIPSEPRS \APPLYREADMACRO \RSTRING2 \SUBREAD
\NSIN.24BITENCODING.ERROR)
(DECLARE: DONTCOPY (CONSTANTS * READTYPES)
(MACROS FIXDOT RBCONTEXT PROPRB \RDCONC)
(EXPORT (MACROS \BACKCHAR \BACKNSCHAR \CHECKEOLC \INCHAR \INCCODE \PEEKCCODE \NSIN
\NSINTEMP \NSPEEK))
(SPECVARS \RefillBufferFn))
(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
(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-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:
"11-Mar-86 12:00")
(* * Like READ except interpret break characters as single character
atoms. I.e., always returns an atom)
(LET ((#CURRENTRDTBL# (\GTREADTABLE RDTBL))
(\RefillBufferFn (FUNCTION \RATOM/RSTRING-REFILL)))
(DECLARE (SPECVARS #CURRENTRDTBL# \RefillBufferFn))
(WITH-RESOURCE (\PNAMESTRING)
(\SUBREAD (\GETSTREAM FILE (QUOTE INPUT))
(fetch (READTABLEP READSA) of #CURRENTRDTBL#)
RATOM.RT \PNAMESTRING (AND (fetch (READTABLEP CASEINSENSITIVE) of
#CURRENTRDTBL#
)
(fetch (ARRAYP BASE) of UPPERCASEARRAY])
(READ
[LAMBDA (FILE RDTBL FLG) (* bvm:
"10-Mar-86 18:12")
(DECLARE (SPECVARS FLG)) (* FLG is used freely by
\FILLBUFFER)
(LET ((#CURRENTRDTBL# (\GTREADTABLE RDTBL))
(\RefillBufferFn (FUNCTION \READREFILL)))
(DECLARE (SPECVARS #CURRENTRDTBL# \RefillBufferFn))
(WITH-RESOURCE (\PNAMESTRING)
(\SUBREAD (\GETSTREAM FILE (QUOTE INPUT))
(fetch (READTABLEP READSA) of #CURRENTRDTBL#)
READ.RT \PNAMESTRING (AND (fetch (READTABLEP CASEINSENSITIVE) of
#CURRENTRDTBL#
)
(fetch (ARRAYP BASE) of UPPERCASEARRAY])
(READC
[LAMBDA (FILE RDTBL) (* rmk: " 4-Apr-85 11:29")
(PROG ((#CURRENTRDTBL# (\GTREADTABLE RDTBL))
(\RefillBufferFn (FUNCTION \READCREFILL)))
(DECLARE (SPECVARS #CURRENTRDTBL# \RefillBufferFn))
(RETURN (FCHARACTER (\INCCODE (\INSTREAMARG FILE])
(READCCODE
[LAMBDA (FILE RDTBL) (* rmk: " 4-Apr-85 11:29")
(* * returns a 16 bit character code. \INCHAR does the EOL conversion and this function converts to a 16 bit value)
(PROG ((#CURRENTRDTBL# (\GTREADTABLE RDTBL))
(\RefillBufferFn (FUNCTION \READCREFILL)))
(DECLARE (SPECVARS #CURRENTRDTBL# \RefillBufferFn))
(RETURN (\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])
(RSTRING
[LAMBDA (FILE RDTBL) (* rmk: " 2-Apr-85 14:14")
(PROG ((#CURRENTRDTBL# (\GTREADTABLE RDTBL))
(\RefillBufferFn (QUOTE \RATOM/RSTRING-REFILL)))
(DECLARE (SPECVARS #CURRENTRDTBL# \RefillBufferFn))
(RETURN (WITH-RESOURCE (\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])
(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])
(\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: " 3-Apr-85 09:12")
(* PNSTR is an instance of the global resource
\PNAMESTRING, which we can reuse without confusion.)
(DECLARE (USEDFREE #CURRENTRDTBL#))
(PROG (CH SNX ANSLIST FATSEEN (EOLC (ffetch EOLCONVENTION of STREAM))
(PBASE (SELECTQ (SYSTEMTYPE)
(VAX PNSTR)
(ffetch (STRINGP XBASE) of PNSTR)))
(SHIFTEDCHARSET (UNFOLD (ffetch CHARSET of STREAM)
256))
(J 0))
RS2LP
(SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)
EOLC STREAM))
(SETQ SNX (\SYNCODE SA CH))
[COND
((EQ SNX OTHER.RC))
[(EQ SNX ESCAPE.RC)
(AND (fetch ESCAPEFLG of #CURRENTRDTBL#)
(SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)
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)
(\BACKNSCHAR STREAM SHIFTEDCHARSET)))
(RETURN (COND
[ANSLIST (CONCATLIST (DREVERSE (CONS (\SMASHSTRING (ALLOCSTRING J NIL NIL
FATSEEN)
0 PNSTR J)
ANSLIST]
(T (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN)
0 PNSTR J]
(COND
((EQ J \PNAMELIMIT) (* FILLED PNSTR)
(push ANSLIST (\SMASHSTRING (ALLOCSTRING \PNAMELIMIT NIL NIL FATSEEN)
0 PNSTR))
(SETQ J 0)))
(\PNAMESTRINGPUTCHAR PBASE J CH)
(OR FATSEEN (SETQ FATSEEN (IGREATERP CH \MAXTHINCHAR)))
(SETQ J (ADD1 J))
(GO RS2LP])
(\SUBREAD
[LAMBDA (STREAM SA READTYPE PNSTR CASEBASE) (* bvm:
"11-Mar-86 12:03")
(* 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 #CURRENTRDTBL# \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)
SEPRLOOP
(* * Here ready to scan a new token. First skip over separator characters)
(COND
((EQ [SETQ SNX (\SYNCODE SA (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET]
SEPRCHAR.RC)
(GO SEPRLOOP))
((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.)
))
(SETQ J 0)
(SETQ ESCAPEFLG NIL)
(GO GOTATOMCHAR))
[(fetch STOPATOM of SNX) (* This character
definitely does not
start an atom)
(COND
((EQ READTYPE RATOM.RT)
(GO SINGLECHARATOM))
(T (GO BREAK]
[(AND (SELECTC (fetch MACROCONTEXT of SNX)
(FIRST.RMC T)
(ALONE.RMC (fetch STOPATOM of (\SYNCODE SA (\NSPEEK STREAM SHIFTEDCHARSET
SHIFTEDCHARSET))))
NIL)
(fetch READMACROFLG of #CURRENTRDTBL#))
(COND
((EQ READTYPE RATOM.RT)
(GO SINGLECHARATOM))
(T (GO MACRO]
(T (* Some character that
starts an atom but has
non-trivial syntax
attributes)
(SETQ J 0)
(SETQ ESCAPEFLG NIL)))
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 #CURRENTRDTBL#)
(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 (\MKATOM PBASE 0 J \FATPNAMESTRINGP]
(COND
((EQ [SETQ SNX (\SYNCODE SA (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET]
OTHER.RC)
(GO GOTATOMCHAR))
[(fetch STOPATOM of SNX) (* Terminates atom)
(SETQ ELT (\MKATOM PBASE 0 J \FATPNAMESTRINGP))
(\RDCONC ELT (PROGN (* At top-level, put
back the terminating
character)
(\BACKNSCHAR STREAM SHIFTEDCHARSET)
(RETURN ELT)))
(COND
((EQ SNX SEPRCHAR.RC) (* Examine the
terminating character)
(GO SEPRLOOP))
(T (GO BREAK]
(T (GO ATOMLOOP)))
SINGLECHARATOM
(\PNAMESTRINGPUTCHAR PBASE 0 CH)
(SETQ ELT (\MKATOM PBASE 0 1 \FATPNAMESTRINGP))
(\RDCONC ELT (RETURN ELT))
(GO SEPRLOOP)
(* * 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)))
(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 #CURRENTRDTBL#))) (* A breakchar or a
disabled always macro)
(GO SINGLECHARATOM))
(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 (\BACKNSCHAR STREAM SHIFTEDCHARSET))
(* Back over
right-bracket and return
instead of setting free
\RBFLG)
(RETURN ELT)))
(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 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])
(\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])
)
(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 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 \NSINTEMP MACRO (OPENLAMBDA (STREAM SHIFTEDCSET SHIFTEDCSETVAR)
(PROG1 (NSIN STREAM SHIFTEDCSET)
(AND (QUOTE SHIFTEDCSETVAR)
(SETQ SHIFTEDCSETVAR (UNFOLD (fetch (STREAM CHARSET)
of STREAM)
256]
[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)
)
)
(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 (1261 30756 (INREADMACROP 1271 . 1745) (LASTC 1747 . 3278) (PEEKC 3280 . 3755) (
PEEKCCODE 3757 . 4217) (RATOM 4219 . 5273) (READ 5275 . 6361) (READC 6363 . 6716) (READCCODE 6718 .
7192) (READP 7194 . 7712) (RSTRING 7714 . 8194) (SETREADMACROFLG 8196 . 8483) (SKIPSEPRCODES 8485 .
9411) (SKIPSEPRS 9413 . 10351) (\APPLYREADMACRO 10353 . 10845) (\RSTRING2 10847 . 12999) (\SUBREAD
13001 . 29812) (\NSIN.24BITENCODING.ERROR 29814 . 30754)))))
STOP