(FILECREATED "15-Sep-86 18:18:08" {ERIS}<LISPCORE>SOURCES>APRINT.;42 74492
changes to: (FNS \TTYOUTCHARFN)
previous date: "10-Sep-86 21:47:42" {ERIS}<LISPCORE>SOURCES>APRINT.;41)
(* 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))
(* JRB: I don't understand how this ever worked without a FIRST...)
(DECLARE: FIRST (INITVARS (PLVLFILEFLG NIL)
(\LINELENGTH 82)
(\FLOATFORMAT T)
(PRXFLG NIL)
(*PRINT-BASE* 10)
(*READ-BASE* 10)
(*PRINT-RADIX* NIL)
(*PRINT-ESCAPE* T)
(*PRINT-CASE* (QUOTE :UPCASE))
(*PRINT-GENSYM* T)
(*PRINT-LEVEL* NIL)
(*PRINT-LENGTH* NIL)
(*PRINT-PRETTY* NIL)
(*PRINT-CIRCLE* NIL)
(*PRINT-ARRAY* NIL)
(*PRINT-CIRCLE-HASHTABLE* NIL)
(*PACKAGE* NIL)
(*KEYWORD-PACKAGE* NIL)
(\DEFPRINTFNS NIL)))
(COMS (* PRINT internals)
(FNS PRINT-CIRCLE-LOOKUP PRINT-CIRCLE-LABEL-P PRINT-CIRCLE-SCAN PRINT-CIRCLE-ENTER)
(FNS \PRINDATUM \ELIDE.PRINT.ELEMENT \ELIDE.ELEMENT.CHAR \ELIDE.PRINT.TAIL
\ELIDE.TAIL.STRING \CKPOSBOUT \CKPOSSOUT \CONVERTNUMBER \LITPRIN \LITPRIN.INTERNAL
\SYMBOL.ESCAPE.COUNT \NUMERIC.PNAMEP \PRINSTACKP \PRINTADDR \PRINSTRING \SOUT
\OUTCHAR \FILEOUTCHARFN \TTYOUTCHARFN)
(DECLARE: DONTCOPY (MACROS .FILELINELENGTH.))
(DECLARE: EVAL@COMPILE DONTCOPY (EXPORT (MACROS .SPACECHECK. \CHECKRADIX)))
(FNS \INVALID.RADIX)
(SPECVARS \THISFILELINELENGTH))
(COMS (* Internal printing)
(FNS \MAPPNAME \MAPPNAME.INTERNAL PNAMESTREAMP)
(DECLARE: DONTCOPY (RESOURCES \MAPPNAMESTREAM)
(MACROS PNAMESTREAMP))
(INITRESOURCES \MAPPNAMESTREAM)
(INITVARS (\PNAMEDEVICE (NCREATE (QUOTE FDEV)
(\GETDEVICEFROMHOSTNAME (QUOTE NULL)
T))))
(GLOBALVARS \PNAMEDEVICE))
(COMS (* Obsolete)
(FNS \MAPCHARS))
(DECLARE: EVAL@COMPILE DOCOPY
(ADDVARS (SYSSPECVARS *PRINT-BASE* *READ-BASE* *PRINT-RADIX* *PRINT-ESCAPE*
*PRINT-CASE* *PRINT-GENSYM* *PRINT-LEVEL* *PRINT-LENGTH*
*PRINT-PRETTY* *PRINT-CIRCLE* *PRINT-ARRAY* *PACKAGE*)))
(COMS (* PRINTNUM and friends)
(FNS PRINTNUM FLTFMT \CHECKFLTFMT NUMFORMATCODE)
(MACROS NUMFORMATCODE)
(INITVARS (NILNUMPRINTFLG)))
(LOCALVARS . T)
(GLOBALVARS \LINELENGTH \FLOATFORMAT PRXFLG \DEFPRINTFNS)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA PRINT-CIRCLE-ENTER PRINT-CIRCLE-SCAN PRINT-CIRCLE-LABEL-P
PRINT-CIRCLE-LOOKUP)))))
(* User-level print functions)
(DEFINEQ
(PRIN1
(LAMBDA (X FILE) (* bvm: "11-May-86 15:23")
(* * Like PRIN2 but no escaping. Also implies no radix qualifiers, although
Common Lisp separates *PRINT-RADIX* from *PRINT-ESCAPE* --
might want to bind *PRINT-RADIX* to (AND
(fetch (READTABLEP COMMONLISP) of *READTABLE*) *PRINT-RADIX*))
(LET* ((STRM (\GETSTREAM FILE (QUOTE OUTPUT)))
(OBEY-PRINT-LEVEL (OR (ffetch (READTABLEP COMMONLISP)
of
(\DTEST *READTABLE* (QUOTE READTABLEP)))
(OR (\OUTTERMP STRM)
PLVLFILEFLG))))
(LET ((*PRINT-ESCAPE* NIL)
(*PRINT-RADIX* NIL)
(*PRINT-LEVEL* (AND OBEY-PRINT-LEVEL *PRINT-LEVEL*))
(*PRINT-LENGTH* (AND OBEY-PRINT-LEVEL *PRINT-LENGTH*))
\THISFILELINELENGTH)
(DECLARE (SPECVARS *PRINT-RADIX* *PRINT-ESCAPE* *PRINT-LEVEL* *PRINT-LENGTH*
\THISFILELINELENGTH))
(SETQ \THISFILELINELENGTH (.FILELINELENGTH. STRM))
(\PRINDATUM X STRM 0)
X))))
(PRIN2
(LAMBDA (X FILE RDTBL) (* bvm: "11-May-86 15:23")
(LET* ((STRM (\GETSTREAM FILE (QUOTE OUTPUT)))
(OBEY-PRINT-LEVEL (OR (fetch (READTABLEP COMMONLISP)
of
(SETQ RDTBL (\GTREADTABLE RDTBL)))
(OR (\OUTTERMP STRM)
PLVLFILEFLG))))
(LET ((*READTABLE* RDTBL)
(*PRINT-ESCAPE* T)
(*PRINT-RADIX* (NEQ *PRINT-BASE* 10))
(*PRINT-LEVEL* (AND OBEY-PRINT-LEVEL *PRINT-LEVEL*))
(*PRINT-LENGTH* (AND OBEY-PRINT-LEVEL *PRINT-LENGTH*))
\THISFILELINELENGTH)
(DECLARE (SPECVARS *PRINT-RADIX* *PRINT-ESCAPE* *READTABLE* *PRINT-LEVEL*
*PRINT-LENGTH* \THISFILELINELENGTH))
(SETQ \THISFILELINELENGTH (.FILELINELENGTH. STRM))
(\PRINDATUM X STRM 0)
X))))
(PRIN3
(LAMBDA (X FILE) (* bvm: "11-May-86 15:23")
(* * Like PRIN1 but no linelength checking)
(LET* ((STRM (\GETSTREAM FILE (QUOTE OUTPUT)))
(OBEY-PRINT-LEVEL (OR (ffetch (READTABLEP COMMONLISP)
of
(\DTEST *READTABLE* (QUOTE READTABLEP)))
(OR (\OUTTERMP STRM)
PLVLFILEFLG))))
(LET ((*PRINT-ESCAPE* NIL)
(*PRINT-RADIX* NIL)
(*PRINT-LEVEL* (AND OBEY-PRINT-LEVEL *PRINT-LEVEL*))
(*PRINT-LENGTH* (AND OBEY-PRINT-LEVEL *PRINT-LENGTH*))
\THISFILELINELENGTH)
(DECLARE (SPECVARS *PRINT-RADIX* *PRINT-ESCAPE* *PRINT-LEVEL* *PRINT-LENGTH*
\THISFILELINELENGTH))
(\PRINDATUM X STRM 0)
X))))
(PRIN4
(LAMBDA (X FILE RDTBL) (* bvm: "11-May-86 15:24")
(* * Like PRIN2 but doesn't check linelength)
(LET* ((STRM (\GETSTREAM FILE (QUOTE OUTPUT)))
(OBEY-PRINT-LEVEL (OR (fetch (READTABLEP COMMONLISP)
of
(SETQ RDTBL (\GTREADTABLE RDTBL)))
(OR (\OUTTERMP STRM)
PLVLFILEFLG))))
(LET ((*READTABLE* RDTBL)
(*PRINT-ESCAPE* T)
(*PRINT-RADIX* (NEQ *PRINT-BASE* 10))
(*PRINT-LEVEL* (AND OBEY-PRINT-LEVEL *PRINT-LEVEL*))
(*PRINT-LENGTH* (AND OBEY-PRINT-LEVEL *PRINT-LENGTH*))
\THISFILELINELENGTH)
(DECLARE (SPECVARS *PRINT-RADIX* *PRINT-ESCAPE* *READTABLE* *PRINT-LEVEL*
*PRINT-LENGTH* \THISFILELINELENGTH))
(\PRINDATUM X STRM 0)
X))))
(PRINT
(LAMBDA (X FILE RDTBL) (* bvm: " 9-May-86 23:08")
(LET ((STRM (\GETSTREAM FILE (QUOTE OUTPUT))))
(PRIN2 X STRM RDTBL)
(\OUTCHAR STRM (CHARCODE EOL))
X)))
(PRINTCCODE
(LAMBDA (CHARCODE FILE) (* bvm: " 9-May-86 22:44")
(\OUTCHAR (\GETSTREAM FILE (QUOTE OUTPUT))
(COND
((\CHARCODEP CHARCODE)
CHARCODE)
(T (\ILLEGAL.ARG CHARCODE))))))
(PRINTLEVEL
(LAMBDA (CARVAL CDRVAL) (* bvm: " 9-May-86 22:47")
(* * Sets Interlisp print level to the given values in CAR and CDR directions.
These correspond to *PRINT-LEVEL* and *PRINT-LENGTH* in Common Lisp)
(COND
((LISTP CARVAL)
(SETQ CDRVAL (CDR CARVAL))
(SETQ CARVAL (CAR CARVAL))))
(PROG1 (CONS (OR *PRINT-LEVEL* -1)
(OR *PRINT-LENGTH* -1))
(COND
(CARVAL (SETQ *PRINT-LEVEL* (AND (IGEQ CARVAL 0)
CARVAL))))
(COND
(CDRVAL (SETQ *PRINT-LENGTH* (AND (IGEQ CDRVAL 0)
CDRVAL)))))))
(RADIX
(LAMBDA (N) (* bvm: " 5-May-86 10:56")
(PROG1 *PRINT-BASE* (AND N (SETQ *PRINT-BASE* (\CHECKRADIX 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")
(COND
((NEQ 0 (fetch CHARPOSITION of (COND
((AND (type? STREAM STREAM)
(WRITEABLE STREAM))
STREAM)
(T (SETQ STREAM (GETSTREAM STREAM (QUOTE OUTPUT)))))))
(\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)))))))))))
)
(* JRB: I don't understand how this ever worked without a FIRST...)
(DECLARE: FIRST
(RPAQ? PLVLFILEFLG NIL)
(RPAQ? \LINELENGTH 82)
(RPAQ? \FLOATFORMAT T)
(RPAQ? PRXFLG NIL)
(RPAQ? *PRINT-BASE* 10)
(RPAQ? *READ-BASE* 10)
(RPAQ? *PRINT-RADIX* NIL)
(RPAQ? *PRINT-ESCAPE* T)
(RPAQ? *PRINT-CASE* (QUOTE :UPCASE))
(RPAQ? *PRINT-GENSYM* T)
(RPAQ? *PRINT-LEVEL* NIL)
(RPAQ? *PRINT-LENGTH* NIL)
(RPAQ? *PRINT-PRETTY* NIL)
(RPAQ? *PRINT-CIRCLE* NIL)
(RPAQ? *PRINT-ARRAY* NIL)
(RPAQ? *PRINT-CIRCLE-HASHTABLE* NIL)
(RPAQ? *PACKAGE* NIL)
(RPAQ? *KEYWORD-PACKAGE* NIL)
(RPAQ? \DEFPRINTFNS NIL)
)
(* PRINT internals)
(DEFINEQ
(PRINT-CIRCLE-LOOKUP
(CL:LAMBDA (OBJECT)
(DECLARE (SPECVARS *PRINT-CIRCLE-HASHTABLE* *PRINT-CIRCLE-NUMBER* *READTABLE*))
(* jrb: "17-Jun-86 13:51")
(CL:BLOCK PRINT-CIRCLE-LOOKUP (* jrb: " 9-Jun-86 18:21")
(LET ((TABLEENTRY (GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)))
(CASE TABLEENTRY (T1 (VALUES NIL NIL))
(T2 (VALUES (PROG1 (CONCAT (CHARACTER (fetch (READTABLEP HASHMACROCHAR)
of *READTABLE*))
*PRINT-CIRCLE-NUMBER* "=")
(SETF (GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)
*PRINT-CIRCLE-NUMBER*)
(INCF *PRINT-CIRCLE-NUMBER*))
T))
(OTHERWISE (CL:IF (NUMBERP TABLEENTRY)
(VALUES (CONCAT (CHARACTER (fetch (READTABLEP
HASHMACROCHAR)
of *READTABLE*))
TABLEENTRY "#")
NIL)
(CL:ERROR "Print-circle-lookup hashtable error!"))))))))
(PRINT-CIRCLE-LABEL-P
(CL:LAMBDA (OBJECT) (* jrb: "30-Jun-86 23:04")
(DECLARE (SPECIAL *PRINT-CIRCLE-HASHTABLE*))
(CL:BLOCK PRINT-CIRCLE-LABEL-P (LET ((TABLEENTRY (GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)))
(COND
((EQ TABLEENTRY (QUOTE T2)))
((INTEGERP TABLEENTRY)
TABLEENTRY)
(T NIL))))))
(PRINT-CIRCLE-SCAN
(CL:LAMBDA (OBJECT) (* jrb: "17-Jun-86 13:56")
(DECLARE (SPECIAL *PRINT-ARRAY*))
(CL:BLOCK PRINT-CIRCLE-SCAN (TYPECASE OBJECT (CONS (CL:WHEN (NOT (PRINT-CIRCLE-ENTER OBJECT)
)
(PRINT-CIRCLE-SCAN (CAR OBJECT))
(PRINT-CIRCLE-SCAN (CDR OBJECT))))
((ARRAY T)
(CL:WHEN (AND *PRINT-ARRAY* (NOT (PRINT-CIRCLE-ENTER
OBJECT)))
(*
"No need to walk array if we're not printing them")
(LET* ((ASIZE (ARRAY-TOTAL-SIZE OBJECT))
(VARRAY (CL:IF (> (ARRAY-RANK OBJECT)
1)
(MAKE-ARRAY ASIZE
:DISPLACED-TO OBJECT
)
OBJECT)))
(DOTIMES (X ASIZE)
(PRINT-CIRCLE-SCAN (AREF VARRAY X)))
)))))))
(PRINT-CIRCLE-ENTER
(CL:LAMBDA (OBJECT)
(DECLARE (SPECIAL *PRINT-CIRCLE-HASHTABLE* THERE-ARE-CIRCLES))
(* jrb: "17-Jun-86 13:59")
(CL:BLOCK PRINT-CIRCLE-ENTER (* jrb: " 9-Jun-86 18:26")
(CASE (GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)
(NIL (SETF (GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)
(QUOTE T1))
NIL)
(T1 (SETF (GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)
(QUOTE T2))
(SETQ THERE-ARE-CIRCLES T)
T)
(T2 T)
(OTHERWISE (CL:ERROR "Print-circle-enter hashtable error!"))))))
)
(DEFINEQ
(\PRINDATUM
(LAMBDA (X STREAM CPL) (* gbn " 7-Aug-86 16:20")
(SELECTC (NTYPX X)
(\LITATOM (\LITPRIN X STREAM))
(\LISTP (OR CPL (SETQ CPL 0))
(LET (LABEL FIRSTTIME)
(if *PRINT-CIRCLE-HASHTABLE* then (MULTIPLE-VALUE-SETQ (LABEL FIRSTTIME)
(PRINT-CIRCLE-LOOKUP X)))
(if LABEL then (\CKPOSSOUT STREAM LABEL)
(CL:WHEN FIRSTTIME (\CKPOSBOUT STREAM (CHARCODE SPACE))))
(COND
((AND LABEL (NOT FIRSTTIME)) (* Second reference -
just print label)
NIL)
((AND *PRINT-LEVEL* (ILEQ *PRINT-LEVEL* CPL))
(\ELIDE.PRINT.ELEMENT STREAM))
(T (PROG (CDRCNT)
(COND
(*PRINT-LENGTH* (SETQ CDRCNT (COND
((fetch (READTABLEP COMMONLISP)
of *READTABLE*)
0)
(T
(* Interlisp print depth is
triangular, Common Lisp isn't)
(COND
((IGEQ CPL *PRINT-LENGTH*)
(* We would just print "(--)" so it's
nicer to print "&")
(RETURN (
\ELIDE.PRINT.ELEMENT
STREAM))))
CPL)))))
(add CPL 1) (* Recursive calls will be at 1
greater depth)
(\CKPOSBOUT STREAM (CHARCODE %())
LP (COND
((AND CDRCNT (IGREATERP (add CDRCNT 1)
*PRINT-LENGTH*))
(* have printed as many elements as
allowed)
(\ELIDE.PRINT.TAIL STREAM T))
(T (\PRINDATUM (CAR X)
STREAM CPL)
(COND
((LISTP (SETQ X (CDR X)))
(\CKPOSBOUT STREAM (CHARCODE SPACE))
(if (AND *PRINT-CIRCLE-HASHTABLE* (PRINT-CIRCLE-LABEL-P
X))
then (* "Must print as a dotted tail")
(\CKPOSSOUT STREAM ". ")
(\PRINDATUM X STREAM CPL)
else
(GO LP)))
(X (* Dotted tail)
(\CKPOSSOUT STREAM " . ")
(\PRINDATUM X STREAM)))))
(\CKPOSBOUT STREAM (CHARCODE ")")))))))
((LIST \SMALLP \FIXP)
(WITH-RESOURCES (\NUMSTR \NUMSTR1)
(\CKPOSSOUT STREAM (\CONVERTNUMBER X (\CHECKRADIX *PRINT-BASE*)
T
(AND *PRINT-RADIX* *READTABLE*)
\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))
(\STACKP (\PRINSTACKP X STREAM))
(COND
((\INSTANCE-P X (QUOTE T)) (* this is a common-loops object,
since it is a sub-class of t)
(PRINT-INSTANCE X STREAM 0))
(T (LET* ((TYPE (TYPENAME X))
(FN (FASSOC TYPE \DEFPRINTFNS)))
(COND
((OR (NULL FN)
(NULL (SETQ FN (LET ((*PRINT-LEVEL* (AND *PRINT-LEVEL*
(IDIFFERENCE *PRINT-LEVEL*
(OR CPL 0)))))
(* This way recursive calls to PRINT
etc will be at the "right" level)
(APPLY* (CDR FN)
X STREAM 0)))))
(* No defined printer, or printer
declined to do anything)
(COND
((fetch (READTABLEP COMMONLISP)
of *READTABLE*)
(.SPACECHECK. STREAM 2)
(\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR)
of *READTABLE*))
(\OUTCHAR STREAM (CHARCODE "<"))
(AND TYPE (\LITPRIN TYPE STREAM))
(\CKPOSSOUT STREAM " @ ")
(\PRINTADDR X STREAM)
(\CKPOSBOUT STREAM (CHARCODE ">")))
(T (\CKPOSBOUT STREAM (CHARCODE {))
(AND TYPE (\LITPRIN TYPE STREAM))
(\CKPOSBOUT STREAM (CHARCODE }))
(\OUTCHAR STREAM (CHARCODE "#"))
(\PRINTADDR X STREAM))))
((LISTP FN)
(* PRIN1 the CAR (usually a macro char) and PRIN2 the CDR.
Nowadays there is little reason for a defprint fn to not do its own printing)
(AND (CAR FN)
(LET (*PRINT-ESCAPE*)
(\PRINDATUM (CAR FN)
STREAM)))
(AND (CDR FN)
(\PRINDATUM (CDR FN)
STREAM CPL))))))))))
(\ELIDE.PRINT.ELEMENT
(LAMBDA (STREAM) (* jrb: "29-Jun-86 21:05")
(\OUTCHAR STREAM (\ELIDE.ELEMENT.CHAR))))
(\ELIDE.ELEMENT.CHAR
(LAMBDA NIL (* jrb: "29-Jun-86 21:04")
(COND
((fetch (READTABLEP COMMONLISP)
of *READTABLE*)
(fetch (READTABLEP HASHMACROCHAR)
of *READTABLE*))
(T (CHARCODE "&")))))
(\ELIDE.PRINT.TAIL
(LAMBDA (STREAM NOSPACEP) (* jrb: "29-Jun-86 21:06")
(* * Prints the appropriate elision indicator for elements beyond *PRINT-DEPTH*
according to the read table we're using.
Prints first a space unless NOSPACEP)
(COND
((NOT NOSPACEP)
(\OUTCHAR STREAM (CHARCODE SPACE))))
(\SOUT (\ELIDE.TAIL.STRING)
STREAM)))
(\ELIDE.TAIL.STRING
(LAMBDA NIL (* jrb: "29-Jun-86 21:05")
(COND
((fetch (READTABLEP COMMONLISP)
of *READTABLE*)
"...")
(T "--"))))
(\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: "11-May-86 15:05")
(* * 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 STREAM) (* bvm: "21-May-86 11:47")
(DECLARE (USEDFREE \THISFILELINELENGTH *PRINT-ESCAPE* *READTABLE* *PACKAGE* *PRINT-GENSYM*
*PRINT-CASE*))
(COND
(*PRINT-ESCAPE* (LET ((RDTBL *READTABLE*)
PKG PKGSEPR)
(COND
(*PACKAGE* (* This is NIL until packages get
turned on)
(COND
((EQ *PACKAGE* (SETQ PKG (fetch (SYMBOL PACKAGE)
of X)))
(* No prefix needed in current package)
(SETQ PKG NIL))
((NULL PKG) (* Uninterned. Print something if flag
is on)
(COND
(*PRINT-GENSYM* (* Print "#:" as prefix)
(RPLCHARCODE (SETQ PKGSEPR
(ALLOCSTRING 2 (fetch (READTABLEP
PACKAGECHAR)
of RDTBL)))
1
(fetch (READTABLEP HASHMACROCHAR)
of RDTBL)))))
((EQ PKG *KEYWORD-PACKAGE*)
(* Keywords get single colon, no
prefix)
(SETQ PKGSEPR (ALLOCSTRING 1 (fetch (READTABLEP PACKAGECHAR
)
of RDTBL)))
(SETQ PKG NIL))
((FIND-EXACT-SYMBOL X *PACKAGE*)
(* "Symbol is accessible in current package, either by being imported or by inheritance. This is a messy test, which is why we test for special case of PKG being the current package first above. No prefix needed here.")
(SETQ PKG NIL))
(T (* "Package qualifier is needed; we need only know now whether symbol is internal or external in its home package.")
(SETQ PKGSEPR (ALLOCSTRING (COND
((EQ X (
FIND-EXTERNAL-SYMBOL
X PKG))
(* X is external in PKG, use single
colon)
1)
(T 2))
(fetch (READTABLEP PACKAGECHAR)
of RDTBL)))))))
(\LITPRIN.INTERNAL X RDTBL STREAM (AND PKG (PACKAGE-NAME-AS-SYMBOL PKG))
PKGSEPR \THISFILELINELENGTH)))
(T (.SPACECHECK. STREAM (\NATOMCHARS X))
(for C inatom X bind (DOWNCASE ← (AND (EQ *PRINT-CASE* (QUOTE :DOWNCASE))
(fetch (READTABLEP CASEINSENSITIVE)
of *READTABLE*)))
do
(\OUTCHAR STREAM (COND
((AND DOWNCASE (LEQ C (CHARCODE Z))
(GEQ C (CHARCODE A)))
(IPLUS C (IDIFFERENCE (CHARCODE a)
(CHARCODE A))))
(T C))))))))
(\LITPRIN.INTERNAL
(LAMBDA (SYMBOL RDTBL STREAM PKGNAME PKGSEPR CHECKLENGTH) (* bvm: " 9-May-86 23:07")
(* * Print SYMBOL to STREAM according to RDTBL, preceded by PKGNAME
(if non-NIL) and/or PKGSEPR. PKGNAME is a symbol, PKGSEPR is a string.
If CHECKLENGTH is true, need to check that there is room for printing all three
parts on this line; else caller has verified that there is room)
(LET ((PNAMELENGTH (\NATOMCHARS SYMBOL))
(ESCAPE (fetch (READTABLEP ESCAPECHAR)
of RDTBL))
(MULTESCAPE (fetch (READTABLEP MULTESCAPECHAR)
of RDTBL))
USEMULTESCAPE CASEBASE SA SYN NESCAPES CHECKESCAPE FIRSTESCAPE)
(COND
((OR CHECKLENGTH (NEQ MULTESCAPE 0)) (* have to check now if linelength
matters or we plan to use multiple
escapes)
(SETQ NESCAPES (\SYMBOL.ESCAPE.COUNT SYMBOL RDTBL (NULL CHECKLENGTH)))
(COND
((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)))
(COND
(CHECKLENGTH (* Verify space for everything)
(.SPACECHECK. STREAM (IPLUS PNAMELENGTH NESCAPES (COND
(PKGNAME
(* How much space to print package
name)
(IABS (
\SYMBOL.ESCAPE.COUNT
PKGNAME RDTBL)))
(T 0))
(COND
(PKGSEPR (* Extra characters between pkg name
and symbol name)
(\NSTRINGCHARS PKGSEPR))
(T 0))))))
(* * First print any needed package qualifier)
(COND
(PKGNAME (* Print package name, don't check
length)
(\LITPRIN.INTERNAL PKGNAME RDTBL STREAM)))
(COND
(PKGSEPR (\SOUT PKGSEPR STREAM)))
(COND
(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 SYMBOL do (COND
((OR (EQ C MULTESCAPE)
(EQ C ESCAPE))
(\OUTCHAR STREAM ESCAPE)))
(\OUTCHAR STREAM C))
(\OUTCHAR STREAM MULTESCAPE))
((AND (EQ PNAMELENGTH 1)
(EQ (CHCON1 SYMBOL)
(CHARCODE "."))) (* have to handle period special
because it is only special in a dotted
context)
(\OUTCHAR STREAM ESCAPE)
(\OUTCHAR STREAM (CHARCODE ".")))
(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 SYMBOL bind (FIRSTFLG ← T)
(DOWNCASE ← (AND (fetch (READTABLEP CASEINSENSITIVE)
of RDTBL)
(EQ *PRINT-CASE* (QUOTE :DOWNCASE))))
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))
(T (\OUTCHAR STREAM (COND
((AND DOWNCASE (LEQ C (CHARCODE Z))
(GEQ C (CHARCODE A)))
(IPLUS C (IDIFFERENCE (CHARCODE a)
(CHARCODE A))))
(T C)))))
(SETQ FIRSTFLG NIL)))))))
(\SYMBOL.ESCAPE.COUNT
(LAMBDA (SYMBOL RDTBL INEXACTOK) (* bvm: " 8-Aug-86 12:31")
(* * "Counts the number of escape characters needed to print SYMBOL 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. The special value -1 means the symbol is numeric, so must be quoted, but no multiple escape is available, so just escape the first character. If INEXACTOK is true and we discover we want to use multiple escape char, returns -2 immediately.")
(for C inatom SYMBOL 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 (if (EQ MULTESCAPE 0)
then (* "Can't use multiple-escape")
(SETQ MULTESCAPE NIL))
do
(if (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))))
then (* "Need protection if char is lowercase in a case-insensitive read table or the read table says it needs it")
(add RESULT 1)
(if MULTESCAPE then (if (OR (EQ C MULTESCAPE)
(EQ C ESCAPE))
then (*
"These have to be escaped no matter what")
(add NESCAPES 1)
elseif
(AND INEXACTOK (GREATERP (DIFFERENCE RESULT NESCAPES)
1))
then (*
"If at least 2 chars need escaping, better to use multiple escape, and we can quit scanning now")
(RETURN -2))))
(SETQ FIRSTFLG NIL)
finally
(RETURN (if (EQ RESULT 0)
then (*
"No funny chars, check for some other perverse cases")
(LET ((LEN (\NATOMCHARS SYMBOL)))
(if (EQ LEN 0)
then (*
"The bletcherous null symbol. Shouldn't be allowed to create this, grumble.")
(if MULTESCAPE then (* "Can print as ||")
-2 else (* "Single escape can't work")
0)
elseif
(AND (EQ LEN 1)
(EQ C (CHARCODE ".")))
then (*
"Special case, dot is always escaped when by itself")
1 elseif (\NUMERIC.PNAMEP SYMBOL (if (fetch (READTABLEP COMMONLISP)
of RDTBL)
then *READ-BASE* else 10))
then (* "Is numeric, must escape it. Note that if pname is numeric, there can't be any special chars inside it needing escaping. We wait until now to test numeric on the grounds that it is more likely we will print a symbol with escapable chars than one that is a potential number.")
(if MULTESCAPE then (*
"Nicer to use multiple escape around whole symbol")
-2 else (* "Say to escape first char")
-1)
else 0))
elseif
(AND MULTESCAPE (GREATERP (DIFFERENCE RESULT NESCAPES)
1))
then (* "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 = -(NESCAPES+2) total extra characters")
(IDIFFERENCE -2 NESCAPES)
else RESULT)))))
(\NUMERIC.PNAMEP
(LAMBDA (SYMBOL RADIX) (* bvm: " 4-Aug-86 14:56")
(* * True if the chars in SYMBOL are a potential number in RADIX, which
defaults to the current read base (according to current read table))
(LET
((LASTCHARTYPE (QUOTE FIRST))
(MAXALPHADIGIT (IPLUS (CHARCODE A)
(IDIFFERENCE (OR RADIX (if (fetch (READTABLEP COMMONLISP)
of *READTABLE*)
then *READ-BASE* else 10))
11)))
SEENALPHADIGITS SEENDIGITS SEENDECPT SEENTIGHTLETTERS) (* If RADIX is bigger than 10, this
allows alphabetic digits)
(for C inpname SYMBOL do
(* The inpname is a nicety so it works on strings too
(useful for testing) -
Note that we are assuming a partitioning of character space as follows:
(-
+ / decpt) (digits) (A-Z) (← ↑) (a-z))
(SETQ LASTCHARTYPE
(if (ILESSP C (CHARCODE A))
then (* Numeric or funny char)
(if (ILESSP C (CHARCODE 0))
then
(SELCHARQ C
((- +) (* Signs anywhere but end)
(QUOTE SIGN))
(%. (if SEENALPHADIGITS then (* Can't have decimal point in other
radices, so if we saw combinations of
chars that would have been invalid in
radix 10, bomb out)
(if SEENTIGHTLETTERS then (RETURN NIL))
(SETQ SEENALPHADIGITS NIL))
(SETQ MAXALPHADIGIT 0)
(SETQ SEENDECPT T))
(/ (if (EQ LASTCHARTYPE (QUOTE FIRST))
then (* Can't start with ratio marker)
(RETURN NIL)))
(RETURN NIL))
elseif
(ILEQ C (CHARCODE 9))
then (* digit)
(SETQ SEENDIGITS T)
(QUOTE DIGIT)
else
(RETURN NIL))
elseif
(IGREATERP C (CHARCODE z))
then (* Out in the wilderness.)
(RETURN NIL)
elseif
(PROGN (if (IGEQ C (CHARCODE a))
then (* Raise it)
(SETQ C (IDIFFERENCE C (IDIFFERENCE (CHARCODE a)
(CHARCODE A)))))
(ILEQ C (CHARCODE Z)))
then (* Letter)
(if (ILEQ C MAXALPHADIGIT)
then (* Letter is a digit in this base.
Can't be digit in number with decimal
pt)
(SETQ SEENALPHADIGITS T)
(SELECTQ LASTCHARTYPE
((LETTER FIRST) (* Two letters in a row or started
with letter. Notice this in case a dec
pt comes along)
(SETQ SEENTIGHTLETTERS T))
NIL)
else (* Potential number marker --
only if not next to another letter)
(SELECTQ LASTCHARTYPE
((LETTER FIRST)
(RETURN NIL))
NIL))
(QUOTE LETTER)
elseif
(OR (EQ C (CHARCODE ←))
(EQ C (CHARCODE ↑)))
then (* Extension chars, not used now but
maybe some day. We're supposed to
escape these)
NIL else (RETURN NIL)))
finally (* Success if there was at least one
digit and didn't end in a sign)
(RETURN (AND (OR SEENDIGITS SEENALPHADIGITS)
(NEQ LASTCHARTYPE (QUOTE SIGN))))))))
(\PRINSTACKP
(LAMBDA (X STREAM) (* bvm: "11-May-86 16:09")
(* * Print stackp as addr/framename. If stackp is released or framename is not
a symbol, print mumble)
(.SPACECHECK. STREAM (IPLUS 1 (CONSTANT (NCHARS "<StackP "))
(PROGN (* Longest stack address is "177,177777")
10)
1
(COND
((RELSTKP X)
(CONSTANT (NCHARS "released")))
((LITATOM (STKNAME X))
(\NATOMCHARS (STKNAME X)))
(T 6))
1))
(\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR)
of *READTABLE*))
(\SOUT "<StackP " STREAM)
(\PRINTADDR X STREAM)
(\OUTCHAR STREAM (CHARCODE /))
(COND
((RELSTKP X)
(\SOUT "released" STREAM))
((LITATOM (SETQ X (STKNAME X)))
(\LITPRIN X STREAM))
(T (\SOUT "*form*" STREAM)))
(\OUTCHAR STREAM (CHARCODE >))))
(\PRINTADDR
(LAMBDA (X STREAM) (* bvm: "11-May-86 15:13")
(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) (* bvm: "11-May-86 15:08")
(COND
(*PRINT-ESCAPE* (* Print with double quotes and
escaped as needed)
(LET ((ESC (fetch (READTABLEP ESCAPECHAR)
of *READTABLE*)))
(.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) (* bvm: "26-Mar-86 10:40")
(* OUTCHARFN for standard files)
(COND
((EQ CHARCODE (CHARCODE EOL))
(COND
((NOT (\RUNCODED STREAM)) (* Charset is a constant 0)
(\BOUT STREAM (\CHARSET (CHARCODE EOL))))
((EQ (\CHARSET (CHARCODE EOL))
(ffetch CHARSET of STREAM)))
(T (\BOUT STREAM NSCHARSETSHIFT)
(\BOUT STREAM (freplace (STREAM CHARSET)
of STREAM with (\CHARSET (CHARCODE EOL))))))
(\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)
(IPLUS16 (ffetch CHARPOSITION of STREAM)
1)))))))
(\TTYOUTCHARFN
(LAMBDA (STREAM CH) (* hdj "15-Sep-86 18:09")
(* ;; "OUTCHARFN for TTY when dribble is on")
(DECLARE (USEDFREE \DRIBBLE.OFD))
(\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))))
)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS .SPACECHECK. MACRO ((STRM N)
(AND \THISFILELINELENGTH (IGREATERP (IPLUS N (fetch CHARPOSITION of
STRM))
\THISFILELINELENGTH)
(FRESHLINE STRM))))
(PUTPROPS \CHECKRADIX MACRO (LAMBDA (R)
(COND ((OR (NOT (SMALLP R))
(ILESSP R 1)
(IGREATERP R 36))
(\INVALID.RADIX R))
(T R))))
)
(* END EXPORTED DEFINITIONS)
)
(DEFINEQ
(\INVALID.RADIX
(LAMBDA (N) (* bvm: " 5-May-86 10:58")
(ERROR "Bad value for *print-base*" N)))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS \THISFILELINELENGTH)
)
(* Internal printing)
(DEFINEQ
(\MAPPNAME
(LAMBDA (FN X FLG RDTBL) (* bvm: "13-May-86 15:05")
(* * 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)
(LET ((*PRINT-ESCAPE* FLG)
(*READTABLE* (COND
(FLG (\GTREADTABLE RDTBL))
(T (\DTEST *READTABLE* (QUOTE READTABLEP)))))
(*PRINT-BASE* (COND
(PRXFLG *PRINT-BASE*)
(T 10)))
(*PRINT-RADIX*)
(*PRINT-LEVEL*)
(*PRINT-LENGTH*))
(DECLARE (SPECVARS *READTABLE* *PRINT-ESCAPE* *PRINT-BASE* *PRINT-RADIX* *PRINT-LEVEL*
*PRINT-LENGTH*)) (* numbers print in decimal unless
PRXFLG)
(COND
((AND FLG (NEQ *PRINT-BASE* 10))
(SETQ *PRINT-RADIX* T)))
(\MAPPNAME.INTERNAL FN X))))
(\MAPPNAME.INTERNAL
(LAMBDA (FN X) (* bvm: "13-May-86 15:01")
(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) (* Stream has no linelength checks)
(DECLARE (SPECVARS \THISFILELINELENGTH))
(\PRINDATUM X \MAPPNAMESTREAM 0)))))
(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)))
)
(DECLARE: EVAL@COMPILE DOCOPY
(ADDTOVAR SYSSPECVARS *PRINT-BASE* *READ-BASE* *PRINT-RADIX* *PRINT-ESCAPE* *PRINT-CASE*
*PRINT-GENSYM* *PRINT-LEVEL* *PRINT-LENGTH* *PRINT-PRETTY* *PRINT-CIRCLE*
*PRINT-ARRAY* *PACKAGE*)
)
(* 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 \LINELENGTH \FLOATFORMAT PRXFLG \DEFPRINTFNS)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA PRINT-CIRCLE-ENTER PRINT-CIRCLE-SCAN PRINT-CIRCLE-LABEL-P PRINT-CIRCLE-LOOKUP)
)
(PRETTYCOMPRINT APRINTCOMS)
(RPAQQ APRINTCOMS
((COMS (* User-level print functions)
(FNS PRIN1 PRIN2 PRIN3 PRIN4 PRINT PRINTCCODE PRINTLEVEL RADIX SPACES TERPRI FRESHLINE
DEFPRINT LINELENGTH))
(* JRB: I don't understand how this ever worked without a FIRST...)
(DECLARE: FIRST (INITVARS (PLVLFILEFLG NIL)
(\LINELENGTH 82)
(\FLOATFORMAT T)
(PRXFLG NIL)
(*PRINT-BASE* 10)
(*READ-BASE* 10)
(*PRINT-RADIX* NIL)
(*PRINT-ESCAPE* T)
(*PRINT-CASE* (QUOTE :UPCASE))
(*PRINT-GENSYM* T)
(*PRINT-LEVEL* NIL)
(*PRINT-LENGTH* NIL)
(*PRINT-PRETTY* NIL)
(*PRINT-CIRCLE* NIL)
(*PRINT-ARRAY* NIL)
(*PRINT-CIRCLE-HASHTABLE* NIL)
(*PACKAGE* NIL)
(*KEYWORD-PACKAGE* NIL)
(\DEFPRINTFNS NIL)))
(COMS (* PRINT internals)
(FNS PRINT-CIRCLE-LOOKUP PRINT-CIRCLE-LABEL-P PRINT-CIRCLE-SCAN PRINT-CIRCLE-ENTER)
(FNS \PRINDATUM \ELIDE.PRINT.ELEMENT \ELIDE.ELEMENT.CHAR \ELIDE.PRINT.TAIL
\ELIDE.TAIL.STRING \CKPOSBOUT \CKPOSSOUT \CONVERTNUMBER \LITPRIN \LITPRIN.INTERNAL
\SYMBOL.ESCAPE.COUNT \NUMERIC.PNAMEP \PRINSTACKP \PRINTADDR \PRINSTRING \SOUT
\OUTCHAR \FILEOUTCHARFN \TTYOUTCHARFN)
(DECLARE: DONTCOPY (MACROS .FILELINELENGTH.))
(DECLARE: EVAL@COMPILE DONTCOPY (EXPORT (MACROS .SPACECHECK. \CHECKRADIX)))
(FNS \INVALID.RADIX)
(SPECVARS \THISFILELINELENGTH))
(COMS (* Internal printing)
(FNS \MAPPNAME \MAPPNAME.INTERNAL PNAMESTREAMP)
(DECLARE: DONTCOPY (RESOURCES \MAPPNAMESTREAM)
(MACROS PNAMESTREAMP))
(INITRESOURCES \MAPPNAMESTREAM)
(INITVARS (\PNAMEDEVICE (NCREATE (QUOTE FDEV)
(\GETDEVICEFROMHOSTNAME (QUOTE NULL)
T))))
(GLOBALVARS \PNAMEDEVICE))
(COMS (* Obsolete)
(FNS \MAPCHARS))
(DECLARE: EVAL@COMPILE DOCOPY
(ADDVARS (SYSSPECVARS *PRINT-BASE* *READ-BASE* *PRINT-RADIX* *PRINT-ESCAPE*
*PRINT-CASE* *PRINT-GENSYM* *PRINT-LEVEL* *PRINT-LENGTH*
*PRINT-PRETTY* *PRINT-CIRCLE* *PRINT-ARRAY* *PACKAGE*)))
(COMS (* PRINTNUM and friends)
(FNS PRINTNUM FLTFMT \CHECKFLTFMT NUMFORMATCODE)
(MACROS NUMFORMATCODE)
(INITVARS (NILNUMPRINTFLG)))
(LOCALVARS . T)
(GLOBALVARS \LINELENGTH \FLOATFORMAT PRXFLG \DEFPRINTFNS)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA)))))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS APRINT COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3736 12476 (PRIN1 3746 . 5031) (PRIN2 5033 . 6067) (PRIN3 6069 . 7050) (PRIN4 7052 .
8092) (PRINT 8094 . 8343) (PRINTCCODE 8345 . 8632) (PRINTLEVEL 8634 . 9399) (RADIX 9401 . 9578) (
SPACES 9580 . 9939) (TERPRI 9941 . 10136) (FRESHLINE 10138 . 11036) (DEFPRINT 11038 . 11554) (
LINELENGTH 11556 . 12474)) (13191 18114 (PRINT-CIRCLE-LOOKUP 13201 . 14811) (PRINT-CIRCLE-LABEL-P
14813 . 15411) (PRINT-CIRCLE-SCAN 15413 . 17269) (PRINT-CIRCLE-ENTER 17271 . 18112)) (18115 60395 (
\PRINDATUM 18125 . 26430) (\ELIDE.PRINT.ELEMENT 26432 . 26607) (\ELIDE.ELEMENT.CHAR 26609 . 26912) (
\ELIDE.PRINT.TAIL 26914 . 27389) (\ELIDE.TAIL.STRING 27391 . 27624) (\CKPOSBOUT 27626 . 27795) (
\CKPOSSOUT 27797 . 28004) (\CONVERTNUMBER 28006 . 31428) (\LITPRIN 31430 . 36180) (\LITPRIN.INTERNAL
36182 . 43363) (\SYMBOL.ESCAPE.COUNT 43365 . 48638) (\NUMERIC.PNAMEP 48640 . 53830) (\PRINSTACKP 53832
. 55119) (\PRINTADDR 55121 . 56207) (\PRINSTRING 56209 . 57570) (\SOUT 57572 . 57730) (\OUTCHAR 57732
. 57910) (\FILEOUTCHARFN 57912 . 59961) (\TTYOUTCHARFN 59963 . 60393)) (61768 61940 (\INVALID.RADIX
61778 . 61938)) (62039 64346 (\MAPPNAME 62049 . 63211) (\MAPPNAME.INTERNAL 63213 . 63934) (
PNAMESTREAMP 63936 . 64344)) (65100 65517 (\MAPCHARS 65110 . 65515)) (65835 70415 (PRINTNUM 65845 .
68947) (FLTFMT 68949 . 69282) (\CHECKFLTFMT 69284 . 69896) (NUMFORMATCODE 69898 . 70413)))))
STOP