diff --git a/sources/HPRINT b/sources/HPRINT index 80eef5900..56f3d9804 100644 --- a/sources/HPRINT +++ b/sources/HPRINT @@ -1,16 +1,19 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 3-Aug-2022 21:31:57" {DSK}larry>medley>sources>HPRINT.;3 58021 +(FILECREATED "20-Apr-2023 16:20:48" {DSK}larry>il>medley>sources>HPRINT.;5 56784 - :CHANGES-TO (VARS HPRINTCOMS) - (FNS HPRINT) + :EDIT-BY "lmm" - :PREVIOUS-DATE "17-Oct-2021 13:54:11" {DSK}larry>medley>sources>HPRINT.;1) + :CHANGES-TO (FNS HPRINT1 MAKEHVPRETTYCOMS READVARS HPRINT0 READVAR-FROM-STRING + READVARS-FROM-STRING HPRINT-TO-STRING HPRINT-TO-STRINGS HPRINT HPRINTEND + RPTPRINT RPTEND RPTPUT HPRINTSP HPERR HVFWDCDREAD HVBAKREAD HVREADCHECKGETFN + HVREADEND HVRPTREAD HVFWDREAD HREAD HPINITRDTBL HVREADERR HPRINSP COPYALL + \COPYDATATYPE HCOPYALL HCOPYALL1 EQUALALL EQUALHASH) + (FILEPKGCOMS HORRIBLEVARS UGLYVARS) + (VARS HPRINTCOMS) + :PREVIOUS-DATE " 3-Aug-2022 21:31:57" {DSK}larry>medley>sources>HPRINT.;3) -(* ; " -Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation. -") (PRETTYCOMPRINT HPRINTCOMS) @@ -68,21 +71,21 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (DEFINEQ (MAKEHVPRETTYCOMS - [NLAMBDA (VARS NO-CIRCLE-FLAG) (* ; "Edited 9-Sep-87 16:52 by amd") + [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))))) + (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))) + then (ERROR X "not a symbol in HORRIBLEVARS" T))) `((P (READVARS-FROM-STRINGS ',VARS ,@(HPRINT-TO-STRINGS (CL:MAPCAR 'GETATOMVAL VARS) - NO-CIRCLE-FLAG]) + NO-CIRCLE-FLAG]) (READVARS [NLAMBDA VARS (* lmm%: " 4-JAN-77 23:32:43") @@ -93,7 +96,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation '%() (HVREADERR)) (for VAR in VARS when (LITATOM VAR) do (SAVESET VAR (READ NIL HPRINTRDTBL) - T)) + T)) (OR (EQ (RATOM NIL HPRINTRDTBL) '%)) (HVREADERR]) @@ -101,13 +104,12 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (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)) + ((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]) @@ -133,7 +135,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (DEFINEQ (READVAR-FROM-STRING - [LAMBDA (SYMBOL HPRINT-STRING) (* ; "Edited 10-Feb-87 16:39 by Pavel") + [LAMBDA (SYMBOL HPRINT-STRING) (* ; "Edited 10-Feb-87 16:39 by Pavel") (CL:WITH-INPUT-FROM-STRING (STREAM HPRINT-STRING) (* ;; "") @@ -145,17 +147,17 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation T]) (READVARS-FROM-STRING - [LAMBDA (SYMBOLS HPRINT-STRING) (* ; "Edited 9-Sep-87 18:22 by amd") + [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") + [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") + [LAMBDA (VALUE NO-CIRCLE-FLAG) (* ; "Edited 5-Feb-88 14:42 by amd") (XCL:WITH-COLLECTION (XCL:COLLECT (CL:WITH-OUTPUT-TO-STRING (S) @@ -221,14 +223,15 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (TERPRI)))]) (HPRINT1 - [LAMBDA (X CDRFLG NOMACROSFLG NOSPFLG) (* ; "Edited 26-Apr-91 13:39 by jds") + [LAMBDA (X CDRFLG NOMACROSFLG NOSPFLG) (* ; "Edited 20-Apr-2023 07:19 by lmm") + (* ; "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") + "Atom, small number, are just directly printed") [RETURN (COND [CDRFLG (COND (X (PRIN1 " . ") @@ -250,7 +253,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (* ;; "HPFILLCHAR is 0; there is still a problem in the system of dumping and reading back in (CHARACTER 0)") - (SETQ CN (IQUOTIENT CN 10] + (SETQ CN (IQUOTIENT CN 10] (COND ((NLISTP LASTSEEN) (* ; "Seen only once before") (PUTHASH X (CAR (SETQ BACKREFS (CONS (LIST LASTSEEN HERE) @@ -258,7 +261,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation HPRINTHASHARRAY) NIL) (T (* ; - "Seen at least once before --- Add this place to the list") + "Seen at least once before --- Add this place to the list") (FRPLACD LASTSEEN (CONS HERE (CDR LASTSEEN] (T (AND CDRFLG (NLISTP X) @@ -271,10 +274,10 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (IMINUS (GETFILEPTR (OUTPUT] (T (GETFILEPTR (OUTPUT] HPRINTHASHARRAY) - (SETN CELLCOUNT (ADD1 CELLCOUNT))) + (SETQ CELLCOUNT (ADD1 CELLCOUNT))) ((NOT NOSPFLG) (SPACES 1))) (* ; - "Now, finally get around to printing the thing --- leave space for macro char") + "Now, finally get around to printing the thing --- leave space for macro char") (COND [(LISTP X) (COND @@ -297,8 +300,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (HPRINTENDSTR] (T (SELECTQ TYPE - ((STRINGP FLOATP FIXP) (* ; - "string, floating point or number") + ((STRINGP FLOATP FIXP) (* ; "string, floating point or number") (PRIN2 X)) (ARRAYP (PROG ((SIZE (ARRAYSIZE X)) (RPTCNT 0) @@ -327,35 +329,25 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (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))) + 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") + "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)) + 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) @@ -374,22 +366,21 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (HPRINSP 'NOECHO] (for PROP in '(CTRLV RETYPE LINEDELETE CHARDELETE EOL) unless (EQUAL (GETSYNTAX PROP X) - (GETSYNTAX PROP 'ORIG)) + (GETSYNTAX PROP 'ORIG)) do (HPRINSP PROP) - (HPRINSP (GETSYNTAX PROP X))) + (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) + ([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] + ([NOT (EQUAL (DELETECONTROL PR NIL 'ORIG) + (SETQ TYPE (DELETECONTROL PR NIL X] + (HPRINSP PR) + (HPRINSP TYPE] (PRIN2) (* ; "end with a NIL") (HPRINTENDSTR)) (VAG (HPRINTSTRING %#) @@ -415,8 +406,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation DATATYPESEEN] (PROG ((RPTCNT 0) (RPTLAST (CONS))) - (for Y in (GETDESCRIPTORS TYPE) - do (RPTPRINT (FETCHFIELD Y X))) + (for Y in (GETDESCRIPTORS TYPE) do (RPTPRINT (FETCHFIELD Y X))) (RETURN (RPTEND] (T (HPERR "cannot print this item" X]) @@ -426,17 +416,16 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation [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))) + (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]) @@ -487,8 +476,8 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (HVFWDCDREAD [LAMBDA (FILE RDTBL TCONCPTR) - (* Do setq so that if the READ adds things to the BACKREF list, it will still - be correct) + (* 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)) @@ -506,7 +495,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (SKIPSEPRS FILE RDTBL) (SELECTQ (SETQ HV (READC FILE)) (} (* ; - "Empty printout from false start for HPRINTMACRO. Next char should be { and be default") + "Empty printout from false start for HPRINTMACRO. Next char should be { and be default") (SKIPSEPRS FILE RDTBL) (COND ((EQ '{ (READC FILE)) @@ -540,14 +529,13 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (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] + (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") + "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)) @@ -574,38 +562,36 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (SETQ READVAL (COPYREADTABLE 'ORIG)) (AND BKRF (FRPLACA BKRF READVAL)) (for I in (READ FILE RDTBL) do (SETSYNTAX I (HVRPTREAD FILE RDTBL) - READVAL)) + 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))) + (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") + ((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))) + (while (SMALLP (SETQ HV (READC FILE))) do (SETQ HV2 (IPLUS (ITIMES HV2 10) + HV))) (RETURN (OR [CAR (FNTH BACKREFS (ADD1 (IDIFFERENCE BACKREFCNT HV2] (HVREADERR)))) (%( @@ -618,8 +604,8 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (* ;; "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) - '%))) + (EQ (PEEKC FILE) + '%))) collect (EVAL (READ FILE RDTBL)) finally (* ; "read the closing (QUOTE ))") @@ -633,26 +619,25 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (RETURN READVAL]) (HVREADCHECKGETFN - [LAMBDA (FN) (* ; "Edited 27-Jan-87 19:41 by rrb") + [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.") + (* ;; "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.") + "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") + "headed for an undefined function error anyway") (\LISPERROR FN 46 T) (* ; - "user may have loaded a package during the break.") + "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?") @@ -664,8 +649,8 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (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]) + (CONSTANT HPFINALCHAR)) do (OR (SYNTAXP CHAR 'SEPR RDTBL) + (HVREADERR]) (HVRPTREAD [LAMBDA (FILE RDTBL) (* lmm " 2-APR-82 23:26") @@ -748,7 +733,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (DEFINEQ (COPYALL - [LAMBDA (X) (* ; "Edited 9-Oct-94 13:06 by jds") + [LAMBDA (X) (* ; "Edited 9-Oct-94 13:06 by jds") (COND ((LISTP X) (PROG [TAIL (VAL (LIST (COPYALL (CAR X] @@ -789,8 +774,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (ORIG (ARRAYORIG X)) NEW) (RETURN (PROG1 (SETQ NEW (ARRAY SIZE TYPE NIL ORIG)) - (FRPTQ SIZE (SETA NEW ORIG (COPYALL - (ELT X ORIG))) + (FRPTQ SIZE (SETA NEW ORIG (COPYALL (ELT X ORIG))) (add ORIG 1)))]) (BITMAP (BITMAPCOPY X)) (CURSOR @@ -803,13 +787,12 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (FETCH (CURSOR CUIMAGE) OF X)) IM) - (T (BITMAPCOPY (FETCH - (CURSOR CUMASK) + (T (BITMAPCOPY (FETCH (CURSOR CUMASK + ) OF X] (FETCH (CURSOR CUHOTSPOTX) OF X) (FETCH (CURSOR CUHOTSPOTY) OF X) - (COPYALL (FETCH (CURSOR CUDATA) - OF X] + (COPYALL (FETCH (CURSOR CUDATA) OF X] NEW)) (CCODEP X) (NIL (\COPYARRAYBLOCK X)) @@ -824,9 +807,9 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (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] + (\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 @@ -880,8 +863,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (MAPHASH X (FUNCTION (LAMBDA (X Y) (PUTHASH (HCOPYALL1 Y) - (HCOPYALL1 - X) + (HCOPYALL1 X) NEW] NEW) (READTABLEP (COPYREADTABLE X)) @@ -893,16 +875,15 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (PUTHASH X (SETQ NEW (NCREATE TYPE)) HPRINTHASHARRAY) [for FIELD in SEEN - do (REPLACEFIELD FIELD NEW (HCOPYALL1 - (FETCHFIELD FIELD X] + do (REPLACEFIELD FIELD NEW (HCOPYALL1 (FETCHFIELD FIELD + X] NEW) (T X]) ) (DEFINEQ (EQUALALL - [LAMBDA (X Y) (* ; - "Edited 26-Apr-2021 14:34 by rmk:") + [LAMBDA (X Y) (* ; "Edited 26-Apr-2021 14:34 by rmk:") (OR (EQ X Y) (PROG ((TY (TYPENAME Y)) TEM) @@ -925,7 +906,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (ARRAYSIZE Y)) (for I from (ARRAYORIG X) as J to TEM always (EQUALALL (ELT X I) - (ELT Y I]) + (ELT Y I]) ((ONED-ARRAY TWOD-ARRAY GENERAL-ARRAY) (* ; "RMK: Added CL arrays") [AND (EQUAL (CL:ARRAY-DIMENSIONS X) @@ -939,14 +920,12 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (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)) + (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]) + (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)))) + (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) @@ -965,7 +944,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation Y] (for I from 0 to 31 always (EQ (ECHOCONTROL I NIL X) - (ECHOCONTROL I NIL Y))) + (ECHOCONTROL I NIL Y))) (EVERY ORIGDELETECONTROL (FUNCTION (LAMBDA (Z) (EQUAL (DELETECONTROL (CAR Z) @@ -974,15 +953,14 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation NIL Y]) (OR (EQP X Y) (AND (SETQ TY (GETDESCRIPTORS TY)) - (for FIELD in TY always (EQUALALL - (FETCHFIELD FIELD X) - (FETCHFIELD FIELD Y]) + (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") + (DECLARE (SPECVARS AR1 AR2)) (* rmk%: "26-Dec-83 13:33") (* ; - "What does it mean for two hash arrays to be EQUAL?") + "What does it mean for two hash arrays to be EQUAL?") [PROG (UNMATCHED) (OR (EQUAL (HARRAYPROP AR1 'OVERFLOW) (HARRAYPROP AR2 'OVERFLOW)) @@ -1001,9 +979,8 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (RETFROM (FUNCTION EQUALHASH] ([NOT (SOME UNMATCHED (FUNCTION (LAMBDA (Y) (AND (EQUALALL KEY Y) - (EQUALALL - VAL - (GETHASH Y AR1] + (EQUALALL VAL + (GETHASH Y AR1] (RETFROM (FUNCTION EQUALHASH] T]) ) @@ -1115,17 +1092,15 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2022 by Venue & Xerox Corporation (ADDTOVAR LAMA ) ) -(PUTPROPS HPRINT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991 -1993 1994 2022)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3694 6232 (MAKEHVPRETTYCOMS 3704 . 4991) (READVARS 4993 . 5559) (HPRINT0 5561 . 6230)) -(6234 6567 (READVARS-FROM-STRINGS 6234 . 6567)) (6569 6956 (READVARS-FROM-STREAM 6569 . 6956)) (6957 -8885 (READVAR-FROM-STRING 6967 . 7373) (READVARS-FROM-STRING 7375 . 7611) (HPRINT-TO-STRING 7613 . -7819) (HPRINT-TO-STRINGS 7821 . 8883)) (9696 38289 (HPRINT 9706 . 11697) (HPRINT1 11699 . 23201) ( -HPRINTEND 23203 . 24239) (RPTPRINT 24241 . 24479) (RPTEND 24481 . 24640) (RPTPUT 24642 . 25140) ( -HPRINTSP 25142 . 25206) (HPERR 25208 . 25305) (HVFWDCDREAD 25307 . 25686) (HVBAKREAD 25688 . 33733) ( -HVREADCHECKGETFN 33735 . 35134) (HVREADEND 35136 . 35488) (HVRPTREAD 35490 . 36016) (HVFWDREAD 36018 - . 36872) (HREAD 36874 . 37196) (HPINITRDTBL 37198 . 38032) (HVREADERR 38034 . 38147) (HPRINSP 38149 - . 38287)) (38290 47172 (COPYALL 38300 . 42203) (\COPYDATATYPE 42205 . 42894) (HCOPYALL 42896 . 43206) - (HCOPYALL1 43208 . 47170)) (47173 54520 (EQUALALL 47183 . 52841) (EQUALHASH 52843 . 54518))))) + (FILEMAP (NIL (4107 6487 (MAKEHVPRETTYCOMS 4117 . 5408) (READVARS 5410 . 5960) (HPRINT0 5962 . 6485)) +(6489 6822 (READVARS-FROM-STRINGS 6489 . 6822)) (6824 7211 (READVARS-FROM-STREAM 6824 . 7211)) (7212 +9156 (READVAR-FROM-STRING 7222 . 7632) (READVARS-FROM-STRING 7634 . 7874) (HPRINT-TO-STRING 7876 . +8086) (HPRINT-TO-STRINGS 8088 . 9154)) (9967 37711 (HPRINT 9977 . 11968) (HPRINT1 11970 . 22695) ( +HPRINTEND 22697 . 23910) (RPTPRINT 23912 . 24150) (RPTEND 24152 . 24311) (RPTPUT 24313 . 24811) ( +HPRINTSP 24813 . 24877) (HPERR 24879 . 24976) (HVFWDCDREAD 24978 . 25359) (HVBAKREAD 25361 . 33172) ( +HVREADCHECKGETFN 33174 . 34576) (HVREADEND 34578 . 34910) (HVRPTREAD 34912 . 35438) (HVFWDREAD 35440 + . 36294) (HREAD 36296 . 36618) (HPINITRDTBL 36620 . 37454) (HVREADERR 37456 . 37569) (HPRINSP 37571 + . 37709)) (37712 46385 (COPYALL 37722 . 41496) (\COPYDATATYPE 41498 . 42178) (HCOPYALL 42180 . 42490) + (HCOPYALL1 42492 . 46383)) (46386 53402 (EQUALALL 46396 . 51789) (EQUALHASH 51791 . 53400))))) STOP diff --git a/sources/HPRINT.LCOM b/sources/HPRINT.LCOM index 24b13d5b5..34934bfa0 100644 Binary files a/sources/HPRINT.LCOM and b/sources/HPRINT.LCOM differ diff --git a/sources/WINDOWOBJ b/sources/WINDOWOBJ index 7aeeb2aa5..cf98f933e 100644 --- a/sources/WINDOWOBJ +++ b/sources/WINDOWOBJ @@ -1,17 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "18-Mar-2022 21:45:55" {DSK}kaplan>Local>medley3.5>my-medley>sources>WINDOWOBJ.;8 28006 +(FILECREATED "20-Apr-2023 08:30:40" {DSK}larry>il>medley>sources>WINDOWOBJ.;3 28072 - :CHANGES-TO (FNS READIMAGEOBJ) + :EDIT-BY "lmm" - :PREVIOUS-DATE "17-Mar-2022 22:48:26" -{DSK}kaplan>Local>medley3.5>my-medley>sources>WINDOWOBJ.;7) + :PREVIOUS-DATE "20-Apr-2023 07:54:01" {DSK}larry>il>medley>sources>WINDOWOBJ.;2) -(* ; " -Copyright (c) 1986-1987, 1990-1991, 1993 by Venue & Xerox Corporation. -") - (PRETTYCOMPRINT WINDOWOBJCOMS) (RPAQQ WINDOWOBJCOMS @@ -19,7 +14,8 @@ Copyright (c) 1986-1987, 1990-1991, 1993 by Venue & Xerox Corporation.  "Image object support - here so that DEDIT can use it without needing TEDIT to be loaded.") (RECORDS IMAGEOBJ IMAGEFNS IMAGEBOX) (FNS COPYINSERT IMAGEBOX IMAGEFNSCREATE IMAGEFNSP IMAGEOBJCREATE IMAGEOBJP IMAGEOBJPROP - \IMAGEUSERPROP HPRINT.IMAGEOBJ COPYIMAGEOBJ READIMAGEOBJ WRITEIMAGEOBJ) + \IMAGEUSERPROP HPRINT.IMAGEOBJ COPYIMAGEOBJ READIMAGEOBJ CHECKIMAGEOBJGETFN + WRITEIMAGEOBJ) (ADDVARS (HPRINTMACROS (IMAGEOBJ . WRITEIMAGEOBJ))) (GLOBALVARS (IMAGEOBJTYPES NIL) (IMAGEOBJGETFNS NIL))) @@ -315,6 +311,8 @@ Copyright (c) 1986-1987, 1990-1991, 1993 by Venue & Xerox Corporation. (READIMAGEOBJ [LAMBDA (STREAM GETFN NOERROR DATANBYTES) + (* ;; "Edited 20-Apr-2023 07:46 by lmm") + (* ;; "Edited 18-Mar-2022 21:45 by rmk: Added WHEREIS as a last resort.") (* rrb "18-Mar-86 11:35") (DECLARE (SPECVARS UNDERREADIMAGEOBJ)) @@ -325,23 +323,14 @@ Copyright (c) 1986-1987, 1990-1991, 1993 by Venue & Xerox Corporation. (* ;; "rmk: I'm not sure that it makes sense for GETFN to be NIL, as 86 code allowed. Presumably an image object without a GETFN should never have been written.") - (LET (SUPPORTFILE (UNDERREADIMAGEOBJ T)) + (LET ((UNDERREADIMAGEOBJ T)) (DECLARE (SPECVARS UNDERREADIMAGEOBJ)) (* ;; "Typically,the file containing the GETFN has already been loaded. If not, it could be the case that the GETFN and its file were pushed on the list for future reference (now), but the file wasn't loaded then. We need to download it. Or if not there or not there with a file, and we can find the file containing the GETFN in the WHEREIS database, load that file.") (* ;; "If we find the file with the GETFN but that file doesn't also contain the IMAGEFNS variable, we're screwed. That's why we apply the GETFN under an NLSETQ") - (CL:WHEN (AND GETFN (NOT (GETD GETFN)) - [SETQ SUPPORTFILE (OR (LISTGET (CDR (ASSOC GETFN IMAGEOBJGETFNS)) - 'FILE) - (CAR (WHEREIS GETFN 'FNS T)) - (CAR (WHEREIS GETFN 'FUNCTIONS T] - (MOUSECONFIRM (CONCAT "Trying to read an IMAGEOBJ with GETFN " GETFN - ". Shall I load the support file, " SUPPORTFILE "?") - NIL NIL NIL)) - (DOFILESLOAD (LIST '(SYSLOAD) - SUPPORTFILE))) + (CHECKIMAGEOBJGETFN GETFN) (COND [(AND GETFN (GETD GETFN) (CAR (NLSETQ (APPLY* GETFN STREAM] @@ -360,6 +349,21 @@ Copyright (c) 1986-1987, 1990-1991, 1993 by Venue & Xerox Corporation. DATANBYTES))) OBJ]) +(CHECKIMAGEOBJGETFN + [LAMBDA (GETFN) (* ; "Edited 20-Apr-2023 07:49 by lmm") + [LET (SUPPORTFILE) + (CL:WHEN (AND GETFN (NOT (GETD GETFN)) + [SETQ SUPPORTFILE (OR (LISTGET (CDR (ASSOC GETFN IMAGEOBJGETFNS)) + 'FILE) + (CAR (WHEREIS GETFN 'FNS T)) + (CAR (WHEREIS GETFN 'FUNCTIONS T] + (MOUSECONFIRM (CONCAT "Trying to read an IMAGEOBJ with GETFN " GETFN + ". Shall I load the support file, " SUPPORTFILE "?") + NIL NIL NIL)) + (DOFILESLOAD (LIST '(SYSLOAD) + SUPPORTFILE)))] + GETFN]) + (WRITEIMAGEOBJ [LAMBDA (IMAGEOBJ STREAM) (* jds "19-Feb-85 09:36") @@ -526,13 +530,12 @@ Either delete this image object or load its support files." IMAGEOBJ) (ADDTOVAR LAMA IMAGEOBJPROP) ) -(PUTPROPS WINDOWOBJ COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1993)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (4897 21221 (COPYINSERT 4907 . 6434) (IMAGEBOX 6436 . 6616) (IMAGEFNSCREATE 6618 . 7813) - (IMAGEFNSP 7815 . 8056) (IMAGEOBJCREATE 8058 . 8603) (IMAGEOBJP 8605 . 8846) (IMAGEOBJPROP 8848 . -14740) (\IMAGEUSERPROP 14742 . 15336) (HPRINT.IMAGEOBJ 15338 . 15927) (COPYIMAGEOBJ 15929 . 16672) ( -READIMAGEOBJ 16674 . 19867) (WRITEIMAGEOBJ 19869 . 21219)) (21435 27642 ( -ENCAPSULATEDOBJ.BUTTONEVENTINFN 21445 . 22581) (ENCAPSULATEDOBJ.PUTFN 22583 . 23698) ( -ENCAPSULATEDOBJ.DISPLAYFN 23700 . 25313) (ENCAPSULATEDOBJ.IMAGEBOXFN 25315 . 26203) ( -ENCAPSULATEDIMAGEFNS 26205 . 27640))))) + (FILEMAP (NIL (4801 21373 (COPYINSERT 4811 . 6338) (IMAGEBOX 6340 . 6520) (IMAGEFNSCREATE 6522 . 7717) + (IMAGEFNSP 7719 . 7960) (IMAGEOBJCREATE 7962 . 8507) (IMAGEOBJP 8509 . 8750) (IMAGEOBJPROP 8752 . +14644) (\IMAGEUSERPROP 14646 . 15240) (HPRINT.IMAGEOBJ 15242 . 15831) (COPYIMAGEOBJ 15833 . 16576) ( +READIMAGEOBJ 16578 . 19176) (CHECKIMAGEOBJGETFN 19178 . 20019) (WRITEIMAGEOBJ 20021 . 21371)) (21587 +27794 (ENCAPSULATEDOBJ.BUTTONEVENTINFN 21597 . 22733) (ENCAPSULATEDOBJ.PUTFN 22735 . 23850) ( +ENCAPSULATEDOBJ.DISPLAYFN 23852 . 25465) (ENCAPSULATEDOBJ.IMAGEBOXFN 25467 . 26355) ( +ENCAPSULATEDIMAGEFNS 26357 . 27792))))) STOP diff --git a/sources/WINDOWOBJ.LCOM b/sources/WINDOWOBJ.LCOM index 173384160..776e301dd 100644 Binary files a/sources/WINDOWOBJ.LCOM and b/sources/WINDOWOBJ.LCOM differ