(FILECREATED "16-Aug-84 17:27:08" {ERIS}<LISPCORE>SOURCES>APRINT.;3 24847
changes to: (FNS \FILEOUTCHARFN)
previous date: " 7-Apr-84 14:47:11" {ERIS}<LISPCORE>SOURCES>APRINT.;2)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT APRINTCOMS)
(RPAQQ APRINTCOMS [(DECLARE: FIRST (P (RESETSAVE PRETTYHEADER NIL)))
(FNS PRIN1 PRIN2 PRIN3 PRIN4 PRINT 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)
(FNS \APRINTINIT)
(INITVARS (\CARPRINTLEVEL 1000)
(\PRINTCRFLAG NIL)
(\CDRPRINTLEVEL -1)
(PLVLFILEFLG NIL)
(\LINELENGTH 82)
(\FLOATFORMAT T)
(PRXFLG NIL)
(\PRINTRADIX 10)
(\SIGNFLAG T)
(\DEFPRINTFNS NIL))
[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)
(DECLARE: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (P (\APRINTINIT])
(DECLARE: FIRST
(RESETSAVE PRETTYHEADER NIL)
)
(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])
(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) (* N.Greenfeld "11-Jun-81 10:11")
(PROG ([OLD (COND
(\SIGNFLAG \PRINTRADIX)
(T (IDIFFERENCE 0 \PRINTRADIX]
R S)
(COND
(N [COND
((SETQ S (IGREATERP (SETQ R (FIX N))
0)))
(T (SETQ R (IDIFFERENCE 0 R]
(COND
((OR (IGREATERP 2 R)
(IGREATERP R 16))
(\ILLEGAL.ARG R)))
(SETQ \PRINTRADIX R)
(SETQ \SIGNFLAG S)))
(RETURN OLD])
(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) (* rmk: "14-APR-82 00:06")
(PROG ((X N)
Y SIGN (POS (SUB1 (NCHARS NS)))
END DIGIT)
[COND
[(IGREATERP 0 N)
(COND
(SFLAG (SETQ Y (IQUOTIENT X R))
(SETQ SIGN T))
(T (* Compute X as remainder of N and R, Y as quotient)
(COND
((EQ R 8)
(SETQ X (LOGAND N 7))
(SETQ Y (LRSH N 3)))
(T (PROG ((Q (IQUOTIENT 1073741824 R))
P
(\OVERFLOW 0))
(DECLARE (SPECVARS \OVERFLOW))
(SETQ Y 0)
(SETQ P (ITIMES Q R))
RED (SETQ X (IDIFFERENCE X P))
(SETQ Y (IPLUS Y Q))
(COND
((ILESSP X 0)
(GO RED)))
(SETQ Y (IPLUS Y (IQUOTIENT X R]
(T (SETQ Y (IQUOTIENT X R]
(COND
((AND (EQ R 8)
QFLAG
(OR (IGREATERP X 7)
(ILESSP X -7)))
(RPLCHARCODE NS (SETQ END (ADD1 POS))
(CHARCODE Q)))
(T (SETQ END POS)))
(SETQ DIGIT (COND
((IGREATERP 0 (SETQ X (IREMAINDER X R)))
(IDIFFERENCE 0 X))
(T X)))
[RPLCHARCODE NS POS (IPLUS DIGIT (COND
((ILESSP DIGIT 10)
(CHARCODE 0))
(T (IDIFFERENCE (CHARCODE A)
10]
(AND (IGREATERP 0 Y)
(SETQ Y (IDIFFERENCE 0 Y))) (* The first character is done outside the loop so that
there will not be a problem negating the least negative
number)
LP [COND
((EQ (SETQ X Y)
0)
[COND
(SIGN (RPLCHARCODE NS (SETQ POS (SUB1 POS))
(CHARCODE -]
(RETURN (SUBSTRING NS POS END NSB]
(SETQ Y (IQUOTIENT X R))
(SETQ DIGIT (IREMAINDER X R))
[RPLCHARCODE NS (SETQ POS (SUB1 POS))
(COND
((ILESSP DIGIT 10)
(IPLUS DIGIT (CHARCODE 0)))
(T (IPLUS (IDIFFERENCE DIGIT 10)
(CHARCODE A]
(GO LP])
(\LITPRIN
[LAMBDA (X SA STREAM) (* rmk: "21-OCT-83 12:32")
(DECLARE (USEDFREE \THISFILELINELENGTH))
(COND
((EQ X (QUOTE %.))
(COND
(SA (.SPACECHECK. STREAM 2)
(\OUTCHAR STREAM (CHARCODE %%)))
(T (.SPACECHECK. STREAM 1)))
(\OUTCHAR STREAM (CHARCODE %.)))
(SA [.SPACECHECK. STREAM (IPLUS (\NATOMCHARS X)
(for C inatom X count (fetch (READCODE ESCQUOTE)
of (\SYNCODE SA C]
(for C inatom X
do (AND (fetch (READCODE ESCQUOTE) of (\SYNCODE SA C))
(\OUTCHAR STREAM (CHARCODE %%)))
(\OUTCHAR STREAM C)))
(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) (* rmk: "21-OCT-83 12:32")
(* 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 \SIGNFLAG 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) (* bvm: "16-Aug-84 17:20")
(* OUTCHARFN for standard files)
(COND
((EQ CHARCODE (CHARCODE EOL))
(\BOUT STREAM (SELECTC (fetch EOLCONVENTION of STREAM)
(CR.EOLC (CHARCODE CR))
(LF.EOLC (CHARCODE LF))
(CRLF.EOLC (\BOUT STREAM (CHARCODE CR))
(CHARCODE LF))
(SHOULDNT)))
(replace CHARPOSITION of STREAM with 0))
(T (\BOUT STREAM CHARCODE)
(replace CHARPOSITION of STREAM with (PROGN (* Ugh. Don't overflow)
(\LOLOC (\ADDBASE (fetch 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 "24-JUL-83 14:23")
(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))
(OR (NULL PRXFLG)
\SIGNFLAG)
SA))
[\FLOATP (GLOBALRESOURCE (\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: "23-DEC-80 21:16")
(GLOBALRESOURCE (\NUMSTR \NUMSTR1)
(\PRODUCESTRING (\CONVERTNUMBER N R SFLAG QFLAG \NUMSTR \NUMSTR1)))])
(\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) (* N.Greenfeld "11-Jun-81 09:30")
(for C inatom X do (AND SA (fetch (READCODE ESCQUOTE) of (\SYNCODE SA C))
(\PRODUCECHAR (CHARCODE %%)))
(\PRODUCECHAR C])
)
(DEFINEQ
(\APRINTINIT
[LAMBDA NIL (* N.Greenfeld " 9-Oct-81 15:31")
(* This is here for the JERICHO bootstrap process.
Note that MKSTRING and NCHARS are here rather than in
JATOM because they use \MAPCHARS.)
(SELECTQ (SYSTEMTYPE)
(JERICHO [MAPC (QUOTE (MKSTRING NCHARS))
(FUNCTION (LAMBDA (X)
(MOVD (PACK* (QUOTE \\)
X)
X]
(SETQ \TERM.OFD (COPYIOD \TERM.OFD .TTYOUTIOD))
(SETQ \TERM.OFD.SAV \TERM.OFD))
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)
(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
(ADDTOVAR GLOBALVARS \CARPRINTLEVEL \TCARPRINTLEVEL \PRINTCRFLAG \CDRPRINTLEVEL \TCDRPRINTLEVEL
\LINELENGTH \FLOATFORMAT \PRINTRADIX \SIGNFLAG PRXFLG \DEFPRINTFNS)
)
(DECLARE: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY
(\APRINTINIT)
)
(PUTPROPS APRINT COPYRIGHT ("Xerox Corporation" 1982 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1539 15216 (PRIN1 1549 . 2060) (PRIN2 2062 . 2624) (PRIN3 2626 . 3189) (PRIN4 3191 .
3816) (PRINT 3818 . 4418) (PRINTLEVEL 4420 . 5004) (RADIX 5006 . 5498) (SPACES 5500 . 5845) (TERPRI
5847 . 6034) (FRESHLINE 6036 . 6632) (DEFPRINT 6634 . 7076) (LINELENGTH 7078 . 7598) (\CKPOSBOUT 7600
. 7764) (\CKPOSSOUT 7766 . 7979) (\CONVERTNUMBER 7981 . 9956) (\LITPRIN 9958 . 10742) (\OUTCHAR 10744
. 10912) (\SOUT 10914 . 11078) (\PRINDATUM 11080 . 13668) (\PRINOTHER 13670 . 13954) (\PRINSTACKP
13956 . 14348) (\PRINSTRING 14350 . 15214)) (15217 16347 (\FILEOUTCHARFN 15227 . 15988) (\TTYOUTCHARFN
15990 . 16345)) (16348 19886 (\MAPCHARS 16358 . 16548) (\MAPCHARS1 16550 . 18670) (\PRODUCESTRING
18672 . 18844) (\PRODUCENUM 18846 . 19078) (\PRODUCEADDR 19080 . 19605) (\MAPCHARSLIT 19607 . 19884))
(19887 20512 (\APRINTINIT 19897 . 20510)) (20799 23672 (FLTFMT 20809 . 21112) (\CHECKFLTFMT 21114 .
21567) (NUMFORMATCODE 21569 . 21910) (PRINTNUM 21912 . 23670)))))
STOP