(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "31-Jul-2023 13:33:10" {WMEDLEY}HPRINT.;5 57926 :EDIT-BY rmk :CHANGES-TO (FNS EQUALALL) :PREVIOUS-DATE " 3-Aug-2022 21:31:57" {WMEDLEY}HPRINT.;2) (* ; " Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation. ") (PRETTYCOMPRINT HPRINTCOMS) (RPAQQ HPRINTCOMS [(FNS MAKEHVPRETTYCOMS READVARS HPRINT0) (FUNCTIONS READVARS-FROM-STRINGS READVARS-FROM-STREAM) (FNS READVAR-FROM-STRING READVARS-FROM-STRING HPRINT-TO-STRING HPRINT-TO-STRINGS) (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 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 READVAR-FROM-STRING READVARS-FROM-STREAM HPRINT-TO-STRING 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)) (INITVARS (HPRINTMACROS) (HPRINTHASHARRAY) (HPRINTRDTBL) (HPRPTSTRING "") (DONTCOPYDATATYPES)) (VARS ORIGDELETECONTROL ORIGTERMSYNTAX ORIGECHOCONTROL) (ADDVARS (HPRINTREADFNS READBITMAP)) [ADDVARS (GAINSPACEFORMS ((OR HPRINTHASHARRAY HPRINTRDTBL) "discard HPRINT initialization" (PROGN (CLRHASH HPRINTHASHARRAY) (SETQ HPRINTHASHARRAY (SETQ HPRINTRDTBL] (PROP FILETYPE HPRINT) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA HPRINT0 READVARS) (NLAML MAKEHVPRETTYCOMS) (LAMA]) (DEFINEQ (MAKEHVPRETTYCOMS [NLAMBDA (VARS NO-CIRCLE-FLAG) (* ; "Edited 9-Sep-87 16:52 by amd") (* "The old code" (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 NO-CIRCLE-FLAG  then (CONS 0 VARS) else VARS))))) (HPINITRDTBL) (for X in VARS do (if (NOT (LITATOM X)) then (ERROR X "not a symbol in HORRIBLEVARS" T))) `((P (READVARS-FROM-STRINGS ',VARS ,@(HPRINT-TO-STRINGS (CL:MAPCAR 'GETATOMVAL VARS) NO-CIRCLE-FLAG]) (READVARS [NLAMBDA VARS (* lmm%: " 4-JAN-77 23:32:43") (HPINITRDTBL) (PROG (BACKREFS (BACKREFCNT 0) DATATYPESEEN) (OR (EQ (RATOM NIL HPRINTRDTBL) '%() (HVREADERR)) (for VAR in VARS when (LITATOM VAR) do (SAVESET VAR (READ NIL HPRINTRDTBL) T)) (OR (EQ (RATOM NIL HPRINTRDTBL) '%)) (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]) ) (CL:DEFUN READVARS-FROM-STRINGS (SYMBOLS &REST STRINGS) (CL:ASSERT (NOT (NULL STRINGS)) (STRINGS) "~S must be given at least one string." 'READVARS-FROM-STRINGS) (CL:WITH-OPEN-STREAM (STREAM (MAKE-CONCATENATED-STRING-INPUT-STREAM STRINGS)) (READVARS-FROM-STREAM SYMBOLS STREAM))) (CL:DEFUN READVARS-FROM-STREAM (SYMBOLS STREAM) (HPINITRDTBL) (PROG (BACKREFS (BACKREFCNT 0) DATATYPESEEN) (DECLARE (CL:SPECIAL BACKREFS BACKREFCNT DATATYPESEEN RPTCNT RPTVAL)) (CL:MAPC #'(CL:LAMBDA (SYMBOL VALUE) (SAVESET SYMBOL VALUE T)) SYMBOLS (READ STREAM HPRINTRDTBL)))) (DEFINEQ (READVAR-FROM-STRING [LAMBDA (SYMBOL HPRINT-STRING) (* ; "Edited 10-Feb-87 16:39 by Pavel") (CL:WITH-INPUT-FROM-STRING (STREAM HPRINT-STRING) (* ;; "") (HPINITRDTBL) (PROG (BACKREFS (BACKREFCNT 0) DATATYPESEEN) (SAVESET SYMBOL (READ STREAM HPRINTRDTBL) T]) (READVARS-FROM-STRING [LAMBDA (SYMBOLS HPRINT-STRING) (* ; "Edited 9-Sep-87 18:22 by amd") (CL:WITH-INPUT-FROM-STRING (STREAM HPRINT-STRING) (READVARS-FROM-STREAM SYMBOLS STREAM]) (HPRINT-TO-STRING [LAMBDA (VALUE NO-CIRCLE-FLAG) (* ; "Edited 9-Sep-87 16:21 by amd") (CL:WITH-OUTPUT-TO-STRING (S) (HPRINT VALUE S NO-CIRCLE-FLAG]) (HPRINT-TO-STRINGS [LAMBDA (VALUE NO-CIRCLE-FLAG) (* ; "Edited 5-Feb-88 14:42 by amd") (XCL:WITH-COLLECTION (XCL:COLLECT (CL:WITH-OUTPUT-TO-STRING (S) (HANDLER-BIND [(END-OF-FILE #'(CL:LAMBDA (C) (CL:WHEN (AND (EQ (END-OF-FILE-STREAM C) S) (CONDITIONS:FIND-RESTART 'SI::RETRY-OUTCHAR)) (XCL:COLLECT (CL:GET-OUTPUT-STREAM-STRING S)) (CONDITIONS:INVOKE-RESTART 'SI::RETRY-OUTCHAR))] (HPRINT VALUE S NO-CIRCLE-FLAG]) ) (PUTDEF (QUOTE HORRIBLEVARS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (COMS * (MAKEHVPRETTYCOMS X))) CONTENTS (LAMBDA (COM NAME TYPE) (AND (EQ TYPE 'VARS) (INFILECOMTAIL COM]) (PUTDEF (QUOTE UGLYVARS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (COMS * (MAKEHVPRETTYCOMS X T))) CONTENTS (LAMBDA (COM NAME TYPE) (AND (EQ TYPE 'VARS) (INFILECOMTAIL COM]) (DEFINEQ (HPRINT [LAMBDA (EXPR FILE UNCIRCULAR DATATYPESEEN) (DECLARE (SPECVARS DATATYPESEEN UNCIRCULAR)) (* ; "Edited 3-Aug-2022 21:26 by lmm") (* ; "Edited 17-Oct-2021 13:06 by larry") (* ; "Edited 10-Feb-87 15:52 by Pavel") (RESETLST (PROG (BACKREFS (CELLCOUNT 0) SIZE (U UNCIRCULAR)) (DECLARE (SPECVARS BACKREFS CELLCOUNT U)) (RESETSAVE (RADIX 10)) [COND (UNCIRCULAR (* ; "Won't need the hash array")) ([OR (HARRAYP HPRINTHASHARRAY) (HARRAYP (CAR (LISTP HPRINTHASHARRAY] (CLRHASH HPRINTHASHARRAY)) (T (SETQ HPRINTHASHARRAY (HASHARRAY 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") (LET [(NDC (OPENSTREAM "{NODIRCORE}" 'BOTH 'NEW] (CL:UNWIND-PROTECT [LET ((OS *STANDARD-OUTPUT*) (*STANDARD-OUTPUT* NDC)) (HPRINT1 EXPR) (HPRINTEND) (COPYCHARS NDC OS 0 (PROG1 (GETFILEPTR NDC) (SETFILEPTR NDC 0] (CL:CLOSE NDC))] (TERPRI)))]) (HPRINT1 [LAMBDA (X CDRFLG NOMACROSFLG NOSPFLG) (* ; "Edited 26-Apr-91 13:39 by jds") (* ;; "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 NEW-ATOM) (* ;  "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 '"(") (HPRINT1 (CAR X) NIL NIL T) (HPRINT1 (CDR X) T) (PRIN1 '")"] [(AND (NOT NOMACROSFLG) (SETQ HERE (FASSOC TYPE HPRINTMACROS)) (PROG2 (PRIN1 (CONSTANT (CHARACTER HPBAKCHAR)) (OUTPUT)) (APPLY* (CDR HERE) X (OUTPUT)) (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 '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 'ORIG] collect I)) do (RPTPRINT (GETSYNTAX I X))) (RETURN (RPTEND)))) (TERMTABLEP (HPRINTSTRING T) [COND ((GETCONTROL X) (HPRINSP 'CONTROL] [COND ((NOT (GETECHOMODE X)) (HPRINSP 'ECHOMODE] (SELECTQ (GETRAISE X) (T (HPRINSP T)) (0 (HPRINSP 0)) NIL) [COND ((EQ 'NOECHO (GETDELETECONTROL 'ECHO X)) (HPRINSP 'NOECHO] (for PROP in '(CTRLV RETYPE LINEDELETE CHARDELETE EOL) unless (EQUAL (GETSYNTAX PROP X) (GETSYNTAX PROP '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 'ORIG] (HPRINSP (ECHOCHAR I NIL X)) (HPRINSP I] [for PR in '(DELETELINE 1STCHDEL NTHCHDEL POSTCHDEL EMPTYCHDEL) do (COND ([NOT (EQUAL (DELETECONTROL PR NIL '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 '% ] ((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 '{ (READC FILE)) (GO READLP)) (T (HVREADERR)))) (H (* ; "Hash array") [SETQ READVAL (COND ((EQ (SKIPSEPRS FILE RDTBL) '%() (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 '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 '~) (* ;  "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 '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 '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 '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) '%))) 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) (* ; "Edited 27-Jan-87 19:41 by rrb") (* ;;  "if in the context of reading an image object, make sure the get function is a known one.") (COND ((EQ FN '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 ((OR (MEMB FN HPRINTREADFNS) (ASSOC FN IMAGEOBJGETFNS)) (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 '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 'HPRINTRDTBL] (PROG [(RDTBL (COPYREADTABLE 'ORIG] (SETSYNTAX (CONSTANT HPFORWRDCHR) (LIST 'MACRO (FUNCTION HVFWDREAD)) RDTBL) (SETSYNTAX (CONSTANT HPFORWRDCDRCHR) (LIST 'INFIX (FUNCTION HVFWDCDREAD)) RDTBL) (SETSYNTAX (CONSTANT HPBAKCHAR) (LIST 'MACRO (FUNCTION HVBAKREAD)) RDTBL) (SETSYNTAX (CONSTANT HPFILLCHAR) 'SEPR RDTBL) (SETSYNTAX (CONSTANT HPFINALCHAR) 'SEPR RDTBL) (/SETATOMVAL 'HPRINTRDTBL RDTBL)) T]) (HVREADERR [LAMBDA (M1 M2) (ERROR (OR M1 "incorrect format on file") (OR M2 '(in HREAD]) (HPRINSP [LAMBDA (X) (* lmm%: "29-NOV-76 17:41:47") (PRIN2 X) (SPACES 1]) ) (DEFINEQ (COPYALL [LAMBDA (X) (* ; "Edited 9-Oct-94 13:06 by jds") (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) (CL:CHARACTERP 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 '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)) (CURSOR (* ;; "For cursors, must preserve EQ-ness of MASK & IMAGE, to avoid trouble with SOFTCURSOR code being missing.(COPY") (LET* [(IM (BITMAPCOPY (FETCH (CURSOR CUIMAGE) OF X))) (NEW (CURSORCREATE IM [COND ((EQ (FETCH (CURSOR CUMASK) OF X) (FETCH (CURSOR CUIMAGE) OF X)) IM) (T (BITMAPCOPY (FETCH (CURSOR CUMASK) OF X] (FETCH (CURSOR CUHOTSPOTX) OF X) (FETCH (CURSOR CUHOTSPOTY) OF X) (COPYALL (FETCH (CURSOR CUDATA) OF X] NEW)) (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))))]) (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 '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) (* ; "Edited 31-Jul-2023 13:31 by rmk") (* ; "Edited 26-Apr-2021 14:34 by rmk:") (OR (EQ X Y) (PROG ((TY (TYPENAME Y)) TEM) (RETURN (AND (EQ TY (TYPENAME X)) (SELECTQ TY ((LITATOM NEW-ATOM 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]) ((ONED-ARRAY TWOD-ARRAY GENERAL-ARRAY) (* ; "RMK: Added CL arrays") [AND (EQUAL (CL:ARRAY-DIMENSIONS X) (CL:ARRAY-DIMENSIONS Y)) (EQUAL (CL:ARRAY-ELEMENT-TYPE X) (CL:ARRAY-ELEMENT-TYPE Y)) (EQ (CL:ADJUSTABLE-ARRAY-P X) (CL:ADJUSTABLE-ARRAY-P Y)) (CL:IF (CL:ARRAY-HAS-FILL-POINTER-P X) (AND (CL:ARRAY-HAS-FILL-POINTER-P Y) (EQP (CL:FILL-POINTER X) (CL:FILL-POINTER Y))) (NOT (CL:ARRAY-HAS-FILL-POINTER-P Y))) (FOR I FROM 0 TO (SUB1 (CL:ARRAY-TOTAL-SIZE X)) ALWAYS (EQUALALL (XCL:ROW-MAJOR-AREF X I) (XCL:ROW-MAJOR-AREF 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]) ((BITMAP BIGBM) (BITMAPEQUAL X 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 'OVERFLOW) (HARRAYPROP AR2 '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 READVAR-FROM-STRING READVARS-FROM-STREAM HPRINT-TO-STRING 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 'PRIN1 (KWOTE (CONCAT (CHARACTER HPBAKCHAR) (CAR X]) (PUTPROPS HPRINTENDSTR MACRO [X (COND [(CAR X) '(PRIN3 (CONSTANT (CHARACTER HPFINALCHAR] (T '(PRIN1 (CONSTANT (CHARACTER HPFINALCHAR]) ) (RPAQ? HPRINTMACROS ) (RPAQ? HPRINTHASHARRAY ) (RPAQ? HPRINTRDTBL ) (RPAQ? HPRPTSTRING "") (RPAQ? DONTCOPYDATATYPES ) (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))) (ADDTOVAR HPRINTREADFNS READBITMAP) (ADDTOVAR GAINSPACEFORMS [(OR HPRINTHASHARRAY HPRINTRDTBL) "discard HPRINT initialization" (PROGN (CLRHASH HPRINTHASHARRAY) (SETQ HPRINTHASHARRAY (SETQ HPRINTRDTBL]) (PUTPROPS HPRINT FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA HPRINT0 READVARS) (ADDTOVAR NLAML MAKEHVPRETTYCOMS) (ADDTOVAR LAMA ) ) (PUTPROPS HPRINT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991 1993 1994 2022)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3652 6190 (MAKEHVPRETTYCOMS 3662 . 4949) (READVARS 4951 . 5517) (HPRINT0 5519 . 6188)) (6192 6525 (READVARS-FROM-STRINGS 6192 . 6525)) (6527 6914 (READVARS-FROM-STREAM 6527 . 6914)) (6915 8843 (READVAR-FROM-STRING 6925 . 7331) (READVARS-FROM-STRING 7333 . 7569) (HPRINT-TO-STRING 7571 . 7777) (HPRINT-TO-STRINGS 7779 . 8841)) (9654 38247 (HPRINT 9664 . 11655) (HPRINT1 11657 . 23159) ( HPRINTEND 23161 . 24197) (RPTPRINT 24199 . 24437) (RPTEND 24439 . 24598) (RPTPUT 24600 . 25098) ( HPRINTSP 25100 . 25164) (HPERR 25166 . 25263) (HVFWDCDREAD 25265 . 25644) (HVBAKREAD 25646 . 33691) ( HVREADCHECKGETFN 33693 . 35092) (HVREADEND 35094 . 35446) (HVRPTREAD 35448 . 35974) (HVFWDREAD 35976 . 36830) (HREAD 36832 . 37154) (HPINITRDTBL 37156 . 37990) (HVREADERR 37992 . 38105) (HPRINSP 38107 . 38245)) (38248 47130 (COPYALL 38258 . 42161) (\COPYDATATYPE 42163 . 42852) (HCOPYALL 42854 . 43164) (HCOPYALL1 43166 . 47128)) (47131 54425 (EQUALALL 47141 . 52746) (EQUALHASH 52748 . 54423))))) STOP