(FILECREATED " 4-NOV-83 10:03:51" <BLISP>APRINT.;130 24809
changes to: (FNS \TTYOUTCHARFN)
previous date: "21-OCT-83 12:48:03" <BLISP>APRINT.;128)
(* Copyright (c) 1982, 1983 by Xerox Corporation)
(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)
(VARS (\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)
(VARS (NILNUMPRINTFLG))
(P (MOVD? (QUOTE PRINTNUM)
(QUOTE FPRINTNUM]
(DECLARE: DONTCOPY (MACROS .FILELINELENGTH. .SPACECHECK. \PRODUCECHAR \OUTCHAR))
(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) (* rmk: "21-OCT-83 12:46")
(* 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)
(add (fetch CHARPOSITION of STREAM)
1])
(\TTYOUTCHARFN
[LAMBDA (STREAM CH) (* rmk: " 4-NOV-83 10:03")
(* OUTCHARFN for TTY when dribble is on)
(\OUTCHAR \DRIBBLE.OFD CH)
(SPREADAPPLY*(LISTGET (fetch USERFIELD 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])
)
(RPAQQ \CARPRINTLEVEL 1000)
(RPAQQ \PRINTCRFLAG NIL)
(RPAQQ \CDRPRINTLEVEL -1)
(RPAQQ PLVLFILEFLG NIL)
(RPAQQ \LINELENGTH 82)
(RPAQQ \FLOATFORMAT T)
(RPAQQ PRXFLG NIL)
(RPAQQ \PRINTRADIX 10)
(RPAQQ \SIGNFLAG T)
(RPAQQ \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))
)
(RPAQQ NILNUMPRINTFLG NIL)
(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)))
(PUTPROPS \OUTCHAR DMACRO (OPENLAMBDA (STREAM CHARCODE)
(STREAMOP (QUOTE OUTCHARFN)
STREAM STREAM CHARCODE)))
)
)
(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))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1506 15183 (PRIN1 1516 . 2027) (PRIN2 2029 . 2591) (PRIN3 2593 . 3156) (PRIN4 3158 .
3783) (PRINT 3785 . 4385) (PRINTLEVEL 4387 . 4971) (RADIX 4973 . 5465) (SPACES 5467 . 5812) (TERPRI
5814 . 6001) (FRESHLINE 6003 . 6599) (DEFPRINT 6601 . 7043) (LINELENGTH 7045 . 7565) (\CKPOSBOUT 7567
. 7731) (\CKPOSSOUT 7733 . 7946) (\CONVERTNUMBER 7948 . 9923) (\LITPRIN 9925 . 10709) (\OUTCHAR 10711
. 10879) (\SOUT 10881 . 11045) (\PRINDATUM 11047 . 13635) (\PRINOTHER 13637 . 13921) (\PRINSTACKP
13923 . 14315) (\PRINSTRING 14317 . 15181)) (15184 16180 (\FILEOUTCHARFN 15194 . 15824) (\TTYOUTCHARFN
15826 . 16178)) (16181 19719 (\MAPCHARS 16191 . 16381) (\MAPCHARS1 16383 . 18503) (\PRODUCESTRING
18505 . 18677) (\PRODUCENUM 18679 . 18911) (\PRODUCEADDR 18913 . 19438) (\MAPCHARSLIT 19440 . 19717))
(19720 20345 (\APRINTINIT 19730 . 20343)) (20632 23505 (FLTFMT 20642 . 20945) (\CHECKFLTFMT 20947 .
21400) (NUMFORMATCODE 21402 . 21743) (PRINTNUM 21745 . 23503)))))
STOP
P