(FILECREATED "18-Mar-86 16:07:12" {ERIS}<LISPCORE>SOURCES>HPRINT.;9 44302
changes to: (FNS HVREADCHECKGETFN HVBAKREAD)
(VARS HPRINTCOMS)
previous date: "21-Apr-85 15:30:53" {ERIS}<LISPCORE>SOURCES>HPRINT.;6)
(* Copyright (c) 1982, 1983, 1984, 1985, 1986 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
HVREADCHECKGETFN HVREADEND HVRPTREAD HVFWDREAD HREAD HPINITRDTBL HVREADERR HPRINSP)
(FNS COPYALL \COPYDATATYPE \COPYARRAYBLOCK 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 (HPRINTREADFNS READBITMAP))
[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) (* rrb
"18-Mar-86 15:40")
(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 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))))
(%( (* form that should
be evaluated with its
first argument replaced
with the file being
read. This is the case
that handle IMAGEOBJs.)
(SETQ READVAL
(PROG1 [APPLY (HVREADCHECKGETFN (READ FILE RDTBL))
(CONS FILE (PROGN (* dump the first
argument which is a
dummy so that the call
that is on the file
looks like a realy
call.)
(CDR (until (PROGN (SKIPSEPRS FILE RDTBL)
(EQ (PEEKC FILE)
(QUOTE %))))
collect (EVAL (READ FILE RDTBL))
finally (* read the closing
(QUOTE %)))
(RATOM FILE RDTBL]
(HVREADEND FILE RDTBL)))
(AND BKRF (FRPLACA BKRF READVAL))
(RETURN READVAL))
(HVREADERR))
(OR (ZEROP RPTCNT)
(HVREADERR))
(RETURN READVAL])
(HVREADCHECKGETFN
[LAMBDA (FN) (* rrb
"18-Mar-86 16:06")
(* if in the context
of reading an image
object, make sure the
get function is a known
one.)
(COND
((EQ FN (QUOTE READIMAGEOBJ)) (* common case)
FN)
[(AND (BOUNDP UNDERREADIMAGEOBJ)
(EQ UNDERREADIMAGEOBJ T)) (* This is an HREAD
that came from an Image
object and hence needs
to be safe.)
(PROG NIL
LP (COND
((MEMB FN HPRINTREADFNS)
(RETURN FN))
((NOT (GETD FN)) (* headed for an
undefined function
error anyway)
(\LISPERROR FN 46 T) (* user may have
loaded a package during
the break.)
(GO LP))
((MOUSECONFIRM (CONCAT "Trying to read an IMAGEOBJ with GETFN " FN ". " FN
" is NOT registered. Should I use it anyway?")
NIL NIL NIL)
(RETURN FN))
(T (ERROR!]
(T FN])
(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) (* lmm "21-Apr-85 15:14")
(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)
(NIL (\COPYARRAYBLOCK X))
(\COPYDATATYPE X])
(\COPYDATATYPE
[LAMBDA (X) (* lmm "21-Apr-85 15:29")
(LET* ((NTYP (NTYPX X))
(DTD (\GETDTD NTYP))
(PTRS (fetch DTDPTRS of DTD))
(NEW (CREATECELL NTYP)))
(PROG1 NEW (if PTRS
then (UNINTERRUPTABLY
(\BLT NEW X (fetch DTDSIZE of DTD))
(for P in PTRS do (\ADDREF (\GETBASEPTR NEW P))))
[for P in PTRS do (\RPLPTR NEW P (COPYALL (\GETBASEPTR NEW P]
else (\BLT NEW X (fetch DTDSIZE of DTD])
(\COPYARRAYBLOCK
[LAMBDA (OLD) (* lmm "21-Apr-85 15:21")
(LET [(HEADER (\ADDBASE OLD (IMINUS \ArrayBlockHeaderWords]
(COND
[(AND (IEQ \ArrayBlockPassword (fetch PASSWORD of HEADER))
(fetch (ARRAYBLOCK INUSE) of HEADER))
(LET* ((LEN (fetch (ARRAYBLOCK ARLEN) of HEADER))
(TYP (fetch (ARRAYBLOCK GCTYPE) of HEADER))
(NEW (\ALLOCBLOCK LEN TYP)))
(PROG1 NEW (SELECTC TYP
[PTRBLOCK.GCT (FRPTQ LEN (\RPLPTR NEW 0 (COPYALL (\GETBASEPTR OLD 0)))
(SETQ NEW (\ADDBASE NEW WORDSPERCELL)
(SETQ OLD (\ADDBASE OLD WORDSPERCELL]
(CODEBLOCK.GCT (* should increment references from code)
(\BLT NEW OLD (UNFOLD LEN WORDSPERCELL)))
(\BLT NEW OLD (UNFOLD LEN WORDSPERCELL]
(T OLD])
(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 HPRINTREADFNS READBITMAP)
(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 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (4007 5161 (MAKEHVPRETTYCOMS 4017 . 4399) (READVARS 4401 . 4838) (HPRINT0 4840 . 5159))
(6126 31941 (HPRINT 6136 . 7556) (HPRINT1 7558 . 15280) (HPRINTEND 15282 . 15912) (RPTPRINT 15914 .
16119) (RPTEND 16121 . 16253) (RPTPUT 16255 . 16632) (HPRINTSP 16634 . 16698) (HPERR 16700 . 16797) (
HVFWDCDREAD 16799 . 17144) (HVBAKREAD 17146 . 27116) (HVREADCHECKGETFN 27118 . 29337) (HVREADEND 29339
. 29598) (HVRPTREAD 29600 . 30008) (HVFWDREAD 30010 . 30675) (HREAD 30677 . 31001) (HPINITRDTBL 31003
. 31716) (HVREADERR 31718 . 31826) (HPRINSP 31828 . 31939)) (31942 37685 (COPYALL 31952 . 33672) (
\COPYDATATYPE 33674 . 34297) (\COPYARRAYBLOCK 34299 . 35236) (HCOPYALL 35238 . 35530) (HCOPYALL1 35532
. 37683)) (37686 40536 (EQUALALL 37696 . 39602) (EQUALHASH 39604 . 40534)))))
STOP