(FILECREATED "24-Mar-86 17:43:49" {ERIS}<LISPCORE>BVM>APRINT.;15 45252
changes to: (FNS \SYMBOL.ESCAPE.COUNT \PRINDATUM PNAMESTREAMP \CONVERTNUMBER)
(MACROS PNAMESTREAMP)
(RESOURCES \MAPPNAMESTREAM)
(VARS APRINTCOMS)
previous date: "14-Mar-86 14:17:07" {ERIS}<LISPCORE>BVM>APRINT.;12)
(* Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT APRINTCOMS)
(RPAQQ APRINTCOMS ((COMS (* User-level print functions)
(FNS PRIN1 PRIN2 PRIN3 PRIN4 PRINT PRINTCCODE PRINTLEVEL RADIX SPACES TERPRI
FRESHLINE DEFPRINT LINELENGTH))
(COMS (* PRINT internals)
(FNS \PRINDATUM \CKPOSBOUT \CKPOSSOUT \CONVERTNUMBER \LITPRIN
\SYMBOL.ESCAPE.COUNT \PRINSTACKP \PRINTADDR \PRINSTRING \SOUT \OUTCHAR
\FILEOUTCHARFN \TTYOUTCHARFN)
(DECLARE: DONTCOPY (MACROS .FILELINELENGTH. .SPACECHECK.))
(SPECVARS \THISFILELINELENGTH))
(COMS (* Internal printing)
(FNS \MAPPNAME PNAMESTREAMP)
(DECLARE: DONTCOPY (RESOURCES \MAPPNAMESTREAM)
(MACROS PNAMESTREAMP))
(INITRESOURCES \MAPPNAMESTREAM)
[INITVARS (\PNAMEDEVICE (NCREATE (QUOTE FDEV)
(\GETDEVICEFROMHOSTNAME (QUOTE NULL)
T]
(GLOBALVARS \PNAMEDEVICE))
(COMS (* Obsolete)
(FNS \MAPCHARS))
(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 (* PRINTNUM and friends)
(FNS PRINTNUM FLTFMT \CHECKFLTFMT NUMFORMATCODE)
(MACROS NUMFORMATCODE)
(INITVARS (NILNUMPRINTFLG)))
(LOCALVARS . T)
(GLOBALVARS \CARPRINTLEVEL \TCARPRINTLEVEL \PRINTCRFLAG \CDRPRINTLEVEL
\TCDRPRINTLEVEL \LINELENGTH \FLOATFORMAT \PRINTRADIX \SIGNFLAG PRXFLG
\DEFPRINTFNS \RADIX.PREFIX)))
(* User-level print functions)
(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) (* bvm:
"11-Mar-86 18:19")
(PROG ((STRM (\GETSTREAM FILE (QUOTE OUTPUT)))
\THISFILELINELENGTH)
(DECLARE (SPECVARS \THISFILELINELENGTH))
(SETQ \THISFILELINELENGTH (.FILELINELENGTH. STRM))
(SETQ \TCARPRINTLEVEL \CARPRINTLEVEL)
(SETQ \TCDRPRINTLEVEL \CDRPRINTLEVEL)
(\PRINDATUM X STRM (\GTREADTABLE RDTBL)
(COND
((OR (\OUTTERMP STRM)
PLVLFILEFLG)
0)))
(RETURN X])
(PRIN3
(LAMBDA (X FILE) (* lmm "17-Jan-86 22:00") (PROG (\THISFILELINELENGTH (\OFD (\GETSTREAM FILE (QUOTE OUTPUT)))) (DECLARE (SPECVARS \THISFILELINELENGTH)) (SETQ \TCARPRINTLEVEL \CARPRINTLEVEL) (SETQ \TCDRPRINTLEVEL \CDRPRINTLEVEL) (\PRINDATUM X \OFD NIL (COND ((OR (\OUTTERMP \OFD) PLVLFILEFLG) 0))) (RETURN X)))
)
(PRIN4
[LAMBDA (X FILE RDTBL) (* bvm:
"11-Mar-86 18:20")
(PROG ((STRM (\GETSTREAM FILE (QUOTE OUTPUT)))
\THISFILELINELENGTH)
(DECLARE (SPECVARS \THISFILELINELENGTH))
(SETQ \TCARPRINTLEVEL \CARPRINTLEVEL)
(SETQ \TCDRPRINTLEVEL \CDRPRINTLEVEL)
(\PRINDATUM X STRM (\GTREADTABLE RDTBL)
(COND
((OR (\OUTTERMP STRM)
PLVLFILEFLG)
0)))
(RETURN X])
(PRINT
[LAMBDA (X FILE RDTBL) (* bvm:
"11-Mar-86 18:19")
(PROG ((STRM (\GETSTREAM FILE (QUOTE OUTPUT)))
\THISFILELINELENGTH)
(DECLARE (SPECVARS \THISFILELINELENGTH))
(SETQ \THISFILELINELENGTH (.FILELINELENGTH. STRM))
(SETQ \TCARPRINTLEVEL \CARPRINTLEVEL)
(SETQ \TCDRPRINTLEVEL \CDRPRINTLEVEL)
(\PRINDATUM X STRM (\GTREADTABLE RDTBL)
(COND
((OR (\OUTTERMP STRM)
PLVLFILEFLG)
0)))
(\OUTCHAR STRM (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) (* bvm:
"11-Mar-86 14:56")
(* * Sets to N the linelength of FILE --
defaults to primary output file)
(LET [(STREAM (\GETSTREAM FILE (QUOTE OUTPUT]
(PROG1 (fetch (STREAM LINELENGTH) of STREAM)
(AND N (COND
((AND (NUMBERP N)
(ILESSP N 1))
(\ILLEGAL.ARG N))
(T (replace (STREAM LINELENGTH) of STREAM with (COND
((EQ N T)
(* Infinite)
MAX.SMALLP)
(T (FIX N])
)
(* PRINT internals)
(DEFINEQ
(\PRINDATUM
[LAMBDA (X STREAM RDTBL CPL) (* bvm:
"24-Mar-86 17:43")
(* * CPL is the current printing level, NIL if print-level should be
ignored)
(SELECTC (NTYPX X)
(\LITATOM (\LITPRIN X RDTBL 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 RDTBL CPL)
(COND
[(NLISTP (CDR X))
(COND
((SETQ X (CDR X))
(\CKPOSSOUT STREAM (QUOTE " . "))
(\PRINDATUM X STREAM RDTBL 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)
(WITH-RESOURCES (\NUMSTR \NUMSTR1)
(\CKPOSSOUT STREAM (\CONVERTNUMBER X (COND
((AND (PNAMESTREAMP STREAM)
(NOT PRXFLG))
(* The pname of a number
is unaffected by RADIX
unless PRXFLG is true.
This seems silly, but
assorted code will break
otherwise)
10)
(T \PRINTRADIX))
T RDTBL \NUMSTR \NUMSTR1))))
(\FLOATP [WITH-RESOURCES (\NUMSTR \NUMSTR1)
(\CKPOSSOUT STREAM (\CONVERT.FLOATING.NUMBER X \NUMSTR \NUMSTR1
(COND
((AND (PNAMESTREAMP STREAM)
(NOT PRXFLG)) (* The pname of a number
is unaffected by RADIX
unless PRXFLG is true.
This seems silly, but
assorted code will break
otherwise)
T)
(T \FLOATFORMAT])
(\STRINGP (\PRINSTRING X STREAM RDTBL))
(\STACKP (\PRINSTACKP X STREAM))
(LET*[(TYPE (TYPENAME X))
(FN (CDR (FASSOC TYPE \DEFPRINTFNS]
(COND
([OR (NULL FN)
(NULL (SETQ FN (APPLY* FN X (fetch FULLNAME of STREAM]
(\CKPOSBOUT STREAM (CHARCODE {))
(AND TYPE (\LITPRIN TYPE NIL STREAM))
(\CKPOSBOUT STREAM (CHARCODE }))
(\PRINTADDR X STREAM))
((LISTP FN)
(AND (CAR FN)
(\PRINDATUM (CAR FN)
STREAM NIL CPL))
(AND (CDR FN)
(\PRINDATUM (CDR FN)
STREAM RDTBL CPL])
(\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 IGNORE RDTBL NS NSB) (* bvm:
"15-Mar-86 23:07")
(* * Convert integer N to a string in radix R.
RDTBL governs whether radix qualifiers appear.
NS is a scratch promised to be of sufficient length;
NSB is a scratch string pointer. IGNORE is obsolete flag for printing
unsigned numbers)
(COND
((EQ N 0)
"0")
(T (LET*((SIGN)
[X (COND
((GEQ N 0)
N)
(T (SETQ SIGN (IMINUS N]
[POS (\NSTRINGCHARS (\DTEST NS (QUOTE STRINGP]
(END (SUB1 POS))
DIDQ)
(COND
((AND (EQ R 8)
RDTBL
(NOT (fetch (READTABLEP COMMONLISP) of RDTBL))
(IGREATERP X 7)) (* Octal numbers have Q
suffix)
(RPLCHARCODE NS (add END 1)
(CHARCODE Q))
(SETQ DIDQ T)))
(repeatuntil (EQ X 0) do [RPLCHARCODE NS (add POS -1)
(LET ((DIGIT (IREMAINDER X R)))
(COND
((ILESSP DIGIT 10)
(IPLUS DIGIT (CHARCODE 0)))
(T (* For radices higher
than 10, use letters of
alphabet from A on up)
(IPLUS (IDIFFERENCE DIGIT 10)
(CHARCODE A]
(SETQ X (IQUOTIENT X R)))
[COND
(SIGN (RPLCHARCODE NS (add POS -1)
(CHARCODE -]
[COND
((AND (NEQ R 10)
RDTBL
(NOT DIDQ)
(OR (GREATERP N 9)
(GEQ N R))) (* Prepend a radix
qualifier)
[SELECTQ R
(16 (RPLCHARCODE NS (add POS -1)
(CHARCODE x)))
(8 (RPLCHARCODE NS (add POS -1)
(CHARCODE o)))
(2 (RPLCHARCODE NS (add POS -1)
(CHARCODE b)))
(PROGN (RPLCHARCODE NS (add POS -1)
(CHARCODE r))
(RPLCHARCODE NS (add POS -1)
(IPLUS (CHARCODE 0)
(IMOD R 10)))
(COND
((GEQ R 10)
(RPLCHARCODE NS (add POS -1)
(IPLUS (CHARCODE 0)
(IQUOTIENT R 10]
(RPLCHARCODE NS (add POS -1)
(fetch (READTABLEP HASHMACROCHAR) of RDTBL]
(SUBSTRING NS POS END NSB])
(\LITPRIN
[LAMBDA (X RDTBL STREAM) (* bvm:
"14-Mar-86 13:51")
(DECLARE (USEDFREE \THISFILELINELENGTH))
(COND
[RDTBL
(COND
((EQ X (QUOTE %.)) (* Special case because
%. is only important in
isolation)
(.SPACECHECK. STREAM 2)
(\OUTCHAR STREAM (fetch (READTABLEP ESCAPECHAR) of RDTBL))
(\OUTCHAR STREAM (CHARCODE ".")))
(T (LET ((ESCAPE (fetch (READTABLEP ESCAPECHAR) of RDTBL))
(MULTESCAPE (fetch (READTABLEP MULTESCAPECHAR) of RDTBL))
USEMULTESCAPE CASEBASE SA SYN NESCAPES CHECKESCAPE FIRSTESCAPE)
(COND
[(OR \THISFILELINELENGTH (NEQ MULTESCAPE 0)) (* have to check now if
linelength matters or we
plan to use multiple
escapes)
(SETQ NESCAPES (\SYMBOL.ESCAPE.COUNT X RDTBL (NULL \THISFILELINELENGTH)))
(COND
((AND NIL (EQ NESCAPES -1)) (* Pname is numeric and
we don't have a multiple
escape available--need
to escape first char)
(SETQ NESCAPES 1)
(SETQ FIRSTESCAPE T))
((ILESSP NESCAPES 0) (* Use multiple escapes)
(SETQ NESCAPES (IMINUS NESCAPES))
(SETQ USEMULTESCAPE T))
((NEQ NESCAPES 0)
(SETQ CHECKESCAPE T]
(T (* if we don't check now
then have to check while
printing)
(SETQ CHECKESCAPE T)))
(.SPACECHECK. STREAM (IPLUS (\NATOMCHARS X)
NESCAPES))
(COND
((AND NIL FIRSTESCAPE) (* Need an escape
character at start to
keep atom from being
interpreted as number)
(\OUTCHAR STREAM ESCAPE)))
(COND
(USEMULTESCAPE (* Surround pname with
multiple escape char,
only escape internal
escapes)
(\OUTCHAR STREAM MULTESCAPE)
(for C inatom X do (COND
((OR (EQ C MULTESCAPE)
(EQ C ESCAPE))
(\OUTCHAR STREAM ESCAPE)))
(\OUTCHAR STREAM C))
(\OUTCHAR STREAM MULTESCAPE))
(T [COND
(CHECKESCAPE (SETQ CASEBASE (AND (fetch (READTABLEP CASEINSENSITIVE)
of RDTBL)
(fetch (ARRAYP BASE) of UPPERCASEARRAY))
)
(SETQ SA (fetch READSA of RDTBL]
(for C inatom X bind (FIRSTFLG ← T)
do (COND
([AND CHECKESCAPE (OR (AND CASEBASE (ILEQ C \MAXTHINCHAR)
(NEQ C (\GETBASEBYTE CASEBASE C)))
(AND (fetch (READCODE ESCQUOTE)
of (SETQ SYN (\SYNCODE SA C)))
(OR FIRSTFLG (fetch (READCODE
INNERESCQUOTE
)
of SYN]
(* Need to escape if:
character is lower case
when case-insensitive,
or character
intrinsically needs
escape.)
(\OUTCHAR STREAM ESCAPE)))
(\OUTCHAR STREAM C)
(SETQ FIRSTFLG NIL]
(T (.SPACECHECK. STREAM (\NATOMCHARS X))
(for C inatom X do (\OUTCHAR STREAM C])
(\SYMBOL.ESCAPE.COUNT
[LAMBDA (X RDTBL INEXACTOK ESCWIDTH MULTESCWIDTH) (* bvm:
"24-Mar-86 17:16")
(* * Counts the number of escape characters needed to print X by RDTBL.
If RDTBL has a multiple-escape character, then we return a negative count
if we're assuming it is used instead of single escapes;
else a positive count. If INEXACTOK is true and we discover we want to use
multiple escape char, returns -2 immediately.
If ESCWIDTH is non-null, it is the width of the escape character, and we
instead return the cumulative width of all escapes.
In this case, MULTESCWIDTH is optionally the width of the multiple-escape
char)
(COND
((EQ X (QUOTE %.))
1)
(T (for C inatom X bind (RESULT ← 0)
(NESCAPES ← 0)
(FIRSTFLG ← T)
(MULTESCAPE ←(fetch (READTABLEP MULTESCAPECHAR) of RDTBL))
(ESCAPE ←(fetch (READTABLEP ESCAPECHAR) of RDTBL))
(CASEBASE ←(AND (fetch (READTABLEP CASEINSENSITIVE) of RDTBL)
(fetch (ARRAYP BASE) of UPPERCASEARRAY)))
(SA ←(fetch READSA of RDTBL))
SYN first (COND
((OR (EQ MULTESCAPE 0)
(AND ESCWIDTH (NULL MULTESCWIDTH)))
(* Can't use
multiple-escape)
(SETQ MULTESCAPE NIL)))
do [COND
([OR (AND CASEBASE (ILEQ C \MAXTHINCHAR)
(NEQ C (\GETBASEBYTE CASEBASE C)))
(AND (fetch (READCODE ESCQUOTE) of (SETQ SYN (\SYNCODE SA C)))
(OR FIRSTFLG (fetch (READCODE INNERESCQUOTE) of SYN]
(* Need protection if
char is lowercase in a
case-insensitive read
table or the read table
says it needs it)
(add RESULT 1)
(COND
(MULTESCAPE (COND
((OR (EQ C MULTESCAPE)
(EQ C ESCAPE)) (* These have to be
escaped no matter what)
(add NESCAPES 1))
((AND INEXACTOK (GREATERP (DIFFERENCE RESULT NESCAPES)
1)) (* If at least 2 chars
need escaping, better to
use multiple escape, and
we can quit scanning now)
(RETURN -2]
(SETQ FIRSTFLG NIL) finally (COND
((AND NIL MULTESCAPE (EQ RESULT 0))
(* Test here for pname
being numeric)
))
(RETURN (COND
[(AND MULTESCAPE (GREATERP (DIFFERENCE RESULT
NESCAPES)
1))
(* The number of characters needing escaping, not counting the ones that
have to be escaped in any case, is at least two.
Use two multiple-escapes and NESCAPES regular escapes for the internal
escapes)
(COND
(ESCWIDTH (IPLUS (ITIMES MULTESCWIDTH 2)
(ITIMES ESCWIDTH NESCAPES))
)
(T (* "-(NESCAPES+2)" total
extra characters)
(IDIFFERENCE -2 NESCAPES]
(T (COND
(ESCWIDTH (ITIMES RESULT ESCWIDTH))
(T RESULT])
(\PRINSTACKP
[LAMBDA (X STREAM) (* bvm:
"12-Mar-86 15:25")
(* * Print stackp as addr/framename. If stackp is released or framename is
not a symbol, print mumble)
[.SPACECHECK. STREAM (IPLUS 1 (PROGN (* Longest stack address
is "177,177777")
10)
1
(COND
((RELSTKP X)
2)
((LITATOM (STKNAME X))
(\NATOMCHARS (STKNAME X)))
(T 6]
(\PRINTADDR X STREAM)
(\OUTCHAR STREAM (CHARCODE /))
(COND
((RELSTKP X)
(\SOUT "#0" STREAM))
((LITATOM (SETQ X (STKNAME X)))
(\LITPRIN X NIL STREAM))
(T (\SOUT "*form*" STREAM])
(\PRINTADDR
[LAMBDA (X STREAM) (* bvm:
"12-Mar-86 12:26")
(\CKPOSBOUT STREAM (CHARCODE #))
(WITH-RESOURCES (\NUMSTR \NUMSTR1)
(SELECTQ (SYSTEMTYPE)
(D (\CKPOSSOUT STREAM (\CONVERTNUMBER (\HILOC X)
8 NIL NIL \NUMSTR \NUMSTR1))
(\CKPOSBOUT STREAM (CHARCODE ,))
(\CKPOSSOUT STREAM (\CONVERTNUMBER (\LOLOC X)
8 NIL NIL \NUMSTR \NUMSTR1)))
(JERICHO (\CKPOSSOUT STREAM (\CONVERTNUMBER (LOGAND \ADDRMASK (LOC X))
8 NIL NIL \NUMSTR \NUMSTR1)))
(VAX (\CKPOSSOUT STREAM (\CONVERTNUMBER (LOC X)
16 T NIL \NUMSTR \NUMSTR1)))
((TENEX TOPS-20)
(\CKPOSSOUT STREAM (\CONVERTNUMBER (LOC X)
8 T NIL \NUMSTR \NUMSTR1)))
(SYSTEMTYPEPUNT (QUOTE (\PRINDATUM X])
(\PRINSTRING
[LAMBDA (X STREAM RDTBL) (* bvm:
"12-Mar-86 14:39")
(COND
[RDTBL (* Print with double
quotes and escaped as
needed)
(LET ((ESC (fetch (READTABLEP ESCAPECHAR) of RDTBL)))
[.SPACECHECK. STREAM (IPLUS 2 (\NSTRINGCHARS X)
(for C instring X
count (OR (EQ C (CHARCODE %"))
(EQ C ESC]
(\OUTCHAR STREAM (CHARCODE %"))
(for C instring X do (COND
((OR (EQ C (CHARCODE %"))
(EQ C (CHARCODE LF))
(EQ C ESC)) (* VM says only %" is
escaped no matter what
stringdelim's are.)
(\OUTCHAR STREAM ESC)))
(\OUTCHAR STREAM C))
(\OUTCHAR STREAM (CHARCODE %"]
(T (.SPACECHECK. STREAM (\NSTRINGCHARS X))
(\SOUT X STREAM])
(\SOUT
[LAMBDA (X STREAM) (* rmk: "21-OCT-83 12:32")
(for I instring X do (\OUTCHAR STREAM I])
(\OUTCHAR
[LAMBDA (STREAM CHARCODE) (* rmk: " 7-APR-82 00:25")
(STREAMOP (QUOTE OUTCHARFN)
STREAM STREAM CHARCODE])
(\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])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTPROPS .FILELINELENGTH. MACRO ((STRM)
(LET ((L (fetch (STREAM LINELENGTH)
of STRM)))
(SELECTC L (0 (* Some default)
\LINELENGTH)
(MAX.SMALLP (* Infinite)
NIL)
L]
[PUTPROPS .SPACECHECK. MACRO ((STRM N)
(AND \THISFILELINELENGTH (IGREATERP (IPLUS N (fetch CHARPOSITION of
STRM))
\THISFILELINELENGTH)
(FRESHLINE STRM]
)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS \THISFILELINELENGTH)
)
(* Internal printing)
(DEFINEQ
(\MAPPNAME
[LAMBDA (FN X FLG RDTBL) (* bvm:
"12-Mar-86 14:33")
(* * Run thru the characters in the pname of X, calling FN on each
character. For speed, FN is defined to be of the same form as an
OUTCHARFN, viz., arglist = (stream char);
stream in this case is a dummy)
(WITH-RESOURCE (\MAPPNAMESTREAM)
(replace OUTCHARFN of \MAPPNAMESTREAM with FN)
(replace STRMBOUTFN of \MAPPNAMESTREAM with FN) (* Should never use the
bout fn, but include it
just in case somebody
thinks \OUTCHAR = \BOUT)
(LET (\THISFILELINELENGTH)
(DECLARE (SPECVARS \THISFILELINELENGTH)) (* Stream has no
linelength checks,
please)
(\PRINDATUM X \MAPPNAMESTREAM (AND FLG (\GTREADTABLE RDTBL])
(PNAMESTREAMP
[LAMBDA (STRM) (* bvm:
"24-Mar-86 17:37")
(* * True if STRM is an internal-printing stream for pnames, i.e., one of
the values of the \MAPPNAMESTREAM resource)
(AND (TYPENAMEP STRM (QUOTE STREAM))
(EQ (fetch (STREAM DEVICE) of STRM)
\PNAMEDEVICE])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTDEF (QUOTE \MAPPNAMESTREAM)
(QUOTE RESOURCES)
(QUOTE (NEW (create STREAM DEVICE ← \PNAMEDEVICE ACCESSBITS ← OutputBits LINELENGTH ←
MAX.SMALLP]
)
(DECLARE: EVAL@COMPILE
(PUTPROPS PNAMESTREAMP DMACRO ((STRM)
(EQ (fetch (STREAM DEVICE)
of STRM)
\PNAMEDEVICE)))
)
)
(/SETTOPVAL (QUOTE \\MAPPNAMESTREAM.GLOBALRESOURCE))
(RPAQ? \PNAMEDEVICE (NCREATE (QUOTE FDEV)
(\GETDEVICEFROMHOSTNAME (QUOTE NULL)
T)))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \PNAMEDEVICE)
)
(* Obsolete)
(DEFINEQ
(\MAPCHARS
[LAMBDA (\MAPCHARFN X FLG RDTBL) (* bvm:
"13-Mar-86 18:53")
(DECLARE (SPECVARS RDTBL))
(* * Run thru the characters in the pname of X, calling \MAPCHARFN on each
character.)
(\MAPPNAME [FUNCTION (LAMBDA (DUMMY CHAR)
(SPREADAPPLY* \MAPCHARFN CHAR]
X FLG RDTBL])
)
(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 "|"))
(* PRINTNUM and friends)
(DEFINEQ
(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)))])
(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])
)
(DECLARE: EVAL@COMPILE
(PUTPROPS NUMFORMATCODE BYTEMACRO (= . PROG1))
)
(RPAQ? NILNUMPRINTFLG )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(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 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2834 9514 (PRIN1 2844 . 3355) (PRIN2 3357 . 4051) (PRIN3 4053 . 4371) (PRIN4 4373 .
5006) (PRINT 5008 . 5747) (PRINTCCODE 5749 . 6009) (PRINTLEVEL 6011 . 6595) (RADIX 6597 . 6896) (
SPACES 6898 . 7243) (TERPRI 7245 . 7432) (FRESHLINE 7434 . 8030) (DEFPRINT 8032 . 8474) (LINELENGTH
8476 . 9512)) (9543 37418 (\PRINDATUM 9553 . 15169) (\CKPOSBOUT 15171 . 15335) (\CKPOSSOUT 15337 .
15550) (\CONVERTNUMBER 15552 . 19149) (\LITPRIN 19151 . 25452) (\SYMBOL.ESCAPE.COUNT 25454 . 31038) (
\PRINSTACKP 31040 . 32194) (\PRINTADDR 32196 . 33406) (\PRINSTRING 33408 . 35086) (\SOUT 35088 . 35252
) (\OUTCHAR 35254 . 35422) (\FILEOUTCHARFN 35424 . 37059) (\TTYOUTCHARFN 37061 . 37416)) (38413 40295
(\MAPPNAME 38423 . 39807) (PNAMESTREAMP 39809 . 40293)) (41045 41553 (\MAPCHARS 41055 . 41551)) (41913
44786 (PRINTNUM 41923 . 43681) (FLTFMT 43683 . 43986) (\CHECKFLTFMT 43988 . 44441) (NUMFORMATCODE
44443 . 44784)))))
STOP