(FILECREATED " 7-Feb-85 22:03:39" {ERIS}<LISPCORE>SOURCES>HPRINT.;5 33545
changes to: (FNS COPYALL HCOPYALL1)
previous date: " 1-Jan-85 22:10:17" {ERIS}<LISPCORE>SOURCES>HPRINT.;4)
(* Copyright (c) 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT HPRINTCOMS)
(RPAQQ HPRINTCOMS [(FNS MAKEHVPRETTYCOMS READVARS HPRINT0)
(FILEPKGCOMS HORRIBLEVARS UGLYVARS)
(FNS HPRINT HPRINT1 HPRINTEND RPTPRINT RPTEND RPTPUT HPRINTSP HPERR HVFWDCDREAD HVBAKREAD
HVREADEND HVRPTREAD HVFWDREAD HREAD HPINITRDTBL HVREADERR HPRINSP)
(FNS COPYALL HCOPYALL HCOPYALL1)
(FNS EQUALALL EQUALHASH)
(BLOCKS (COPYALL COPYALL (NOLINKFNS . T)
(GLOBALVARS SYSHASHARRAY))
(EQUALALL EQUALALL EQUALHASH (RETFNS EQUALHASH)
(NOLINKFNS . T)
(GLOBALVARS SYSHASHARRAY))
(NIL HCOPYALL (LOCALVARS . T))
(HCOPYALL1 HCOPYALL1 (NOLINKFNS . T)
(GLOBALVARS SYSHASHARRAY))
(HPRINTBLOCK HPRINT RPTPRINT RPTPUT RPTEND HPRINTEND HPRINT1 HPRINSP HPRINTSP HPERR
(LOCALFREEVARS DATATYPESEEN BACKREFS CELLCOUNT RPTLAST RPTCNT U)
(NOLINKFNS . T)
(GLOBALVARS SYSHASHARRAY FCHARAR)
(ENTRIES HPRINT HPRINT1))
(NIL MAKEHVPRETTYCOMS READVARS HPINITRDTBL HVFWDCDREAD HVBAKREAD HVRPTREAD HVFWDREAD
HREAD HPRINT0 HVREADERR (NOLINKFNS . T)
(LOCALVARS . T)
(SPECVARS BACKREFS BACKREFCNT DATATYPESEEN RPTCNT RPTVAL)
(GLOBALVARS FILERDTBL)))
(GLOBALVARS HPRINTHASHARRAY HPRINTRDTBL HPBAKCHAR HPFORWRDCDRCHR HPFORWRDCHR HPFILLCHAR
HPFINALCHAR HPFILLSTRING HPRPTSTRING CIRCLMARKER DONTCOPYDATATYPES ORIGTERMSYNTAX
ORIGECHOCONTROL ORIGDELETECONTROL HPRINTMACROS)
(DECLARE: EVAL@COMPILE DONTCOPY [VARS HPFORWRDCHR HPFORWRDCDRCHR HPBAKCHAR HPFILLCHAR
HPFINALCHAR (HPFILLSTRING (PACKC (LIST HPBAKCHAR
HPFILLCHAR]
(PROP MACRO HPRINTSTRING HPRINTENDSTR))
[VARS (HPRINTMACROS)
(HPRINTHASHARRAY)
(HPRINTRDTBL)
(HPRPTSTRING "<repeat>")
(DONTCOPYDATATYPES)
ORIGDELETECONTROL ORIGTERMSYNTAX ORIGECHOCONTROL (HPRINT.SCRATCH
(SELECTQ (SYSTEMTYPE)
((TENEX TOPS20)
(QUOTE HPRINT.SCRATCH;T))
(D (QUOTE {CORE}HPRINT.SCRATCH;1))
(QUOTE HPRINT.SCRATCH]
[ADDVARS (GAINSPACEFORMS ((OR HPRINTHASHARRAY HPRINTRDTBL)
"discard HPRINT initialization"
(PROGN (CLRHASH HPRINTHASHARRAY)
(SETQ HPRINTHASHARRAY (SETQ HPRINTRDTBL]
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA HPRINT0 READVARS)
(NLAML MAKEHVPRETTYCOMS)
(LAMA])
(DEFINEQ
(MAKEHVPRETTYCOMS
[NLAMBDA (VARS FLG) (* lmm " 3-JAN-78 15:19")
(HPINITRDTBL)
(for X in VARS do (OR (LITATOM X)
(ERROR X "invalid in HORRIBLEVARS" T)))
(LIST (LIST (QUOTE P)
(CONS (FUNCTION READVARS)
VARS))
(LIST (QUOTE E)
(CONS (QUOTE HPRINT0)
(if FLG
then (CONS 0 VARS)
else VARS])
(READVARS
[NLAMBDA VARS (* lmm: " 4-JAN-77 23:32:43")
(HPINITRDTBL)
(PROG (BACKREFS (BACKREFCNT 0)
DATATYPESEEN)
(OR (EQ (RATOM NIL HPRINTRDTBL)
(QUOTE %())
(HVREADERR))
(for VAR in VARS when (LITATOM VAR) do (SAVESET VAR (READ NIL HPRINTRDTBL)
T))
(OR (EQ (RATOM NIL HPRINTRDTBL)
(QUOTE %)))
(HVREADERR])
(HPRINT0
[NLAMBDA VARS (* lmm: 30-JAN-76 7 36)
(HPRINT (for X in (COND
((EQ (CAR VARS)
0)
(CDR VARS))
(T VARS))
collect (OR (LITATOM X)
(ERROR X "not a var, in HORRIBLEVARS" T))
(GETATOMVAL X))
NIL
(EQ (CAR VARS)
0])
)
(PUTDEF (QUOTE HORRIBLEVARS) (QUOTE FILEPKGCOMS) [QUOTE ((COM MACRO (X (COMS * (MAKEHVPRETTYCOMS
X)))
CONTENTS
(LAMBDA (COM NAME TYPE)
(AND (EQ TYPE (QUOTE VARS))
(INFILECOMTAIL COM])
(PUTDEF (QUOTE UGLYVARS) (QUOTE FILEPKGCOMS) [QUOTE ((COM MACRO (X (COMS * (MAKEHVPRETTYCOMS X T)))
CONTENTS
(LAMBDA (COM NAME TYPE)
(AND (EQ TYPE (QUOTE VARS))
(INFILECOMTAIL COM])
(DEFINEQ
(HPRINT
[LAMBDA (EXPR FILE UNCIRCULAR DATATYPESEEN) (* rmk: " 3-Jan-84 13:16")
(RESETLST (PROG (BACKREFS (CELLCOUNT 0)
SIZE
(U UNCIRCULAR))
(RESETSAVE (RADIX 12Q))
[COND
(UNCIRCULAR (* Won't need the hash array))
([OR (HARRAYP HPRINTHASHARRAY)
(HARRAYP (CAR (LISTP HPRINTHASHARRAY]
(CLRHASH HPRINTHASHARRAY))
(T (SETQ HPRINTHASHARRAY (HASHARRAY 144Q]
(HPINITRDTBL)
(RESETSAVE (OUTPUT FILE))
(RESETSAVE (SETREADTABLE HPRINTRDTBL))
(COND
(UNCIRCULAR (HPRINT1 EXPR NIL NIL T))
((RANDACCESSP (OUTPUT))
(HPRINT1 EXPR)
(HPRINTEND))
(T (* If the byte pointer cannot be reset, want to output
to temp file and copy it back)
(SETQ FILE (OUTPUT))
(OUTFILE HPRINT.SCRATCH) (* Open new temporary file for IO)
(RESETSAVE NIL (LIST (QUOTE DELFILE)
(OUTPUT)))
(RESETSAVE NIL (LIST (QUOTE CLOSEF)
(OUTPUT)))
(HPRINT1 EXPR)
(HPRINTEND)
(SETQ SIZE (GETFILEPTR (OUTPUT)))
(COPYBYTES [INPUT (INFILE (CLOSEF (OUTPUT]
FILE 0 SIZE)))
(TERPRI])
(HPRINT1
[LAMBDA (X CDRFLG NOMACROSFLG NOSPFLG) (* lmm " 1-Jan-85 21:35")
(* Print the potentially self-referential structure
EXPR; if CDRFLG then this is the CDR part of a list)
(PROG (LASTSEEN HERE TYPE SIZE)
(SELECTQ (SETQ TYPE (TYPENAME X))
[(SMALLP LITATOM) (* Atom, small number, are just directly printed)
(RETURN (COND
[CDRFLG (COND
(X (PRIN1 " . ")
(PRIN2 X]
(T (PRIN2 X]
NIL)
(RETURN
(COND
[(SETQ LASTSEEN (AND (NOT U)
(GETHASH X HPRINTHASHARRAY)))
(* Seen before -
Hash value is either byte position of first place seen
(negative if CDR pointer) or
(bytepos-of-expression . byte-positions-of-backrefs))
(AND CDRFLG (PRIN1 " . "))
(PRIN1 (CONSTANT HPFILLSTRING))
[SETQ HERE (SUB1 (GETFILEPTR (OUTPUT]
[PROG ((CN CELLCOUNT))
(while (IGREATERP CN 0)
do (PRIN3 (FCHARACTER (CONSTANT HPFILLCHAR)))
(* HPFILLCHAR is 0; there is still a problem in the
system of dumping and reading back in
(CHARACTER 0))
(SETQ CN (IQUOTIENT CN 12Q]
(COND
((NLISTP LASTSEEN) (* Seen only once before)
(PUTHASH X (CAR (SETQ BACKREFS (CONS (LIST LASTSEEN HERE)
BACKREFS)))
HPRINTHASHARRAY)
NIL)
(T (* Seen at least once before -
Add this place to the list)
(FRPLACD LASTSEEN (CONS HERE (CDR LASTSEEN]
(T
(AND CDRFLG (NLISTP X)
(PRIN1 " . "))
(COND
((NOT U)
(SPACES 1)
(PUTHASH X [COND
[(AND CDRFLG (LISTP X))
(IMINUS (GETFILEPTR (OUTPUT]
(T (GETFILEPTR (OUTPUT]
HPRINTHASHARRAY)
(SETN CELLCOUNT (ADD1 CELLCOUNT)))
((NOT NOSPFLG)
(SPACES 1))) (* Now, finally get around to printing the thing -
leave space for macro char)
(COND
[(LISTP X)
(COND
(CDRFLG (HPRINT1 (CAR X))
(HPRINT1 (CDR X)
T))
(T (PRIN1 (QUOTE "("))
(HPRINT1 (CAR X)
NIL NIL T)
(HPRINT1 (CDR X)
T)
(PRIN1 (QUOTE ")"]
[(AND (NOT NOMACROSFLG)
(SETQ HERE (FASSOC TYPE HPRINTMACROS))
(PROG2 (PRIN1 (CONSTANT (CHARACTER HPBAKCHAR))
FILE)
(APPLY* (CDR HERE)
X FILE)
(HPRINTENDSTR]
(T (SELECTQ TYPE
((STRINGP FLOATP FIXP) (* string, floating point or number)
(PRIN2 X))
(ARRAYP (PROG ((SIZE (ARRAYSIZE X))
(RPTCNT 0)
(RPTLAST (CONS))
TYP
(INDEX (ARRAYORIG X)))
(HPRINTSTRING Y)
(PRIN2 SIZE)
(SPACES 1)
(PRIN2 (SETQ TYP (ARRAYTYP X)))
(SPACES 1)
(PRIN2 INDEX)
(SPACES 1)
(FRPTQ SIZE (RPTPRINT (ELT X INDEX))
(add INDEX 1))
[AND (FIXP TYP)
(NOT (EQP TYP SIZE))
(for I from (ADD1 TYP) to SIZE
do (RPTPRINT (ELTD X I]
(RPTEND)))
(HARRAYP (PROG ((RPTCNT 0)
(RPTLAST (CONS))
VALS SIZ)
(DECLARE (SPECVARS VALS))
(HPRINTSTRING H)
(SETQ SIZ (HARRAYSIZE X))
[PRIN2 (LIST SIZ (HARRAYPROP X (QUOTE OVERFLOW]
(SPACES 1)
(SELECTQ (SYSTEMTYPE)
[(TENEX TOPS20)
(* bug in Interlisp-10 MAPHASH)
(COND
((ILESSP (GCTRP)
SIZ)
(RESETFORM (MINFS (IMAX (MINFS)
SIZ))
(RECLAIM]
NIL)
[MAPHASH X (FUNCTION (LAMBDA (V K)
(push VALS K]
(PRIN2 (FLENGTH VALS))
(SPACES 1)
(while VALS
do (HPRINTSP (GETHASH (CAR VALS)
X))
(HPRINTSP (CAR VALS))
(SETQ VALS (CDR VALS)))
(HPRINTENDSTR)))
[READTABLEP (* should dump the READMACROS flag too -
doesn't now and won't until READMACROS takes a RDTBL
arg)
(PROG ((RPTCNT 0)
(RPTLAST (CONS)))
(HPRINTSTRING D)
(for I in (PRIN2 (for I from 0 to 177Q
when [NOT (EQUAL (GETSYNTAX I X)
(GETSYNTAX I (QUOTE ORIG]
collect I))
do (RPTPRINT (GETSYNTAX I X)))
(RETURN (RPTEND]
(TERMTABLEP (HPRINTSTRING T)
[COND
((GETCONTROL X)
(HPRINSP (QUOTE CONTROL]
[COND
((NOT (GETECHOMODE X))
(HPRINSP (QUOTE ECHOMODE]
(SELECTQ (GETRAISE X)
(T (HPRINSP T))
(0 (HPRINSP 0))
NIL)
[COND
((EQ (QUOTE NOECHO)
(GETDELETECONTROL (QUOTE ECHO)
X))
(HPRINSP (QUOTE NOECHO]
(for PROP in (QUOTE (CTRLV RETYPE LINEDELETE CHARDELETE EOL)
)
unless (EQUAL (GETSYNTAX PROP X)
(GETSYNTAX PROP (QUOTE ORIG)))
do (HPRINSP PROP)
(HPRINSP (GETSYNTAX PROP X)))
[for I from 0 to \MAXTHINCHAR
do (COND
([NOT (EQUAL (ECHOCHAR I NIL X)
(ECHOCHAR I NIL (QUOTE ORIG]
(HPRINSP (ECHOCHAR I NIL X))
(HPRINSP I]
[for PR in (QUOTE (DELETELINE 1STCHDEL NTHCHDEL POSTCHDEL
EMPTYCHDEL))
do (COND
([NOT (EQUAL (DELETECONTROL PR NIL (QUOTE ORIG))
(SETQ TYPE (DELETECONTROL PR NIL X]
(HPRINSP PR)
(HPRINSP TYPE]
(PRIN2) (* end with a NIL)
(HPRINTENDSTR))
(VAG (HPRINTSTRING #)
(PRIN2 (LOC X))
(HPRINTENDSTR))
(BITMAP (HPRINTSTRING %()
(PRIN1 "READBITMAP)")
(PRINTBITMAP X)
(HPRINTENDSTR))
(COND
[(SETQ HERE (GETFIELDSPECS TYPE))
[COND
((EQ DATATYPESEEN T)
(HPRINTSTRING ~)
(PRIN2 TYPE)
(SPACES 1))
(T (HPRINTSTRING $)
(PRIN2 TYPE)
(SPACES 1)
(COND
((NOT (FASSOC TYPE DATATYPESEEN))
(SETQ DATATYPESEEN (CONS (CONS TYPE (PRIN2 HERE))
DATATYPESEEN]
(PROG ((RPTCNT 0)
(RPTLAST (CONS)))
(for Y in (GETDESCRIPTORS TYPE)
do (RPTPRINT (FETCHFIELD Y X)))
(RETURN (RPTEND]
(T (HPERR "cannot print this item" X])
(HPRINTEND
[LAMBDA NIL (* lmm: "29-NOV-76 16:11:02")
(PROG [(HERE (GETFILEPTR (OUTPUT]
[SORT BACKREFS (FUNCTION (LAMBDA (X Y)
(ILESSP (ABS (CAR X))
(ABS (CAR Y]
(for X in BACKREFS as I from 1
do [SETFILEPTR (OUTPUT)
(SUB1 (ABS (CAR X]
[PRIN3 (COND
((MINUSP (CAR X))
(CONSTANT (CHARACTER HPFORWRDCDRCHR)))
(T (CONSTANT (CHARACTER HPFORWRDCHR]
(for Z in (DREVERSE (CDR X))
do (SETFILEPTR (OUTPUT)
Z)
(PRIN3 I)
(HPRINTENDSTR T)))
(SETFILEPTR (OUTPUT)
HERE])
(RPTPRINT
[LAMBDA (X FLAG)
(COND
((OR (EQ X RPTLAST)
(AND FLAG (EQP X RPTLAST)))
(SETQ RPTCNT (ADD1 RPTCNT)))
(T (RPTPUT RPTCNT RPTLAST)
(SETQ RPTLAST X)
(SETQ RPTCNT 1])
(RPTEND
[LAMBDA NIL (* lmm: "29-NOV-76 16:11:40")
(RPTPUT RPTCNT RPTLAST)
(HPRINTENDSTR])
(RPTPUT
[LAMBDA (CNT ITEM FLAG) (* lmm "11-SEP-78 03:22")
(COND
[(AND (ILESSP CNT 4)
(OR FLAG (LITATOM ITEM)
(SMALLP ITEM)))
(FRPTQ CNT (PROGN (PRIN2 ITEM)
(PRIN1 (QUOTE % ]
((ILESSP CNT 2)
(FRPTQ CNT (HPRINTSP ITEM)))
(T (HPRINTSTRING R)
(PRIN2 CNT)
(PRIN1 " ")
(HPRINT1 ITEM)
(HPRINTENDSTR)
(SPACES 1])
(HPRINTSP
[LAMBDA (X)
(HPRINT1 X)
(PRIN1 " "])
(HPERR
[LAMBDA (A1 A2)
(PRIN1 A1 T)
(SPACES 2 T)
(PRINT A2 T T)
(PRIN2 A2])
(HVFWDCDREAD
[LAMBDA (FILE RDTBL TCONCPTR) (* Do setq so that if the READ adds things to the BACKREF list, it will still be
correct)
(TCONC TCONCPTR NIL)
(SETQ BACKREFCNT (ADD1 BACKREFCNT))
(SETQ BACKREFS (CONS (CDR TCONCPTR)
BACKREFS))
(FRPLACA (CAR BACKREFS)
(READ FILE RDTBL))
TCONCPTR])
(HVBAKREAD
[LAMBDA (FILE RDTBL BKRF) (* lmm " 1-Jan-85 21:31")
(PROG (HV HV1 HV2 HV3 (RPTCNT 0)
RPTVAL READVAL)
READLP
(SKIPSEPRS FILE RDTBL)
(SELECTQ (SETQ HV (READC FILE))
[} (* Empty printout from false start for HPRINTMACRO.
Next char should be { and be default)
(SKIPSEPRS FILE RDTBL)
(COND
((EQ (QUOTE {)
(READC FILE))
(GO READLP))
(T (HVREADERR]
(H (* Hash array)
[SETQ READVAL (COND
((EQ (SKIPSEPRS FILE RDTBL)
(QUOTE %())
(APPLY (FUNCTION HASHARRAY)
(READ FILE RDTBL)))
(T (HARRAY (RATOM FILE RDTBL]
(AND BKRF (FRPLACA BKRF READVAL))
(FRPTQ (RATOM FILE RDTBL)
(PROGN (SETQ HV (READ FILE RDTBL))
(PUTHASH (READ FILE RDTBL)
HV READVAL)))
(HVREADEND FILE RDTBL))
((A Y) (* array)
[SETQ READVAL (ARRAY (SETQ HV1 (READ FILE RDTBL))
(SETQ HV2 (READ FILE RDTBL))
NIL
(SETQ HV3 (SELECTQ HV
(Y (READ FILE RDTBL))
1]
(AND BKRF (FRPLACA BKRF READVAL))
(FRPTQ (ARRAYSIZE READVAL)
(PROGN (SETA READVAL HV3 (HVRPTREAD FILE RDTBL))
(add HV3 1)))
[AND (FIXP HV2)
(NOT (IEQP HV1 HV2))
(OR (EQ HV (QUOTE Y))
(NOT (ZEROP HV2)))
(for I from (ADD1 HV2) to HV1 do (SETD READVAL I (HVRPTREAD FILE RDTBL]
(HVREADEND FILE RDTBL))
(($ ~) (* DATATYPE)
(SETQ HV1 (RATOM FILE RDTBL))
[COND
((EQ HV (QUOTE ~)) (* This should be a previously known datatype not
specified in file)
(SETQ HV2 (GETDESCRIPTORS HV1)))
([NOT (SETQ HV2 (CDR (FASSOC HV1 DATATYPESEEN]
(SETQ HV2 (READ FILE RDTBL))
(OR (NULL (GETFIELDSPECS HV1))
(EQUAL HV2 (GETFIELDSPECS HV1))
(ERROR
"attempt to read DATATYPE with different field specification than currently defined"
HV1))
(SETQ DATATYPESEEN (CONS (CONS HV1 (SETQ HV2 (/DECLAREDATATYPE HV1 HV2)))
DATATYPESEEN]
(SETQ READVAL (NCREATE HV1))
(AND BKRF (FRPLACA BKRF READVAL))
(for X in HV2 do (REPLACEFIELD X READVAL (HVRPTREAD FILE RDTBL)))
(HVREADEND FILE RDTBL))
(R (* repeat)
(AND BKRF (HVREADERR))
(RETURN HPRPTSTRING))
[# (* Kludge for (VAG smallnumber))
(RETURN (PROG1 (VAG (RATOM FILE RDTBL))
(HVREADEND FILE RDTBL]
[! (* ! -
value cell)
(RETURN (AT2VC (RATOM FILE RDTBL]
(D (* READTABLEP)
(SETQ READVAL (COPYREADTABLE (QUOTE ORIG)))
(AND BKRF (FRPLACA BKRF READVAL))
(for I in (READ FILE RDTBL) do (SETSYNTAX I (HVRPTREAD FILE RDTBL)
READVAL))
(HVREADEND FILE RDTBL))
(T (* TERMTABLEP)
(SETQ READVAL (COPYTERMTABLE (QUOTE ORIG)))
(AND BKRF (FRPLACA BKRF READVAL))
(while (SETQ HV (RATOM FILE RDTBL))
do (SELECTQ HV
(CONTROL (CONTROL T READVAL))
(ECHOMODE (ECHOMODE NIL READVAL))
((UPARROW IGNORE REAL SIMULATE)
(ECHOCHAR (READ FILE RDTBL)
HV READVAL))
[(CTRLV RETYPE LINEDELETE CHARDELETE EOL)
(MAPC (READ FILE FILERDTBL)
(FUNCTION (LAMBDA (CH)
(SETSYNTAX CH HV READVAL]
((DELETELINE 1STCHDEL NTHCHDEL POSTCHDEL EMPTYCHDEL)
(DELETECONTROL HV (READ FILE RDTBL)
READVAL))
((T 0)
(RAISE HV READVAL))
(NOECHO (DELETECONTROL (QUOTE NOECHO)
NIL READVAL))
(HVREADERR)))
(HVREADEND FILE RDTBL))
[(0 1 2 3 4 5 6 7 10Q 11Q) (* immediately followed by a number)
(AND BKRF (HVREADERR)) (* BACK REFERENCE -
shouldn't be forward reference as well)
(SETQ HV2 HV)
(while (SMALLP (SETQ HV (READC FILE))) do (SETQ HV2 (IPLUS (ITIMES HV2 12Q)
HV)))
(RETURN (OR [CAR (FNTH BACKREFS (ADD1 (IDIFFERENCE BACKREFCNT HV2]
(HVREADERR]
(%( (SETQ READVAL (PROG1 (APPLY* (PROG1 (READ FILE RDTBL)
(RATOM FILE RDTBL))
FILE)
(HVREADEND FILE RDTBL)))
(AND BKRF (FRPLACA BKRF READVAL))
(RETURN READVAL))
(HVREADERR))
(OR (ZEROP RPTCNT)
(HVREADERR))
(RETURN READVAL])
(HVREADEND
[LAMBDA (FILE RDTBL) (* lmm "21-APR-82 11:25")
(bind CHAR until (EQ (SETQ CHAR (CHCON1 (READC FILE)))
(CONSTANT HPFINALCHAR))
do (OR (SYNTAXP CHAR (QUOTE SEPR)
RDTBL)
(HVREADERR])
(HVRPTREAD
[LAMBDA (FILE RDTBL) (* lmm " 2-APR-82 23:26")
(PROG NIL
LOOP(COND
((IGREATERP RPTCNT 0)
(SETQ RPTCNT (SUB1 RPTCNT))
(RETURN RPTVAL))
((EQ (SETQ RPTVAL (READ FILE RDTBL))
HPRPTSTRING)
(SETQ RPTCNT (READ FILE RDTBL))
(SETQ RPTVAL (READ FILE RDTBL))
(HVREADEND FILE RDTBL)
(GO LOOP))
(T (RETURN RPTVAL])
(HVFWDREAD
[LAMBDA (FILE RDTBL) (* lmm: "29-NOV-76 15:56:19")
(PROG (CH VAL)
(SETQ BACKREFCNT (ADD1 BACKREFCNT))
(SETQ BACKREFS (CONS NIL BACKREFS))
LP (SELECTQ (SETQ CH (PEEKC FILE))
[%( (FRPLACA BACKREFS (CONS))
(RETURN (FRPLNODE2 (CAR BACKREFS)
(READ FILE RDTBL]
((%
% )
(READC FILE)
(GO LP))
(COND
((EQ CH (CONSTANT (CHARACTER HPBAKCHAR)))
(READC FILE)
(SETQ VAL (HVBAKREAD FILE RDTBL (SETQ CH BACKREFS)))
(OR (CAR CH)
(HVREADERR))
(RETURN VAL))
(T (RETURN (CAR (FRPLACA BACKREFS (READ FILE RDTBL])
(HREAD
[LAMBDA (FILE) (* lmm: 23Q MAY 113Q 473Q)
(PROG [BACKREFS (BACKREFCNT 0)
DATATYPESEEN
(FILE (INPUT (INPUT FILE]
(OR (READTABLEP HPRINTRDTBL)
(HPINITRDTBL))
(RETURN (READ FILE HPRINTRDTBL])
(HPINITRDTBL
[LAMBDA NIL (* lmm " 5-JAN-78 23:23")
(COND
([NOT (READTABLEP (GETATOMVAL (QUOTE HPRINTRDTBL]
(PROG [(RDTBL (COPYREADTABLE (QUOTE ORIG]
(SETSYNTAX (CONSTANT HPFORWRDCHR)
(LIST (QUOTE MACRO)
(FUNCTION HVFWDREAD))
RDTBL)
(SETSYNTAX (CONSTANT HPFORWRDCDRCHR)
(LIST (QUOTE INFIX)
(FUNCTION HVFWDCDREAD))
RDTBL)
(SETSYNTAX (CONSTANT HPBAKCHAR)
(LIST (QUOTE MACRO)
(FUNCTION HVBAKREAD))
RDTBL)
(SETSYNTAX (CONSTANT HPFILLCHAR)
(QUOTE SEPR)
RDTBL)
(SETSYNTAX (CONSTANT HPFINALCHAR)
(QUOTE SEPR)
RDTBL)
(/SETATOMVAL (QUOTE HPRINTRDTBL)
RDTBL))
T])
(HVREADERR
[LAMBDA (M1 M2)
(ERROR (OR M1 "incorrect format on file")
(OR M2 (QUOTE (in HREAD])
(HPRINSP
[LAMBDA (X) (* lmm: "29-NOV-76 17:41:47")
(PRIN2 X)
(SPACES 1])
)
(DEFINEQ
(COPYALL
[LAMBDA (X) (* bvm: " 7-Feb-85 21:23")
(COND
((LISTP X)
(PROG [TAIL (VAL (LIST (COPYALL (CAR X]
(SETQ TAIL VAL)
LP (COND
((NLISTP (SETQ X (CDR X)))
(AND X (RPLACD TAIL (COPYALL X)))
(RETURN VAL)))
[RPLACD TAIL (SETQ TAIL (CONS (COPYALL (CAR X]
(GO LP)))
((OR (LITATOM X)
(SMALLP X))
X)
(T (PROG ((TN (TYPENAME X)))
(RETURN (COND
((FMEMB TN DONTCOPYDATATYPES)
X)
(T (SELECTQ TN
(STRINGP (CONCAT X))
(FLOATP (FPLUS X))
(FIXP (IPLUS X))
(HARRAYP (* Hash array)
(PROG [(NH (HASHARRAY (HARRAYSIZE X)
(HARRAYPROP X (QUOTE OVERFLOW]
(DECLARE (SPECVARS NH))
[MAPHASH X (FUNCTION (LAMBDA (X Y)
(PUTHASH (COPYALL Y)
(COPYALL X)
NH]
(RETURN NH)))
(READTABLEP (COPYREADTABLE X))
(TERMTABLEP (COPYTERMTABLE X))
[ARRAYP (PROG ((SIZE (ARRAYSIZE X))
(TYPE (ARRAYTYP X))
(ORIG (ARRAYORIG X))
NEW)
(RETURN (PROG1 (SETQ NEW
(ARRAY SIZE TYPE NIL ORIG))
(FRPTQ SIZE
(SETA NEW ORIG
(COPYALL (ELT X ORIG)))
(add ORIG 1]
(BITMAP (BITMAPCOPY X))
(CCODEP X)
(PROG (D NEW)
(COND
((SETQ D (GETDESCRIPTORS X))
(SETQ NEW (NCREATE TN X))
[for FIELD in D do (REPLACEFIELD FIELD NEW
(COPYALL
(FETCHFIELD FIELD X]
(RETURN NEW))
(T (RETURN X])
(HCOPYALL
[LAMBDA (X) (* rmk: " 3-Jan-84 13:16")
[COND
([OR (HARRAYP HPRINTHASHARRAY)
(HARRAYP (CAR (LISTP HPRINTHASHARRAY]
(CLRHASH HPRINTHASHARRAY))
(T (SETQ HPRINTHASHARRAY (HASHARRAY 100]
(HCOPYALL1 X])
(HCOPYALL1
[LAMBDA (X) (* bvm: " 7-Feb-85 21:25")
(COND
((OR (LITATOM X)
(SMALLP X))
X)
(T (PROG ((TYPE (TYPENAME X))
SEEN NEW)
(RETURN (COND
((FMEMB (SETQ TYPE (TYPENAME X))
DONTCOPYDATATYPES)
X)
(T (OR (GETHASH X HPRINTHASHARRAY)
(SELECTQ TYPE
[LISTP (FRPLNODE (PUTHASH X (CONS)
HPRINTHASHARRAY)
(HCOPYALL1 (CAR X))
(HCOPYALL1 (CDR X]
(STRINGP (PUTHASH X (CONCAT X)
HPRINTHASHARRAY))
(FLOATP (PUTHASH X (FPLUS X)
HPRINTHASHARRAY))
(FIXP (PUTHASH X (IPLUS X)
HPRINTHASHARRAY))
(ARRAYP (PROG ((SIZE (ARRAYSIZE X))
(TYP (ARRAYTYP X))
(ORIG (ARRAYORIG X)))
(* Regular array)
(PUTHASH X (SETQ NEW
(ARRAY SIZE TYP NIL ORIG))
HPRINTHASHARRAY)
(FRPTQ SIZE (SETA NEW ORIG
(HCOPYALL1 (ELT X ORIG)))
(add ORIG 1))
(RETURN NEW)))
(HARRAYP (PUTHASH X [SETQ NEW (HASHARRAY
(HARRAYSIZE X)
(HARRAYPROP X (QUOTE OVERFLOW]
HPRINTHASHARRAY)
[PROG ((NH NEW))
(DECLARE (SPECVARS NH))
(MAPHASH X (FUNCTION (LAMBDA (X Y)
(PUTHASH (HCOPYALL1 Y)
(HCOPYALL1 X)
NEW]
NEW)
(READTABLEP (COPYREADTABLE X))
(BITMAP (PUTHASH X (BITMAPCOPY X)
HPRINTHASHARRAY))
(TERMTABLEP (COPYTERMTABLE X))
(COND
((SETQ SEEN (GETDESCRIPTORS TYPE))
(PUTHASH X (SETQ NEW (NCREATE TYPE))
HPRINTHASHARRAY)
[for FIELD in SEEN
do (REPLACEFIELD FIELD NEW (HCOPYALL1 (FETCHFIELD
FIELD X]
NEW)
(T X])
)
(DEFINEQ
(EQUALALL
[LAMBDA (X Y) (* lmm "18-JUL-83 16:59")
(OR (EQ X Y)
(PROG ((TY (TYPENAME Y))
TEM)
(RETURN (AND (EQ TY (TYPENAME X))
(SELECTQ TY
((LITATOM SMALLP) (* not eq, so not equal)
NIL)
(FIXP (IEQP X Y))
(FLOATP (EQP X Y))
[LISTP (AND (EQUALALL (CAR X)
(CAR Y))
(EQUALALL (CDR X)
(CDR Y]
(STRINGP (STREQUAL X Y))
[ARRAYP (AND (EQ (ARRAYORIG X)
(ARRAYORIG Y))
(EQUAL (ARRAYTYP X)
(ARRAYTYP Y))
(EQUAL (SETQ TEM (ARRAYSIZE X))
(ARRAYSIZE Y))
(for I from (ARRAYORIG X) as J to TEM
always (EQUALALL (ELT X I)
(ELT Y I]
(HARRAYP (EQUALHASH X Y))
[READTABLEP (for I from 0 to 127 always (EQUALALL (GETSYNTAX
I X)
(GETSYNTAX
I Y]
[TERMTABLEP (AND (EQ (GETCONTROL X)
(GETCONTROL Y))
(EQ (GETRAISE X)
(GETRAISE Y))
(EQ (GETECHOMODE X)
(GETECHOMODE Y))
(EQ (GETDELETECONTROL X)
(GETDELETECONTROL Y))
[EVERY ORIGTERMSYNTAX
(FUNCTION (LAMBDA (Z)
(EQUAL (GETSYNTAX (CAR Z)
X)
(GETSYNTAX (CAR Z)
Y]
(for I from 0 to 31
always (EQ (ECHOCONTROL I NIL X)
(ECHOCONTROL I NIL Y)))
(EVERY ORIGDELETECONTROL
(FUNCTION (LAMBDA (Z)
(EQUAL (DELETECONTROL (CAR Z)
NIL X)
(DELETECONTROL (CAR Z)
NIL Y]
(OR (EQP X Y)
(AND (SETQ TY (GETDESCRIPTORS TY))
(for FIELD in TY always (EQUALALL (FETCHFIELD FIELD X)
(FETCHFIELD FIELD Y])
(EQUALHASH
[LAMBDA (AR1 AR2)
(DECLARE (SPECVARS AR1 AR2)) (* rmk: "26-Dec-83 13:33")
(* What does it mean for two hash arrays to be EQUAL?)
[PROG (UNMATCHED)
(OR (EQUAL (HARRAYPROP AR1 (QUOTE OVERFLOW))
(HARRAYPROP AR2 (QUOTE OVERFLOW)))
(RETURN))
[MAPHASH AR1 (FUNCTION (LAMBDA (VAL KEY)
(COND
[(LITATOM KEY)
(OR (EQUALALL (GETHASH KEY AR2)
VAL)
(RETFROM (FUNCTION EQUALHASH]
(T (SETQ UNMATCHED (CONS KEY UNMATCHED]
(MAPHASH AR2 (FUNCTION (LAMBDA (VAL KEY)
(COND
[(LITATOM KEY)
(OR (GETHASH KEY AR1)
(RETFROM (FUNCTION EQUALHASH]
([NOT (SOME UNMATCHED (FUNCTION (LAMBDA (Y)
(AND (EQUALALL KEY Y)
(EQUALALL VAL (GETHASH Y AR1]
(RETFROM (FUNCTION EQUALHASH]
T])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: COPYALL COPYALL (NOLINKFNS . T)
(GLOBALVARS SYSHASHARRAY))
(BLOCK: EQUALALL EQUALALL EQUALHASH (RETFNS EQUALHASH)
(NOLINKFNS . T)
(GLOBALVARS SYSHASHARRAY))
(BLOCK: NIL HCOPYALL (LOCALVARS . T))
(BLOCK: HCOPYALL1 HCOPYALL1 (NOLINKFNS . T)
(GLOBALVARS SYSHASHARRAY))
(BLOCK: HPRINTBLOCK HPRINT RPTPRINT RPTPUT RPTEND HPRINTEND HPRINT1 HPRINSP HPRINTSP HPERR
(LOCALFREEVARS DATATYPESEEN BACKREFS CELLCOUNT RPTLAST RPTCNT U)
(NOLINKFNS . T)
(GLOBALVARS SYSHASHARRAY FCHARAR)
(ENTRIES HPRINT HPRINT1))
(BLOCK: NIL MAKEHVPRETTYCOMS READVARS HPINITRDTBL HVFWDCDREAD HVBAKREAD HVRPTREAD HVFWDREAD HREAD
HPRINT0 HVREADERR (NOLINKFNS . T)
(LOCALVARS . T)
(SPECVARS BACKREFS BACKREFCNT DATATYPESEEN RPTCNT RPTVAL)
(GLOBALVARS FILERDTBL))
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS HPRINTHASHARRAY HPRINTRDTBL HPBAKCHAR HPFORWRDCDRCHR HPFORWRDCHR HPFILLCHAR HPFINALCHAR
HPFILLSTRING HPRPTSTRING CIRCLMARKER DONTCOPYDATATYPES ORIGTERMSYNTAX ORIGECHOCONTROL
ORIGDELETECONTROL HPRINTMACROS)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(RPAQQ HPFORWRDCHR 94)
(RPAQQ HPFORWRDCDRCHR 96)
(RPAQQ HPBAKCHAR 123)
(RPAQQ HPFILLCHAR 0)
(RPAQQ HPFINALCHAR 125)
(RPAQ HPFILLSTRING (PACKC (LIST HPBAKCHAR HPFILLCHAR)))
(PUTPROPS HPRINTSTRING MACRO [X (LIST (QUOTE PRIN1)
(KWOTE (CONCAT (CHARACTER HPBAKCHAR)
(CAR X])
(PUTPROPS HPRINTENDSTR MACRO [X (COND
[(CAR X)
(QUOTE (PRIN3 (CONSTANT (CHARACTER HPFINALCHAR]
(T (QUOTE (PRIN1 (CONSTANT (CHARACTER HPFINALCHAR])
)
(RPAQQ HPRINTMACROS NIL)
(RPAQQ HPRINTHASHARRAY NIL)
(RPAQQ HPRINTRDTBL NIL)
(RPAQ HPRPTSTRING "<repeat>")
(RPAQQ DONTCOPYDATATYPES NIL)
(RPAQQ ORIGDELETECONTROL ((DELETELINE . "##
")
(1STCHDEL . "\")
(NTHCHDEL . "")
(POSTCHDEL . "\")
(EMPTYCHDEL . "##
")))
(RPAQQ ORIGTERMSYNTAX ((CTRLV 22)
(RETYPE 18)
(LINEDELETE 17)
(CHARDELETE 1)
(EOL 31)))
(RPAQQ ORIGECHOCONTROL ((0 . IGNORE)
(1 . IGNORE)
(7 . REAL)
(8 . UPARROW)
(9 . SIMULATE)
(10 . REAL)
(13 . REAL)
(17 . IGNORE)
(18 . IGNORE)
(27 . SIMULATE)
(31 . REAL)))
(RPAQ HPRINT.SCRATCH (SELECTQ (SYSTEMTYPE)
((TENEX TOPS20)
(QUOTE HPRINT.SCRATCH;T))
(D (QUOTE {CORE}HPRINT.SCRATCH;1))
(QUOTE HPRINT.SCRATCH)))
(ADDTOVAR GAINSPACEFORMS [(OR HPRINTHASHARRAY HPRINTRDTBL)
"discard HPRINT initialization"
(PROGN (CLRHASH HPRINTHASHARRAY)
(SETQ HPRINTHASHARRAY (SETQ HPRINTRDTBL])
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA HPRINT0 READVARS)
(ADDTOVAR NLAML MAKEHVPRETTYCOMS)
(ADDTOVAR LAMA )
)
(PUTPROPS HPRINT COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2576 3730 (MAKEHVPRETTYCOMS 2586 . 2968) (READVARS 2970 . 3407) (HPRINT0 3409 . 3728))
(4208 23312 (HPRINT 4218 . 5638) (HPRINT1 5640 . 13362) (HPRINTEND 13364 . 13994) (RPTPRINT 13996 .
14201) (RPTEND 14203 . 14335) (RPTPUT 14337 . 14714) (HPRINTSP 14716 . 14780) (HPERR 14782 . 14879) (
HVFWDCDREAD 14881 . 15226) (HVBAKREAD 15228 . 20708) (HVREADEND 20710 . 20969) (HVRPTREAD 20971 .
21379) (HVFWDREAD 21381 . 22046) (HREAD 22048 . 22372) (HPINITRDTBL 22374 . 23087) (HVREADERR 23089 .
23197) (HPRINSP 23199 . 23310)) (23313 27757 (COPYALL 23323 . 25308) (HCOPYALL 25310 . 25602) (
HCOPYALL1 25604 . 27755)) (27758 30608 (EQUALALL 27768 . 29674) (EQUALHASH 29676 . 30606)))))
STOP