(FILECREATED "15-Aug-87 16:01:45" {QV}<NOTECARDS>1.3KNEXT>RHTPATCH287.;5 14217
changes to: (MACROS HPRINTSTRING)
(VARS RHTPATCH287COMS)
(RESOURCES HPRINTHARRAY)
(FNS HPRINT HPRINT1 HCOPYALL HCOPYALL1 HPRINTEND)
previous date: "14-Aug-87 12:12:42" {QV}<NOTECARDS>1.3KNEXT>RHTPATCH287.;2)
(* Copyright (c) 1987 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT RHTPATCH287COMS)
(RPAQQ RHTPATCH287COMS ((* * This fixes a bug in HPRINT whereby two HPRINTs starting nearly
simultaneously could clobber one another because they were sharing the
HPRINTHASHARRAY globalvar. Now HPRINTHASHARRAY is a RESOURCE.)
(* * New stuff for KOTOSYSTEMPATCHES)
(RESOURCES HPRINTHARRAY)
(MACROS HPRINTSTRING)
(FNS HPRINT HPRINT1 HCOPYALL HCOPYALL1 HPRINTEND)))
(* * This fixes a bug in HPRINT whereby two HPRINTs starting nearly simultaneously could
clobber one another because they were sharing the HPRINTHASHARRAY globalvar. Now
HPRINTHASHARRAY is a RESOURCE.)
(* * New stuff for KOTOSYSTEMPATCHES)
(DECLARE: EVAL@COMPILE
(PUTDEF (QUOTE HPRINTHARRAY)
(QUOTE RESOURCES)
(QUOTE (NEW (HASHARRAY 100))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS HPRINTSTRING MACRO (X (LIST (QUOTE PRIN1)
(KWOTE (CONCAT (CHARACTER HPBAKCHAR)
(CAR X))))))
)
(DEFINEQ
(HPRINT
(LAMBDA (EXPR FILE UNCIRCULAR DATATYPESEEN) (* rht: "15-Aug-87 15:03")
(* * rht 8/14/87: Enclosed calls to HPRINT1 inside a WITH-RESOURCE except for the uncircular case.)
(RESETLST (PROG (BACKREFS (CELLCOUNT 0)
SIZE
(U UNCIRCULAR))
(RESETSAVE (RADIX 10))
(HPINITRDTBL)
(RESETSAVE (OUTPUT FILE))
(RESETSAVE (SETREADTABLE HPRINTRDTBL))
(COND
(UNCIRCULAR (HPRINT1 EXPR NIL NIL T))
((RANDACCESSP (OUTPUT))
(WITH-RESOURCE HPRINTHARRAY (HPRINT1 EXPR)
(HPRINTEND)
(CLRHASH HPRINTHARRAY)))
(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)))
(WITH-RESOURCE HPRINTHARRAY (HPRINT1 EXPR)
(HPRINTEND)
(CLRHASH HPRINTHARRAY))
(SETQ SIZE (GETFILEPTR (OUTPUT)))
(COPYBYTES (INPUT (INFILE (CLOSEF (OUTPUT))))
FILE 0 SIZE)))
(TERPRI)))))
(HPRINT1
(LAMBDA (X CDRFLG NOMACROSFLG NOSPFLG) (* rht: "15-Aug-87 15:04")
(* 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 HPRINTHARRAY)))
(* 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)))
HPRINTHARRAY)
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))))
HPRINTHARRAY)
(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 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))))
(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))))))))))))
(HCOPYALL
(LAMBDA (X) (* rht: "15-Aug-87 15:47")
(* * rht 8/14/87: Enclosed call to HCOPYALL1 inside a WITH-RESOURCE)
(WITH-RESOURCE HPRINTHARRAY (HCOPYALL1 X)
(CLRHASH HPRINTHARRAY))))
(HCOPYALL1
(LAMBDA (X) (* rht: "15-Aug-87 15:48")
(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 HPRINTHARRAY)
(SELECTQ TYPE
(LISTP (FRPLNODE (PUTHASH X (CONS)
HPRINTHARRAY)
(HCOPYALL1 (CAR X))
(HCOPYALL1 (CDR X))))
(STRINGP (PUTHASH X (CONCAT X)
HPRINTHARRAY))
(FLOATP (PUTHASH X (FPLUS X)
HPRINTHARRAY))
(FIXP (PUTHASH X (IPLUS X)
HPRINTHARRAY))
(ARRAYP (PROG ((SIZE (ARRAYSIZE X))
(TYP (ARRAYTYP X))
(ORIG (ARRAYORIG X)))
(* Regular array)
(PUTHASH X
(SETQ NEW
(ARRAY SIZE TYP NIL
ORIG))
HPRINTHARRAY)
(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))))
HPRINTHARRAY)
(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)
HPRINTHARRAY))
(TERMTABLEP (COPYTERMTABLE X))
(COND
((SETQ SEEN (GETDESCRIPTORS TYPE))
(PUTHASH X (SETQ NEW (NCREATE TYPE))
HPRINTHARRAY)
(for FIELD in SEEN
do (REPLACEFIELD FIELD NEW
(HCOPYALL1
(FETCHFIELD FIELD X))
))
NEW)
(T X))))))))))))
(HPRINTEND
(LAMBDA NIL (* rht: "15-Aug-87 15:48")
(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))))
)
(PUTPROPS RHTPATCH287 COPYRIGHT ("Xerox Corporation" 1987))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1342 14135 (HPRINT 1352 . 2771) (HPRINT1 2773 . 10587) (HCOPYALL 10589 . 10865) (
HCOPYALL1 10867 . 13340) (HPRINTEND 13342 . 14133)))))
STOP