(FILECREATED "22-JUL-83 01:13:03" <NEWLISP>HPRINT.;3 32516
changes to: (FNS HPRINT HPRINT1 GETDELETECONTROL)
previous date: "18-JUL-83 17:00:02" <NEWLISP>HPRINT.;1)
(* Copyright (c) 1982, 1983 by Xerox Corporation)
(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]
(FNS GETDELETECONTROL GETRAISE GETCONTROL GETECHOMODE)
[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)
(* lmm "22-JUL-83 01:10")
(RESETLST (PROG (BACKREFS (CELLCOUNT 0)
SIZE
(U UNCIRCULAR))
(RESETSAVE (RADIX 10))
[COND
(UNCIRCULAR
(* Won't need the hash array))
((HARRAYP (CAR (LISTP HPRINTHASHARRAY)))
(CLRHASH HPRINTHASHARRAY))
(T (SETQ HPRINTHASHARRAY (LIST (HARRAY 100]
(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 "22-JUL-83 01:09")
(* 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 10]
(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 (PRIN2 (HARRAYSIZE X)))
(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 127
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]
[INTERRUPTABLE (PROG1 (INTERRUPTABLE)
(COND
((NOT (ECHOMODE T X))
(ECHOMODE NIL X)
(HPRINSP (QUOTE ECHOMODE]
(INTERRUPTABLE (PROG1 (INTERRUPTABLE)
(SELECTQ (RAISE NIL X)
(T (RAISE T X)
(HPRINSP T))
(0 (RAISE 0 X)
(HPRINSP 0))
NIL)))
[INTERRUPTABLE (PROG1 (INTERRUPTABLE)
(COND
((EQ (QUOTE NOECHO)
(DELETECONTROL (QUOTE ECHO)
X))
(DELETECONTROL (QUOTE NOECHO))
(HPRINSP (QUOTE NOECHO]
(for PR in ORIGTERMSYNTAX
unless (EQUAL (GETSYNTAX (CAR PR)
X)
(CDR PR))
do (HPRINSP (CAR PR))
(HPRINSP (GETSYNTAX (CAR PR)
X)))
[for I from 0 to 31
do (COND
((NEQ (ECHOCONTROL I NIL X)
(OR (CDR (FASSOC I ORIGECHOCONTROL))
(QUOTE UPARROW)))
(HPRINSP (ECHOCONTROL I NIL X))
(HPRINSP I]
[for PR in ORIGDELETECONTROL
do (COND
([NOT (EQUAL (CDR PR)
(SETQ TYPE (DELETECONTROL
(CAR PR)
NIL X]
(HPRINSP (CAR 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 "15-DEC-82 00:50")
(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 (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 DATATYPESEEN (CONS [CONS HV1 (SETQ HV2 (/DECLAREDATATYPE HV1
(READ FILE
RDTBL]
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)
(ECHOCONTROL (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 8 9)
(* 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 10)
HV)))
(RETURN (OR [CAR (FNTH BACKREFS (ADD1 (IDIFFERENCE BACKREFCNT HV2]
(HVREADERR]
(%( (SETQ READVAL (PROG1 (APPLY* (PROG1 (READ FILE RDTBL)
(RATOM FILE RDTBL)))
(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: 19 MAY 75 315)
(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) (* lmm "16-APR-82 22:20")
(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 (HARRAY (HARRAYSIZE X]
(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) (* lmm "11-SEP-78 01:38")
[COND
((HARRAYP (CAR (LISTP HPRINTHASHARRAY)))
(CLRHASH HPRINTHASHARRAY))
(T (SETQ HPRINTHASHARRAY (CONS (HARRAY 100]
(HCOPYALL1 X])
(HCOPYALL1
[LAMBDA (X) (* lmm " 4-MAR-83 23:43")
(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 (HARRAY (HARRAYSIZE X)))
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)) (* What does it mean for two hash arrays to be EQUAL?)
[PROG (UNMATCHED)
[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
(ADDTOVAR 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)))
(DEFINEQ
(GETDELETECONTROL
[LAMBDA (TYPE TTBL) (* lmm "21-JUL-83 23:22")
(COND
((FMEMB TYPE (QUOTE (NOECHO ECHO)))
(PROG (R)
(* kludgeness of reading twice is necessary because of the types ECHO and NOECHO which actually change even if the
message to DELETECONTROL is NIL -
(I didn't design it. rrb))
(SETQ TTBL (GETTERMTABLE TTBL))
(INTERRUPTABLE (PROG1 (INTERRUPTABLE)
(DELETECONTROL (SETQ R (DELETECONTROL TYPE NIL TTBL))
NIL TTBL)))
(RETURN R)))
(T (DELETECONTROL TYPE NIL TTBL])
(GETRAISE
[LAMBDA (TTBL) (* lmm "21-SEP-78 22:52")
(PROG (R)
(INTERRUPTABLE (PROG1 (INTERRUPTABLE)
(RAISE (SETQ R (RAISE NIL TTBL))
TTBL)))
(RETURN R])
(GETCONTROL
[LAMBDA (TTBL) (* lmm "21-SEP-78 22:52")
(PROG (R)
(INTERRUPTABLE (PROG1 (INTERRUPTABLE)
(CONTROL (SETQ R (CONTROL NIL TTBL))
TTBL)))
(RETURN R])
(GETECHOMODE
[LAMBDA (TTBL) (* lmm "21-SEP-78 22:52")
(PROG (R)
(INTERRUPTABLE (PROG1 (INTERRUPTABLE)
(ECHOMODE (SETQ R (ECHOMODE T TTBL))
TTBL)))
(RETURN R])
)
(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))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2641 3838 (MAKEHVPRETTYCOMS 2653 . 3047) (READVARS 3051 . 3500) (HPRINT0 3504 . 3835))
(4328 21739 (HPRINT 4340 . 5623) (HPRINT1 5627 . 12738) (HPRINTEND 12742 . 13391) (RPTPRINT 13395 .
13608) (RPTEND 13612 . 13747) (RPTPUT 13751 . 14143) (HPRINTSP 14147 . 14214) (HPERR 14218 . 14320) (
HVFWDCDREAD 14324 . 14678) (HVBAKREAD 14682 . 19101) (HVREADEND 19105 . 19370) (HVRPTREAD 19374 .
19795) (HVFWDREAD 19799 . 20484) (HREAD 20488 . 20761) (HPINITRDTBL 20765 . 21503) (HVREADERR 21507 .
21618) (HPRINSP 21622 . 21736)) (21741 25531 (COPYALL 21753 . 23452) (HCOPYALL 23456 . 23698) (
HCOPYALL1 23702 . 25528)) (25533 28235 (EQUALALL 25545 . 27510) (EQUALHASH 27514 . 28232)) (30765
32068 (GETDELETECONTROL 30777 . 31377) (GETRAISE 31381 . 31605) (GETCONTROL 31609 . 31834) (
GETECHOMODE 31838 . 32065)))))
STOP