(FILECREATED "24-JUL-83 14:24:10" <SPAGHETTI>APRINT.;2 24732
changes to: (FNS \MAPCHARS1)
previous date: "22-JUL-83 14:57:13" <SPAGHETTI>APRINT.;1)
(* 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) (* lmm " 9-APR-81 13:03")
(PROG ((\OFD (\GETOFD 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) (* lmm " 9-APR-81 13:03")
(PROG ((\OFD (\GETOFD 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) (* lmm " 9-APR-81 14:33")
(PROG [\THISFILELINELENGTH (\OFD (\GETOFD FILE (QUOTE OUTPUT]
(DECLARE (SPECVARS \THISFILELINELENGTH))
(SETQ \TCARPRINTLEVEL \CARPRINTLEVEL)
(SETQ \TCDRPRINTLEVEL \CDRPRINTLEVEL)
[replace XPOSITION of \OFD with (PROG1 (fetch XPOSITION of \OFD)
(\PRINDATUM X \OFD NIL (COND
((OR (\OUTTERMP \OFD)
PLVLFILEFLG)
0]
(RETURN X])
(PRIN4
[LAMBDA (X FILE RDTBL) (* lmm " 9-APR-81 14:34")
(PROG [\THISFILELINELENGTH (\OFD (\GETOFD FILE (QUOTE OUTPUT]
(DECLARE (SPECVARS \THISFILELINELENGTH))
(SETQ \TCARPRINTLEVEL \CARPRINTLEVEL)
(SETQ \TCDRPRINTLEVEL \CDRPRINTLEVEL)
[replace XPOSITION of \OFD with (PROG1 (fetch XPOSITION of \OFD)
(\PRINDATUM X \OFD (fetch READSA
of (\GTREADTABLE RDTBL))
(COND
((OR (\OUTTERMP \OFD)
PLVLFILEFLG)
0]
(RETURN X])
(PRINT
[LAMBDA (X FILE RDTBL) (* N.Greenfeld " 8-Oct-81 18:12")
(PROG [\THISFILELINELENGTH (\OFD (\GETOFD 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) (* lmm " 9-APR-81 12:52")
[PROG ((OFD (\GETOFD FILE (QUOTE OUTPUT)))
\THISFILELINELENGTH)
(SETQ \THISFILELINELENGTH (.FILELINELENGTH. OFD))
(.SPACECHECK. OFD N)
(FRPTQ N (\OUTCHAR OFD (CHARCODE SPACE]
NIL])
(TERPRI
[LAMBDA (FILE) (* N.Greenfeld " 8-Oct-81 18:15")
(\OUTCHAR (\GETOFD FILE (QUOTE OUTPUT))
(CHARCODE EOL))
NIL])
(FRESHLINE
(LAMBDA (STREAM) (* JonL "18-JUL-83 21:51")
(* 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 XPOSITION 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: "27-DEC-81 00:20")
(* Sets to N the linelength of FILE
(NIL defaults to primary output file))
(PROG [(STREAM (\GETOFD 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 (OFD X) (* rrb " 9-MAR-81 11:07")
(.SPACECHECK. OFD 1)
(\OUTCHAR OFD X])
(\CKPOSSOUT
[LAMBDA (OFD X) (* rmk: "14-OCT-81 19:59")
(.SPACECHECK. OFD (\NSTRINGCHARS X))
(for I instring X do (\OUTCHAR OFD 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 OFD) (* N.Greenfeld " 8-Oct-81 18:20")
(DECLARE (USEDFREE \THISFILELINELENGTH))
(COND
((EQ X (QUOTE %.))
(COND
(SA (.SPACECHECK. OFD 2)
(\OUTCHAR OFD (CHARCODE %%)))
(T (.SPACECHECK. OFD 1)))
(\OUTCHAR OFD (CHARCODE %.)))
(SA [.SPACECHECK. OFD (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 OFD (CHARCODE %%)))
(\OUTCHAR OFD C)))
(T (.SPACECHECK. OFD (\NATOMCHARS X))
(for C inatom X do (\OUTCHAR OFD C])
(\OUTCHAR
[LAMBDA (STREAM CHARCODE) (* rmk: " 7-APR-82 00:25")
(STREAMOP (QUOTE OUTCHARFN)
STREAM STREAM CHARCODE])
(\SOUT
[LAMBDA (X OFD) (* N.Greenfeld "11-Jun-81 09:08")
(for I instring X do (\OUTCHAR OFD I])
(\PRINDATUM
[LAMBDA (X OFD SA CPL) (* rmk: "27-OCT-81 15:29")
(* 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 OFD))
[\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 OFD (CHARCODE &))
(RETURN)))
(\CKPOSBOUT OFD (CHARCODE %())
(AND CPL (IGREATERP \TCDRPRINTLEVEL -1)
(SETQ CDRCNT CPL))
LP (\PRINDATUM (CAR X)
OFD SA CPL)
(COND
[(NLISTP (CDR X))
(COND
((SETQ X (CDR X))
(\CKPOSSOUT OFD (QUOTE " . "))
(\PRINDATUM X OFD SA CPL]
([AND CPL (OR (IGREATERP CPL \TCARPRINTLEVEL)
(AND CDRCNT (NOT (IGREATERP \TCDRPRINTLEVEL CDRCNT]
(\CKPOSSOUT OFD (QUOTE " --")))
(T [COND
((AND \PRINTCRFLAG CPL (LISTP (CAR X))
\THISFILELINELENGTH
(LISTP (CADR X)))
(\OUTCHAR OFD (CHARCODE EOL)))
(T (\CKPOSBOUT OFD (CHARCODE SPACE]
(SETQ X (CDR X))
(AND CDRCNT (ADD1VAR CDRCNT))
(GO LP)))
(\CKPOSBOUT OFD (CHARCODE %)]
[(LIST \SMALLP \FIXP)
(GLOBALRESOURCE (\NUMSTR \NUMSTR1)
(\CKPOSSOUT OFD (\CONVERTNUMBER X \PRINTRADIX \SIGNFLAG SA \NUMSTR \NUMSTR1)))]
[\FLOATP (GLOBALRESOURCE (\NUMSTR \NUMSTR1)
(\CKPOSSOUT OFD (\CONVERT.FLOATING.NUMBER X \NUMSTR \NUMSTR1)))]
(\STRINGP (\PRINSTRING X OFD SA))
(\STACKP (\PRINSTACKP X OFD))
(PROG [(FN (CDR (FASSOC (TYPENAME X)
\DEFPRINTFNS]
(RETURN (COND
([OR (NULL FN)
(NULL (SETQ FN (APPLY* FN X (fetch FULLNAME of OFD]
(\PRINOTHER X OFD SA))
((LISTP FN)
(AND (CAR FN)
(\PRINDATUM (CAR FN)
OFD NIL CPL))
(AND (CDR FN)
(\PRINDATUM (CDR FN)
OFD 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 OFD SA) (* lmm "30-MAR-83 21:59")
(* We key on specific characters, not syntax code, cause that's the way the 10
seems to do it.)
(COND
(SA [.SPACECHECK. OFD (IPLUS 2 (\NSTRINGCHARS X)
(for C instring X count (SELCHARQ C
((%" %%))
NIL]
(\OUTCHAR OFD (CHARCODE %"))
(for C instring X
do (SELCHARQ C
((%" %% LF)
(\OUTCHAR OFD (CHARCODE %%)))
NIL) (* VM says only %" is escaped no matter what stringdelim's are.)
(\OUTCHAR OFD C))
(\OUTCHAR OFD (CHARCODE %")))
(T (.SPACECHECK. OFD (\NSTRINGCHARS X))
(\SOUT X OFD])
)
(DEFINEQ
(\FILEOUTCHARFN
[LAMBDA (STREAM CHARCODE) (* lmm " 5-MAR-83 00:20")
(* OUTCHARFN for standard files)
[SELECTQ (SYSTEMTYPE)
(D (\BOUT STREAM CHARCODE))
[(JERICHO TENEX TOPS-20)
(* We don't want to put EOL's into files -
convert to real CR/LFs.)
(COND
((EQ CHARCODE (CHARCODE EOL))
(\BOUT STREAM (CHARCODE CR))
(\BOUT STREAM (CHARCODE LF)))
(T (\BOUT STREAM CHARCODE]
[VAX (COND
((EQ CHARCODE (CHARCODE EOL))
(\BOUT STREAM (CHARCODE LF)))
(T (\BOUT STREAM CHARCODE]
(SYSTEMTYPEPUNT (QUOTE (\OUTCHAR STREAM CHARCODE]
(* Should actually use stream property)
(replace XPOSITION of STREAM with (COND
((EQ CHARCODE (CHARCODE EOL))
0)
(T (ADD1 (fetch XPOSITION of STREAM])
(\TTYOUTCHARFN
[LAMBDA (STREAM CH) (* lmm " 5-MAR-83 00:23")
(* OUTCHARFN for TTY)
(AND \DRIBBLE.OFD (\OUTCHAR \DRIBBLE.OFD CH))
(\BOUT 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 ((OFD N)
(AND \THISFILELINELENGTH (IGREATERP (IPLUS N (fetch XPOSITION
of OFD))
\THISFILELINELENGTH)
(FRESHLINE OFD))))
(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 (1509 14947 (PRIN1 1519 . 2025) (PRIN2 2027 . 2584) (PRIN3 2586 . 3133) (PRIN4 3135 .
3752) (PRINT 3754 . 4357) (PRINTLEVEL 4359 . 4943) (RADIX 4945 . 5437) (SPACES 5439 . 5767) (TERPRI
5769 . 5959) (FRESHLINE 5961 . 6565) (DEFPRINT 6567 . 7009) (LINELENGTH 7011 . 7528) (\CKPOSBOUT 7530
. 7686) (\CKPOSSOUT 7688 . 7894) (\CONVERTNUMBER 7896 . 9871) (\LITPRIN 9873 . 10629) (\OUTCHAR 10631
. 10799) (\SOUT 10801 . 10968) (\PRINDATUM 10970 . 13515) (\PRINOTHER 13517 . 13801) (\PRINSTACKP
13803 . 14195) (\PRINSTRING 14197 . 14945)) (14948 16109 (\FILEOUTCHARFN 14958 . 15884) (\TTYOUTCHARFN
15886 . 16107)) (16110 19648 (\MAPCHARS 16120 . 16310) (\MAPCHARS1 16312 . 18432) (\PRODUCESTRING
18434 . 18606) (\PRODUCENUM 18608 . 18840) (\PRODUCEADDR 18842 . 19367) (\MAPCHARSLIT 19369 . 19646))
(19649 20274 (\APRINTINIT 19659 . 20272)) (20561 23434 (FLTFMT 20571 . 20874) (\CHECKFLTFMT 20876 .
21329) (NUMFORMATCODE 21331 . 21672) (PRINTNUM 21674 . 23432)))))
STOP
P