(FILECREATED " 7-Jul-85 13:15:24" {ERIS}<LISPCORE>SOURCES>APRINT.;12 26308
changes to: (FNS RADIX)
previous date: " 6-Jul-85 22:15:56" {ERIS}<LISPCORE>SOURCES>APRINT.;11)
(* Copyright (c) 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT APRINTCOMS)
(RPAQQ APRINTCOMS ((FNS PRIN1 PRIN2 PRIN3 PRIN4 PRINT PRINTCCODE PRINTLEVEL RADIX SPACES TERPRI
FRESHLINE DEFPRINT LINELENGTH \CKPOSBOUT \CKPOSSOUT \CONVERTNUMBER \LITPRIN
\OUTCHAR \SOUT \PRINDATUM \PRINOTHER \PRINSTACKP \PRINSTRING)
(FNS \FILEOUTCHARFN \TTYOUTCHARFN)
(FNS \MAPCHARS \MAPCHARS1 \PRODUCESTRING \PRODUCENUM \PRODUCEADDR \MAPCHARSLIT)
(INITVARS (\CARPRINTLEVEL 1000)
(\PRINTCRFLAG NIL)
(\CDRPRINTLEVEL -1)
(PLVLFILEFLG NIL)
(\LINELENGTH 82)
(\FLOATFORMAT T)
(PRXFLG NIL)
(\PRINTRADIX 10)
(\SIGNFLAG T)
(\DEFPRINTFNS NIL)
(\RADIX.PREFIX (CHCON1 "|")))
[COMS (FNS FLTFMT \CHECKFLTFMT NUMFORMATCODE PRINTNUM)
(MACROS NUMFORMATCODE)
(INITVARS (NILNUMPRINTFLG))
(P (MOVD? (QUOTE PRINTNUM)
(QUOTE FPRINTNUM]
(DECLARE: DONTCOPY (MACROS .FILELINELENGTH. .SPACECHECK. \PRODUCECHAR))
(LOCALVARS . T)
(SPECVARS \THISFILELINELENGTH)
(GLOBALVARS \CARPRINTLEVEL \TCARPRINTLEVEL \PRINTCRFLAG \CDRPRINTLEVEL \TCDRPRINTLEVEL
\LINELENGTH \FLOATFORMAT \PRINTRADIX \SIGNFLAG PRXFLG \DEFPRINTFNS \RADIX.PREFIX))
)
(DEFINEQ
(PRIN1
[LAMBDA (X FILE) (* rmk: "21-OCT-83 12:31")
(PROG ((\OFD (\GETSTREAM FILE (QUOTE OUTPUT)))
\THISFILELINELENGTH)
(DECLARE (SPECVARS \THISFILELINELENGTH))
(SETQ \THISFILELINELENGTH (.FILELINELENGTH. \OFD))
(SETQ \TCARPRINTLEVEL \CARPRINTLEVEL)
(SETQ \TCDRPRINTLEVEL \CDRPRINTLEVEL)
(\PRINDATUM X \OFD NIL (COND
((OR (\OUTTERMP \OFD)
PLVLFILEFLG)
0)))
(RETURN X])
(PRIN2
[LAMBDA (X FILE RDTBL) (* rmk: "21-OCT-83 12:31")
(PROG ((\OFD (\GETSTREAM FILE (QUOTE OUTPUT)))
\THISFILELINELENGTH)
(DECLARE (SPECVARS \THISFILELINELENGTH))
(SETQ \THISFILELINELENGTH (.FILELINELENGTH. \OFD))
(SETQ \TCARPRINTLEVEL \CARPRINTLEVEL)
(SETQ \TCDRPRINTLEVEL \CDRPRINTLEVEL)
(\PRINDATUM X \OFD (fetch READSA of (\GTREADTABLE RDTBL))
(COND
((OR (\OUTTERMP \OFD)
PLVLFILEFLG)
0)))
(RETURN X])
(PRIN3
[LAMBDA (X FILE) (* rmk: "21-OCT-83 12:31")
(PROG [\THISFILELINELENGTH (\OFD (\GETSTREAM FILE (QUOTE OUTPUT]
(DECLARE (SPECVARS \THISFILELINELENGTH))
(SETQ \TCARPRINTLEVEL \CARPRINTLEVEL)
(SETQ \TCDRPRINTLEVEL \CDRPRINTLEVEL)
[replace CHARPOSITION of \OFD with (PROG1 (fetch CHARPOSITION of \OFD)
(\PRINDATUM X \OFD NIL (COND
((OR (\OUTTERMP \OFD)
PLVLFILEFLG)
0]
(RETURN X])
(PRIN4
[LAMBDA (X FILE RDTBL) (* rmk: "21-OCT-83 12:31")
(PROG [\THISFILELINELENGTH (\OFD (\GETSTREAM FILE (QUOTE OUTPUT]
(DECLARE (SPECVARS \THISFILELINELENGTH))
(SETQ \TCARPRINTLEVEL \CARPRINTLEVEL)
(SETQ \TCDRPRINTLEVEL \CDRPRINTLEVEL)
[replace CHARPOSITION of \OFD with (PROG1 (fetch CHARPOSITION of \OFD)
(\PRINDATUM X \OFD (fetch READSA
of (\GTREADTABLE RDTBL))
(COND
((OR (\OUTTERMP \OFD)
PLVLFILEFLG)
0]
(RETURN X])
(PRINT
[LAMBDA (X FILE RDTBL) (* rmk: "21-OCT-83 12:31")
(PROG [\THISFILELINELENGTH (\OFD (\GETSTREAM FILE (QUOTE OUTPUT]
(DECLARE (SPECVARS \THISFILELINELENGTH))
(SETQ \THISFILELINELENGTH (.FILELINELENGTH. \OFD))
(SETQ \TCARPRINTLEVEL \CARPRINTLEVEL)
(SETQ \TCDRPRINTLEVEL \CDRPRINTLEVEL)
(\PRINDATUM X \OFD (fetch READSA of (\GTREADTABLE RDTBL))
(COND
((OR (\OUTTERMP \OFD)
PLVLFILEFLG)
0)))
(\OUTCHAR \OFD (CHARCODE EOL))
(RETURN X])
(PRINTCCODE
[LAMBDA (CHARCODE FILE) (* rmk: " 5-Apr-85 09:07")
(\OUTCHAR (\GETSTREAM FILE (QUOTE OUTPUT))
(COND
((\CHARCODEP CHARCODE)
CHARCODE)
(T (\ILLEGAL.ARG CHARCODE])
(PRINTLEVEL
[LAMBDA (CARVAL CDRVAL) (* rmk: "28-APR-80 12:07")
[COND
((LISTP CARVAL)
(SETQ CDRVAL (CDR CARVAL))
(SETQ CARVAL (CAR CARVAL]
(PROG ((OLD (CONS (COND
(\PRINTCRFLAG (IDIFFERENCE 0 \CARPRINTLEVEL))
(T \CARPRINTLEVEL))
\CDRPRINTLEVEL))
LEV)
(COND
(CARVAL [COND
([SETQ \PRINTCRFLAG (IGREATERP 0 (SETQ LEV (FIX CARVAL]
(SETQ LEV (IDIFFERENCE 0 LEV]
(SETQ \CARPRINTLEVEL LEV)))
[COND
(CDRVAL (SETQ \CDRPRINTLEVEL (FIX CDRVAL]
(RETURN OLD])
(RADIX
[LAMBDA (N) (* lmm " 7-Jul-85 13:02")
(PROG1 \PRINTRADIX (COND
(N (COND
((NOT (AND (FIXP N)
(ILEQ 2 N)
(ILEQ N 36)))
(\ILLEGAL.ARG N)))
(SETQ \PRINTRADIX N])
(SPACES
[LAMBDA (N FILE) (* rmk: "21-OCT-83 12:32")
[PROG ((STREAM (\GETSTREAM FILE (QUOTE OUTPUT)))
\THISFILELINELENGTH)
(SETQ \THISFILELINELENGTH (.FILELINELENGTH. STREAM))
(.SPACECHECK. STREAM N)
(FRPTQ N (\OUTCHAR STREAM (CHARCODE SPACE]
NIL])
(TERPRI
[LAMBDA (FILE) (* rmk: "21-OCT-83 12:31")
(\OUTCHAR (\GETSTREAM FILE (QUOTE OUTPUT))
(CHARCODE EOL))
NIL])
(FRESHLINE
[LAMBDA (STREAM) (* rmk: "22-AUG-83 13:48")
(* Adjusts the STREAM to be at a new line -- does
equivalent of TERPRI unless it is already
"sitting at the beginning of a line")
(if [NEQ 0 (fetch CHARPOSITION of (if (AND (type? STREAM STREAM)
(WRITEABLE STREAM))
then STREAM
else (SETQ STREAM (GETSTREAM STREAM (QUOTE OUTPUT]
then (\OUTCHAR STREAM (CHARCODE EOL))
T])
(DEFPRINT
[LAMBDA (TYPE FN) (* rmk: "28-APR-80 12:04")
(AND (FIXP TYPE)
(SETQ TYPE (\TYPENAMEFROMNUMBER TYPE))) (* The FIXP case should never occur)
(PROG ((F (FASSOC TYPE \DEFPRINTFNS)))
[COND
(F (SETQ \DEFPRINTFNS (DREMOVE F \DEFPRINTFNS]
[COND
(FN (SETQ \DEFPRINTFNS (CONS (CONS TYPE FN)
\DEFPRINTFNS]
(RETURN (CDR F])
(LINELENGTH
[LAMBDA (N FILE) (* rmk: "21-OCT-83 12:31")
(* Sets to N the linelength of FILE
(NIL defaults to primary output file))
(PROG [(STREAM (\GETSTREAM FILE (QUOTE OUTPUT]
(RETURN (PROG1 (fetch (STREAM LINELENGTH) of STREAM)
(AND N (COND
((IGREATERP 1 N)
(\ILLEGAL.ARG N))
(T (replace (STREAM LINELENGTH) of STREAM with (FIX N])
(\CKPOSBOUT
[LAMBDA (STREAM X) (* rmk: "21-OCT-83 12:32")
(.SPACECHECK. STREAM 1)
(\OUTCHAR STREAM X])
(\CKPOSSOUT
[LAMBDA (STREAM X) (* rmk: "21-OCT-83 12:32")
(.SPACECHECK. STREAM (\NSTRINGCHARS X))
(for I instring X do (\OUTCHAR STREAM I])
(\CONVERTNUMBER
[LAMBDA (N R SFLAG QFLAG NS NSB) (* lmm " 1-Jul-85 23:25")
(if (EQ N 0)
then "0"
else (LET* (SIGN [X (if (GEQ N 0)
then N
else (SETQ SIGN (IMINUS N]
(POS (NCHARS NS))
(END (SUB1 POS)))
[COND
((AND (EQ R 8)
QFLAG
(IGREATERP X 7))
(RPLCHARCODE NS (add END 1)
(CHARCODE Q]
(repeatuntil (EQ X 0)
do [RPLCHARCODE NS (add POS -1)
(LET ((DIGIT (IREMAINDER X R)))
(COND
((ILESSP DIGIT 10)
(IPLUS DIGIT (CHARCODE 0)))
(T (IPLUS (IDIFFERENCE DIGIT 10)
(CHARCODE A]
(SETQ X (IQUOTIENT X R))
finally (PROGN [COND
(SIGN (RPLCHARCODE NS (add POS -1)
(CHARCODE -]
(AND (NEQ R 8)
(NEQ R 10)
QFLAG
(OR (GREATERP N 9)
(GEQ N R))
(PROGN [if (EQ R 16)
then (RPLCHARCODE NS (add POS -1)
(CHARCODE x))
else (RPLCHARCODE NS (add POS -1)
(CHARCODE r))
(PROGN (RPLCHARCODE NS (add POS -1)
(IPLUS (CHARCODE 0)
(IMOD R 10)))
(if (GEQ R 10)
then (RPLCHARCODE NS (add POS -1)
(IPLUS (CHARCODE
0)
(IQUOTIENT
R 10]
(RPLCHARCODE NS (add POS -1)
\RADIX.PREFIX)))
(RETURN (SUBSTRING NS POS END NSB])
(\LITPRIN
[LAMBDA (X SA STREAM) (* bvm: " 6-Jul-85 17:22")
(DECLARE (USEDFREE \THISFILELINELENGTH))
(COND
((EQ X (QUOTE %.))
(COND
(SA (.SPACECHECK. STREAM 2)
(\OUTCHAR STREAM (CHARCODE %%)))
(T (.SPACECHECK. STREAM 1)))
(\OUTCHAR STREAM (CHARCODE %.)))
[SA (LET (NESCAPES)
[.SPACECHECK. STREAM (IPLUS (\NATOMCHARS X)
(SETQ NESCAPES
(for C inatom X bind (FIRSTFLG ← T)
SYN
count (PROG1 (AND (fetch (READCODE ESCQUOTE)
of (SETQ SYN (\SYNCODE SA C)))
(OR FIRSTFLG (fetch (READCODE
INNERESCQUOTE)
of SYN)))
(SETQ FIRSTFLG NIL]
(COND
((EQ NESCAPES 0) (* Won't need to check)
(SETQ NESCAPES NIL))
((NULL NESCAPES) (* If we didn't need to check linelength above, then
don't know whether escapes are needed)
(SETQ NESCAPES T)))
(for C inatom X bind (FIRSTFLG ← T)
SYN
do (AND NESCAPES (fetch (READCODE ESCQUOTE) of (SETQ SYN (\SYNCODE SA C)))
(OR FIRSTFLG (fetch (READCODE INNERESCQUOTE) of SYN))
(\OUTCHAR STREAM (CHARCODE %%)))
(\OUTCHAR STREAM C)
(SETQ FIRSTFLG NIL]
(T (.SPACECHECK. STREAM (\NATOMCHARS X))
(for C inatom X do (\OUTCHAR STREAM C])
(\OUTCHAR
[LAMBDA (STREAM CHARCODE) (* rmk: " 7-APR-82 00:25")
(STREAMOP (QUOTE OUTCHARFN)
STREAM STREAM CHARCODE])
(\SOUT
[LAMBDA (X STREAM) (* rmk: "21-OCT-83 12:32")
(for I instring X do (\OUTCHAR STREAM I])
(\PRINDATUM
[LAMBDA (X STREAM SA CPL) (* lmm " 3-Jun-85 21:11")
(* NOTE: IF YOU CHANGE \PRINDATUM, YOU MUST CHANGE
\MAPCHARS1 AS WELL TO CORRESPOND!)
(* CPL is the current printing level, NIL if
print-level should be ignored)
(SELECTC (NTYPX X)
(\LITATOM (\LITPRIN X SA STREAM))
[\LISTP (PROG (CDRCNT) (* We can pre-compute whether \TCDRPRINTLEVEL is
negative, because its sign can't be dynamically changed
by ↑P. Similarly, \PRINTCRFLAG cannot be dynamically
changed.)
(COND
((AND CPL (IGREATERP (SETQ CPL (ADD1 CPL))
\TCARPRINTLEVEL))
(\CKPOSBOUT STREAM (CHARCODE &))
(RETURN)))
(\CKPOSBOUT STREAM (CHARCODE %())
(AND CPL (IGREATERP \TCDRPRINTLEVEL -1)
(SETQ CDRCNT CPL))
LP (\PRINDATUM (CAR X)
STREAM SA CPL)
(COND
[(NLISTP (CDR X))
(COND
((SETQ X (CDR X))
(\CKPOSSOUT STREAM (QUOTE " . "))
(\PRINDATUM X STREAM SA CPL]
([AND CPL (OR (IGREATERP CPL \TCARPRINTLEVEL)
(AND CDRCNT (NOT (IGREATERP \TCDRPRINTLEVEL CDRCNT]
(\CKPOSSOUT STREAM (QUOTE " --")))
(T [COND
((AND \PRINTCRFLAG CPL (LISTP (CAR X))
\THISFILELINELENGTH
(LISTP (CADR X)))
(\OUTCHAR STREAM (CHARCODE EOL)))
(T (\CKPOSBOUT STREAM (CHARCODE SPACE]
(SETQ X (CDR X))
(AND CDRCNT (ADD1VAR CDRCNT))
(GO LP)))
(\CKPOSBOUT STREAM (CHARCODE %)]
[(LIST \SMALLP \FIXP)
(GLOBALRESOURCE (\NUMSTR \NUMSTR1)
(\CKPOSSOUT STREAM (\CONVERTNUMBER X \PRINTRADIX T SA \NUMSTR \NUMSTR1]
[\FLOATP (GLOBALRESOURCE (\NUMSTR \NUMSTR1)
(\CKPOSSOUT STREAM (\CONVERT.FLOATING.NUMBER X \NUMSTR \NUMSTR1]
(\STRINGP (\PRINSTRING X STREAM SA))
(\STACKP (\PRINSTACKP X STREAM))
(PROG [(FN (CDR (FASSOC (TYPENAME X)
\DEFPRINTFNS]
(RETURN (COND
([OR (NULL FN)
(NULL (SETQ FN (APPLY* FN X (fetch FULLNAME of STREAM]
(\PRINOTHER X STREAM SA))
((LISTP FN)
(AND (CAR FN)
(\PRINDATUM (CAR FN)
STREAM NIL CPL))
(AND (CDR FN)
(\PRINDATUM (CDR FN)
STREAM SA CPL])
(\PRINOTHER
[LAMBDA (X OFD\PRINOTHER SA)
(DECLARE (SPECVARS OFD\PRINOTHER)) (* N.Greenfeld "17-Jun-81 15:06")
(.SPACECHECK. OFD\PRINOTHER (NCHARS X))
(\MAPCHARS (FUNCTION [LAMBDA (CH)
(\OUTCHAR OFD\PRINOTHER CH])
X])
(\PRINSTACKP
[LAMBDA (X OFD\PRINSTACKP)
(DECLARE (SPECVARS OFD\PRINSTACKP)) (* rmk: " 1-APR-82 17:24")
[.SPACECHECK. OFD\PRINSTACKP (IPLUS 2 7 (COND
((RELSTKP X)
2)
((LITATOM (STKNAME X))
(\NATOMCHARS (STKNAME X)))
(T 6]
(\MAPCHARS (FUNCTION [LAMBDA (X)
(\OUTCHAR OFD\PRINSTACKP X])
X])
(\PRINSTRING
[LAMBDA (X STREAM SA) (* rmk: "21-OCT-83 12:32")
(* We key on specific characters, not syntax code, cause
that's the way the 10 seems to do it.)
(COND
(SA [.SPACECHECK. STREAM (IPLUS 2 (\NSTRINGCHARS X)
(for C instring X count (SELCHARQ C
((%" %%))
NIL]
(\OUTCHAR STREAM (CHARCODE %"))
(for C instring X
do (SELCHARQ C
((%" %% LF)
(\OUTCHAR STREAM (CHARCODE %%)))
NIL) (* VM says only %" is escaped no matter what
stringdelim's are.)
(\OUTCHAR STREAM C))
(\OUTCHAR STREAM (CHARCODE %")))
(T (.SPACECHECK. STREAM (\NSTRINGCHARS X))
(\SOUT X STREAM])
)
(DEFINEQ
(\FILEOUTCHARFN
[LAMBDA (STREAM CHARCODE) (* rmk: "24-Apr-85 11:54")
(* OUTCHARFN for standard files)
(COND
((EQ CHARCODE (CHARCODE EOL))
(COND
((NOT (\RUNCODED STREAM))
(\BOUT STREAM 0))
((EQ (\CHARSET CHARCODE)
(ffetch CHARSET of STREAM)))
(T (\BOUT STREAM NSCHARSETSHIFT)
(\BOUT STREAM 0)))
(\BOUT STREAM (SELECTC (ffetch EOLCONVENTION of STREAM)
(CR.EOLC (CHARCODE CR))
(LF.EOLC (CHARCODE LF))
(CRLF.EOLC (\BOUT STREAM (CHARCODE CR))
(* Don't put out high-order byte preceding LF. The CRLF is EOL only if the bytes are immediately adjacent in the
stream, with no additional encoding bytes)
(CHARCODE LF))
(SHOULDNT)))
(freplace CHARPOSITION of STREAM with 0))
(T [COND
((NOT (\RUNCODED STREAM))
(\BOUT STREAM (\CHARSET CHARCODE))
(\BOUT STREAM (\CHAR8CODE CHARCODE)))
((EQ (\CHARSET CHARCODE)
(ffetch CHARSET of STREAM))
(\BOUT STREAM (\CHAR8CODE CHARCODE)))
(T (\BOUT STREAM NSCHARSETSHIFT)
(\BOUT STREAM (freplace (STREAM CHARSET) of STREAM with (\CHARSET CHARCODE)))
(\BOUT STREAM (\CHAR8CODE CHARCODE]
(freplace CHARPOSITION of STREAM with (PROGN (* Ugh. Don't overflow)
(\LOLOC (\ADDBASE (ffetch CHARPOSITION
of STREAM)
1])
(\TTYOUTCHARFN
[LAMBDA (STREAM CH) (* rmk: "14-Mar-84 23:23")
(* OUTCHARFN for TTY when dribble is on)
(\OUTCHAR \DRIBBLE.OFD CH)
(SPREADAPPLY*(LISTGET (fetch OTHERPROPS of STREAM)
(QUOTE \OUTCHAR))
STREAM CH])
)
(DEFINEQ
(\MAPCHARS
[LAMBDA (FN X FLG RDTBL) (* lmm " 9-MAY-80 22:45")
(\MAPCHARS1 X (AND FLG (fetch READSA of (\GTREADTABLE RDTBL)))
FN])
(\MAPCHARS1
[LAMBDA (X SA FN) (* lmm " 1-Jul-85 23:28")
(DECLARE (SPECVARS FN))
(SELECTC (NTYPX X)
[\LITATOM (COND
[SA (COND
((EQ X (QUOTE %.))
(\PRODUCESTRING "%%."))
(T (\MAPCHARSLIT X SA FN]
(T (\MAPCHARSLIT X NIL FN]
(\LISTP (\PRODUCECHAR (CHARCODE %())
[PROG NIL
LP (\MAPCHARS1 (CAR X)
SA FN)
(COND
[(NLISTP (CDR X))
(COND
((SETQ X (CDR X))
(\PRODUCESTRING " . ")
(\MAPCHARS1 X SA FN]
(T (\PRODUCECHAR (CHARCODE SPACE))
(SETQ X (CDR X))
(GO LP]
(\PRODUCECHAR (CHARCODE %))))
((LIST \SMALLP \FIXP)
(\PRODUCENUM X (COND
(PRXFLG \PRINTRADIX)
(T 10))
(NULL PRXFLG)
SA))
[\FLOATP (WITH-RESOURCE (\NUMSTR \NUMSTR1)
(\PRODUCESTRING (\CONVERT.FLOATING.NUMBER X \NUMSTR \NUMSTR1
(COND
(PRXFLG \FLOATFORMAT)
(T T]
[\STRINGP (COND
(SA (\PRODUCECHAR (CHARCODE %"))
(for C instring X
do (SELCHARQ C
((%" %% LF)
(\PRODUCECHAR (CHARCODE %%)))
NIL)
(\PRODUCECHAR C))
(\PRODUCECHAR (CHARCODE %")))
(T (\PRODUCESTRING X]
(\STACKP (\PRODUCEADDR X)
(\PRODUCECHAR (CHARCODE /))
(\MAPCHARSLIT (COND
((RELSTKP X)
(QUOTE #0))
((LITATOM (SETQ X (STKNAME X)))
X)
(T (QUOTE *form*)))
SA FN))
(PROG [(DEFPFN (CDR (FASSOC (TYPENAME X)
\DEFPRINTFNS]
(RETURN (COND
([OR (NULL DEFPFN)
(NULL (SETQ DEFPFN (APPLY* DEFPFN X]
(\PRODUCECHAR (CHARCODE {))
(AND (TYPENAME X)
(\MAPCHARSLIT (TYPENAME X)
SA FN))
(\PRODUCECHAR (CHARCODE }))
(\PRODUCEADDR X))
((LISTP DEFPFN)
(AND (CAR DEFPFN)
(\MAPCHARS1 (CAR DEFPFN)
NIL FN))
(AND (CDR DEFPFN)
(\MAPCHARS1 (CDR DEFPFN)
SA FN])
(\PRODUCESTRING
[LAMBDA (X) (* N.Greenfeld "11-Jun-81 09:29")
(for C instring X do (\PRODUCECHAR C])
(\PRODUCENUM
[LAMBDA (N R SFLAG QFLAG) (* rmk: " 3-Apr-85 08:58")
(WITH-RESOURCE (\NUMSTR \NUMSTR1)
(for C inthinstring (\CONVERTNUMBER N R SFLAG QFLAG \NUMSTR \NUMSTR1)
do (\PRODUCECHAR C])
(\PRODUCEADDR
[LAMBDA (ADDR) (* lmm " 5-MAR-83 00:23")
(\PRODUCECHAR (CHARCODE #))
(SELECTQ (SYSTEMTYPE)
(D (\PRODUCENUM (\HILOC ADDR)
8)
(\PRODUCECHAR (CHARCODE ,))
(\PRODUCENUM (\LOLOC ADDR)
8))
(JERICHO (\PRODUCENUM (LOGAND \ADDRMASK (LOC ADDR))
8 NIL))
(VAX (\PRODUCENUM (LOC ADDR)
16 T))
((TENEX TOPS-20)
(\PRODUCENUM (LOC ADDR)
8 T))
(SYSTEMTYPEPUNT (QUOTE (\PRODUCEADDR ADDR])
(\MAPCHARSLIT
[LAMBDA (X SA FN) (* bvm: " 6-Jul-85 17:22")
(for C inatom X bind (FIRSTFLG ← T)
SYN
do [COND
((AND SA (fetch (READCODE ESCQUOTE) of (SETQ SYN (\SYNCODE SA C)))
(OR FIRSTFLG (fetch (READCODE INNERESCQUOTE) of SYN)))
(* Escape it if it is a terminating macro, or a
non-terminating macro in first position)
(\PRODUCECHAR (CHARCODE %%]
(\PRODUCECHAR C)
(SETQ FIRSTFLG NIL])
)
(RPAQ? \CARPRINTLEVEL 1000)
(RPAQ? \PRINTCRFLAG NIL)
(RPAQ? \CDRPRINTLEVEL -1)
(RPAQ? PLVLFILEFLG NIL)
(RPAQ? \LINELENGTH 82)
(RPAQ? \FLOATFORMAT T)
(RPAQ? PRXFLG NIL)
(RPAQ? \PRINTRADIX 10)
(RPAQ? \SIGNFLAG T)
(RPAQ? \DEFPRINTFNS NIL)
(RPAQ? \RADIX.PREFIX (CHCON1 "|"))
(DEFINEQ
(FLTFMT
[LAMBDA (FORMAT) (* bvm: "30-JAN-81 23:20")
(* numeric arg, as on 10, not allowed)
(PROG1 \FLOATFORMAT (AND FORMAT (\CHECKFLTFMT FORMAT)
(SETQ \FLOATFORMAT FORMAT])
(\CHECKFLTFMT
[LAMBDA (FORMAT) (* bvm: "29-JAN-81 15:41")
(* * Generates error if FORMAT is not legal FLOAT format: (FLOAT WIDTH DECPART EXPPART PAD SIGDIGITS))
(COND
([OR (EQ FORMAT T)
(AND (EQ (CAR FORMAT)
(QUOTE FLOAT))
(EVERY (CDR FORMAT)
(FUNCTION (LAMBDA (X)
(OR (NULL X)
(FIXP X]
FORMAT)
(T (LISPERROR "ILLEGAL ARG" FORMAT])
(NUMFORMATCODE
[LAMBDA (FORMAT SMASHCODE) (* rmk: "21-MAY-82 17:35")
(* A dummy in case a user has been calling it.
10 does validity checking as well as format translation,
but we won't bother)
FORMAT])
(PRINTNUM
[LAMBDA (FORMAT NUMBER FILE) (* DECLARATIONS: (RECORD FIXFMT
(WIDTH RADIX PAD0 LEFTFLUSH))
(RECORD FLOATFMT (WIDTH DECPART EXPPART PAD0 SIGDIGITS))
) (* rmk: "17-MAY-82 10:07")
(DECLARE (GLOBALVARS NILNUMPRINTFLG))
(GLOBALRESOURCE (\NUMSTR \NUMSTR1)
(PROG (STR WIDTH PAD TEMP RAD (FLOATFLAG (SELECTQ (CAR (LISTP FORMAT))
(FLOAT T)
(FIX NIL)
(LISPERROR "ILLEGAL ARG" FORMAT)))
(FMT (CDR FORMAT)))
(SETQ WIDTH (fetch WIDTH of FMT))
[SETQ STR (COND
((AND (NULL NUMBER)
NILNUMPRINTFLG))
(FLOATFLAG (\CONVERT.FLOATING.NUMBER (FLOAT NUMBER)
\NUMSTR \NUMSTR1 (\CHECKFLTFMT FORMAT)))
(T (\CONVERTNUMBER (OR (FIXP NUMBER)
(FIXR NUMBER))
(COND
((SETQ RAD (fetch RADIX of FMT))
(SETQ TEMP (IABS RAD))
(COND
((OR (IGREATERP 2 TEMP)
(IGREATERP TEMP 16))
(\ILLEGAL.ARG RAD)))
TEMP)
(T 10))
(OR (NULL RAD)
(IGREATERP RAD 0))
NIL \NUMSTR \NUMSTR1]
(SETQ PAD (COND
(WIDTH (IDIFFERENCE WIDTH (NCHARS STR)))
(T 0)))
[COND
([AND (IGREATERP PAD 0)
(OR FLOATFLAG (NULL (fetch LEFTFLUSH of FMT]
(COND
((COND
(FLOATFLAG (fetch (FLOATFMT PAD0) of FMT))
(T (fetch (FIXFMT PAD0) of FMT)))
(FRPTQ PAD (PRIN1 "0" FILE)))
(T (SPACES PAD FILE]
(PRIN1 STR FILE)
(COND
((AND (IGREATERP PAD 0)
(NOT FLOATFLAG)
(fetch LEFTFLUSH of FMT))
(SPACES PAD FILE)))
(RETURN NUMBER)))])
)
(DECLARE: EVAL@COMPILE
(PUTPROPS NUMFORMATCODE BYTEMACRO (= . PROG1))
)
(RPAQ? NILNUMPRINTFLG )
(MOVD? (QUOTE PRINTNUM)
(QUOTE FPRINTNUM))
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTPROPS .FILELINELENGTH. MACRO ((XOFD)
(COND ((IGREATERP (fetch (STREAM LINELENGTH)
of XOFD)
0)
(fetch (STREAM LINELENGTH)
of XOFD))
(T \LINELENGTH]
[PUTPROPS .SPACECHECK. MACRO ((STRM N)
(AND \THISFILELINELENGTH (IGREATERP (IPLUS N (fetch CHARPOSITION of STRM))
\THISFILELINELENGTH)
(FRESHLINE STRM]
(PUTPROPS \PRODUCECHAR MACRO ((X)
(SPREADAPPLY* FN X)))
)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS \THISFILELINELENGTH)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \CARPRINTLEVEL \TCARPRINTLEVEL \PRINTCRFLAG \CDRPRINTLEVEL \TCDRPRINTLEVEL \LINELENGTH
\FLOATFORMAT \PRINTRADIX \SIGNFLAG PRXFLG \DEFPRINTFNS \RADIX.PREFIX)
)
(PUTPROPS APRINT COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1408 15919 (PRIN1 1418 . 1929) (PRIN2 1931 . 2493) (PRIN3 2495 . 3058) (PRIN4 3060 .
3685) (PRINT 3687 . 4287) (PRINTCCODE 4289 . 4549) (PRINTLEVEL 4551 . 5135) (RADIX 5137 . 5436) (
SPACES 5438 . 5783) (TERPRI 5785 . 5972) (FRESHLINE 5974 . 6570) (DEFPRINT 6572 . 7014) (LINELENGTH
7016 . 7536) (\CKPOSBOUT 7538 . 7702) (\CKPOSSOUT 7704 . 7917) (\CONVERTNUMBER 7919 . 9625) (\LITPRIN
9627 . 11213) (\OUTCHAR 11215 . 11383) (\SOUT 11385 . 11549) (\PRINDATUM 11551 . 14371) (\PRINOTHER
14373 . 14657) (\PRINSTACKP 14659 . 15051) (\PRINSTRING 15053 . 15917)) (15920 17924 (\FILEOUTCHARFN
15930 . 17565) (\TTYOUTCHARFN 17567 . 17922)) (17925 22071 (\MAPCHARS 17935 . 18125) (\MAPCHARS1 18127
. 20488) (\PRODUCESTRING 20490 . 20662) (\PRODUCENUM 20664 . 20930) (\PRODUCEADDR 20932 . 21457) (
\MAPCHARSLIT 21459 . 22069)) (22398 25271 (FLTFMT 22408 . 22711) (\CHECKFLTFMT 22713 . 23166) (
NUMFORMATCODE 23168 . 23509) (PRINTNUM 23511 . 25269)))))
STOP