github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-02-27 09:28:48 +00:00
Code Issues Projects Releases Wiki Activity

Use COPYCHARS instead of COPYBYTES when HPRINT is copying from NODIRCORE buffer (#506)

Browse Source 
* Use COPYCHARS instead of COPYBYTES when HPRINT is copying from NODIRCORE buffer

* Change HPRINT of non-random-access files to use FORMAT of ultimate destination
This commit is contained in:
Larry Masinter
2021-10-21 09:50:15 -07:00
committed by GitHub
parent 13cfb9b835
commit c7a219fd22
2 changed files with 144 additions and 117 deletions
Download Patch File Download Diff File Expand all files Collapse all files

261
sources/HPRINT
View File

@@ -1,13 +1,20 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "26-Apr-2021 14:45:00" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>HPRINT.;2 57689
previous date%: " 9-Oct-94 13:07:03"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>HPRINT.;1)
(FILECREATED "17-Oct-2021 13:54:11" {DSK}<home>larry>medley>sources>HPRINT.;2 59850
changes to%: (VARS HPRINTCOMS)
(FNS MAKEHVPRETTYCOMS READVARS HPRINT0 READVAR-FROM-STRING READVARS-FROM-STRING
HPRINT-TO-STRING HPRINT-TO-STRINGS HPRINT HPRINT1 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)
previous date%: "28-Sep-2021 10:44:11" {DSK}<home>larry>medley>sources>HPRINT.;1)
(* ; "
Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation.
Copyright (c) 1982-1988, 1990-1991, 1993-1994 by Venue & Xerox Corporation.
")
(PRETTYCOMPRINT HPRINTCOMS)
@@ -66,16 +73,16 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(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)))))
[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)))
@@ -83,7 +90,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
NO-CIRCLE-FLAG])
(READVARS
[NLAMBDA VARS (* lmm%: " 4-JAN-77 23:32:43")
[NLAMBDA VARS (* lmm%: " 4-JAN-77 23:32:43")
(HPINITRDTBL)
(PROG (BACKREFS (BACKREFCNT 0)
DATATYPESEEN)
@@ -97,7 +104,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(HVREADERR])
(HPRINT0
[NLAMBDA VARS (* lmm%: 30-JAN-76 7 36)
[NLAMBDA VARS (* lmm%: 30-JAN-76 7 36)
(HPRINT (for X in (COND
((EQ (CAR VARS)
0)
@@ -131,10 +138,10 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 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)
(* ;; "")
(* ;; "")
(HPINITRDTBL)
(PROG (BACKREFS (BACKREFCNT 0)
@@ -143,17 +150,17 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 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)
@@ -181,14 +188,32 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(DEFINEQ
(HPRINT
[LAMBDA (EXPR FILE UNCIRCULAR DATATYPESEEN) (* ; "Edited 10-Feb-87 15:52 by Pavel")
[LAMBDA (EXPR FILE UNCIRCULAR DATATYPESEEN)
(DECLARE (SPECVARS DATATYPESEEN UNCIRCULAR)) (* ;
 "Edited 17-Oct-2021 13:06 by larry")
(* ;
 "Edited 17-Oct-2021 13:02 by larry")
(* ;
 "Edited 17-Oct-2021 12:52 by larry")
(* ;
 "Edited 17-Oct-2021 12:46 by larry")
(* ;
 "Edited 17-Oct-2021 12:42 by larry")
(* ;
 "Edited 17-Oct-2021 12:42 by larry")
(* ;
 "Edited 17-Oct-2021 12:41 by larry")
(* ;
 "Edited 17-Oct-2021 12:39 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"))
(UNCIRCULAR (* ; "Won't need the hash array"))
([OR (HARRAYP HPRINTHASHARRAY)
(HARRAYP (CAR (LISTP HPRINTHASHARRAY]
(CLRHASH HPRINTHASHARRAY))
@@ -201,28 +226,29 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
((RANDACCESSP (OUTPUT))
(HPRINT1 EXPR)
(HPRINTEND))
(T (* ;
 "If the byte pointer cannot be reset, want to output to temp file and copy it back")
(LET* ((STREAM (OPENSTREAM "{NoDirCore}" 'OUTPUT))
(*STANDARD-OUTPUT* STREAM))
(CL:UNWIND-PROTECT
(PROGN (HPRINT1 EXPR)
(HPRINTEND)
(CL:CLOSE STREAM)
(OPENSTREAM STREAM 'INPUT)
(COPYBYTES STREAM FILE))
(CL:CLOSE STREAM))]
(T (* ;
 "If the byte pointer cannot be reset, want to output to temp file and copy it back")
(LET [(NDC (OPENSTREAM "{NODIRCORE}" 'BOTH 'NEW
`((FORMAT ,(STREAMPROP *STANDARD-OUTPUT* 'FORMAT]
(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")
[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")
(* ;; "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")
((SMALLP LITATOM NEW-ATOM) (* ;
 "Atom, small number, are just directly printed")
[RETURN (COND
[CDRFLG (COND
(X (PRIN1 " . ")
@@ -234,7 +260,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
[(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)")
(* ;; "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))
@@ -242,17 +268,17 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
[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)")
(* ;; "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")
((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")
(T (* ;
 "Seen at least once before --- Add this place to the list")
(FRPLACD LASTSEEN (CONS HERE (CDR LASTSEEN]
(T
(AND CDRFLG (NLISTP X)
@@ -267,8 +293,8 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
HPRINTHASHARRAY)
(SETN CELLCOUNT (ADD1 CELLCOUNT)))
((NOT NOSPFLG)
(SPACES 1))) (* ;
 "Now, finally get around to printing the thing --- leave space for macro char")
(SPACES 1))) (* ;
 "Now, finally get around to printing the thing --- leave space for macro char")
(COND
[(LISTP X)
(COND
@@ -291,8 +317,8 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 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)
@@ -322,7 +348,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
[PRIN2 (LIST SIZ (HARRAYPROP X 'OVERFLOW]
(SPACES 1)
(SELECTQ (SYSTEMTYPE)
((TENEX TOPS20) (* ; "bug in Interlisp-10 MAPHASH")
((TENEX TOPS20) (* ; "bug in Interlisp-10 MAPHASH")
[COND
((ILESSP (GCTRP)
SIZ)
@@ -339,8 +365,8 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(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")
(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)
@@ -384,7 +410,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(SETQ TYPE (DELETECONTROL PR NIL X]
(HPRINSP PR)
(HPRINSP TYPE]
(PRIN2) (* ; "end with a NIL")
(PRIN2) (* ; "end with a NIL")
(HPRINTENDSTR))
(VAG (HPRINTSTRING %#)
(PRIN2 (LOC X))
@@ -415,7 +441,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(T (HPERR "cannot print this item" X])
(HPRINTEND
[LAMBDA NIL (* lmm%: "29-NOV-76 16:11:02")
[LAMBDA NIL (* lmm%: "29-NOV-76 16:11:02")
(PROG [(HERE (GETFILEPTR (OUTPUT]
[SORT BACKREFS (FUNCTION (LAMBDA (X Y)
(ILESSP (ABS (CAR X))
@@ -445,12 +471,12 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(SETQ RPTCNT 1])
(RPTEND
[LAMBDA NIL (* lmm%: "29-NOV-76 16:11:40")
[LAMBDA NIL (* lmm%: "29-NOV-76 16:11:40")
(RPTPUT RPTCNT RPTLAST)
(HPRINTENDSTR])
(RPTPUT
[LAMBDA (CNT ITEM FLAG) (* lmm "11-SEP-78 03:22")
[LAMBDA (CNT ITEM FLAG) (* lmm "11-SEP-78 03:22")
(COND
[(AND (ILESSP CNT 4)
(OR FLAG (LITATOM ITEM)
@@ -481,8 +507,8 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 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))
@@ -493,20 +519,20 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
TCONCPTR])
(HVBAKREAD
[LAMBDA (FILE RDTBL BKRF) (* rrb "18-Mar-86 15:40")
[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")
(} (* ;
 "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")
(H (* ; "Hash array")
[SETQ READVAL (COND
((EQ (SKIPSEPRS FILE RDTBL)
'%()
@@ -519,7 +545,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(PUTHASH (READ FILE RDTBL)
HV READVAL)))
(HVREADEND FILE RDTBL))
((A Y) (* ; "array")
((A Y) (* ; "array")
[SETQ READVAL (ARRAY (SETQ HV1 (READ FILE RDTBL))
(SETQ HV2 (READ FILE RDTBL))
NIL
@@ -537,11 +563,11 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(for I from (ADD1 HV2) to HV1
do (SETD READVAL I (HVRPTREAD FILE RDTBL]
(HVREADEND FILE RDTBL))
(($ ~) (* ; "DATATYPE")
(($ ~) (* ; "DATATYPE")
(SETQ HV1 (RATOM FILE RDTBL))
[COND
((EQ HV '~) (* ;
 "This should be a previously known datatype not specified in file")
((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))
@@ -556,21 +582,21 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(AND BKRF (FRPLACA BKRF READVAL))
(for X in HV2 do (REPLACEFIELD X READVAL (HVRPTREAD FILE RDTBL)))
(HVREADEND FILE RDTBL))
(R (* ; "repeat")
(R (* ; "repeat")
(AND BKRF (HVREADERR))
(RETURN HPRPTSTRING))
(%# (* ; "Kludge for (VAG smallnumber)")
(%# (* ; "Kludge for (VAG smallnumber)")
(RETURN (PROG1 (VAG (RATOM FILE RDTBL))
(HVREADEND FILE RDTBL))))
(! (* ; "! --- value cell")
(! (* ; "! --- value cell")
(RETURN (AT2VC (RATOM FILE RDTBL))))
(D (* ; "READTABLEP")
(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")
(T (* ; "TERMTABLEP")
(SETQ READVAL (COPYTERMTABLE 'ORIG))
(AND BKRF (FRPLACA BKRF READVAL))
(while (SETQ HV (RATOM FILE RDTBL))
@@ -592,10 +618,10 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(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)
@@ -603,20 +629,20 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(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.")
(* ;; "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.")
(* ;; "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 ))")
(* ; "read the closing (QUOTE ))")
(RATOM FILE RDTBL]
(HVREADEND FILE RDTBL)))
(AND BKRF (FRPLACA BKRF READVAL))
@@ -627,26 +653,26 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 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")
((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.")
(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.")
((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?")
@@ -656,13 +682,13 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(T FN])
(HVREADEND
[LAMBDA (FILE RDTBL) (* lmm "21-APR-82 11:25")
[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")
[LAMBDA (FILE RDTBL) (* lmm " 2-APR-82 23:26")
(PROG NIL
LOOP
(COND
@@ -678,7 +704,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(T (RETURN RPTVAL])
(HVFWDREAD
[LAMBDA (FILE RDTBL) (* lmm%: "29-NOV-76 15:56:19")
[LAMBDA (FILE RDTBL) (* lmm%: "29-NOV-76 15:56:19")
(PROG (CH VAL)
(SETQ BACKREFCNT (ADD1 BACKREFCNT))
(SETQ BACKREFS (CONS NIL BACKREFS))
@@ -700,7 +726,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(T (RETURN (CAR (FRPLACA BACKREFS (READ FILE RDTBL])
(HREAD
[LAMBDA (FILE) (* lmm%: 19 MAY 75 315)
[LAMBDA (FILE) (* lmm%: 19 MAY 75 315)
(PROG [BACKREFS (BACKREFCNT 0)
DATATYPESEEN
(FILE (INPUT (INPUT FILE]
@@ -709,7 +735,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(RETURN (READ FILE HPRINTRDTBL])
(HPINITRDTBL
[LAMBDA NIL (* lmm " 5-JAN-78 23:23")
[LAMBDA NIL (* lmm " 5-JAN-78 23:23")
(COND
([NOT (READTABLEP (GETATOMVAL 'HPRINTRDTBL]
(PROG [(RDTBL (COPYREADTABLE 'ORIG]
@@ -735,14 +761,14 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(OR M2 '(in HREAD])
(HPRINSP
[LAMBDA (X) (* lmm%: "29-NOV-76 17:41:47")
[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")
[LAMBDA (X) (* ; "Edited 9-Oct-94 13:06 by jds")
(COND
((LISTP X)
(PROG [TAIL (VAL (LIST (COPYALL (CAR X]
@@ -767,7 +793,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(STRINGP (CONCAT X))
(FLOATP (FPLUS X))
(FIXP (IPLUS X))
(HARRAYP (* ; "Hash array")
(HARRAYP (* ; "Hash array")
(PROG [(NH (HASHARRAY (HARRAYSIZE X)
(HARRAYPROP X 'OVERFLOW]
(DECLARE (SPECVARS NH))
@@ -788,7 +814,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(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")
(* ;; "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
@@ -810,7 +836,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(\COPYDATATYPE X])
(\COPYDATATYPE
[LAMBDA (X) (* lmm "21-Apr-85 15:29")
[LAMBDA (X) (* lmm "21-Apr-85 15:29")
(LET* ((NTYP (NTYPX X))
(DTD (\GETDTD NTYP))
(PTRS (fetch DTDPTRS of DTD))
@@ -824,7 +850,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
else (\BLT NEW X (fetch DTDSIZE of DTD))))])
(HCOPYALL
[LAMBDA (X) (* rmk%: " 3-Jan-84 13:16")
[LAMBDA (X) (* rmk%: " 3-Jan-84 13:16")
[COND
([OR (HARRAYP HPRINTHASHARRAY)
(HARRAYP (CAR (LISTP HPRINTHASHARRAY]
@@ -833,7 +859,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(HCOPYALL1 X])
(HCOPYALL1
[LAMBDA (X) (* bvm%: " 7-Feb-85 21:25")
[LAMBDA (X) (* bvm%: " 7-Feb-85 21:25")
(COND
((OR (LITATOM X)
(SMALLP X))
@@ -859,7 +885,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(ARRAYP (PROG ((SIZE (ARRAYSIZE X))
(TYP (ARRAYTYP X))
(ORIG (ARRAYORIG X)))
(* ; "Regular array")
(* ; "Regular array")
(PUTHASH X (SETQ NEW (ARRAY SIZE TYP NIL ORIG))
HPRINTHASHARRAY)
(FRPTQ SIZE (SETA NEW ORIG
@@ -895,13 +921,14 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(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)
(RETURN (AND (EQ TY (TYPENAME X))
(SELECTQ TY
((LITATOM NEW-ATOM SMALLP) (* ; "not eq, so not equal")
((LITATOM NEW-ATOM SMALLP) (* ; "not eq, so not equal")
NIL)
(FIXP (IEQP X Y))
(FLOATP (EQP X Y))
@@ -920,7 +947,7 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
always (EQUALALL (ELT X I)
(ELT Y I])
((ONED-ARRAY TWOD-ARRAY GENERAL-ARRAY)
(* ; "RMK: Added CL arrays")
(* ; "RMK: Added CL arrays")
[AND (EQUAL (CL:ARRAY-DIMENSIONS X)
(CL:ARRAY-DIMENSIONS Y))
(EQUAL (CL:ARRAY-ELEMENT-TYPE X)
@@ -973,9 +1000,9 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(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?")
(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))
@@ -1109,16 +1136,16 @@ Copyright (c) 1982-1988, 1990-1991, 1993-1994, 2021 by Venue & Xerox Corporation
(ADDTOVAR LAMA )
)
(PUTPROPS HPRINT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991
1993 1994 2021))
1993 1994))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3661 6199 (MAKEHVPRETTYCOMS 3671 . 4958) (READVARS 4960 . 5526) (HPRINT0 5528 . 6197))
(6201 6534 (READVARS-FROM-STRINGS 6201 . 6534)) (6536 6923 (READVARS-FROM-STREAM 6536 . 6923)) (6924
8852 (READVAR-FROM-STRING 6934 . 7340) (READVARS-FROM-STRING 7342 . 7578) (HPRINT-TO-STRING 7580 .
7786) (HPRINT-TO-STRINGS 7788 . 8850)) (9663 37895 (HPRINT 9673 . 11303) (HPRINT1 11305 . 22807) (
HPRINTEND 22809 . 23845) (RPTPRINT 23847 . 24085) (RPTEND 24087 . 24246) (RPTPUT 24248 . 24746) (
HPRINTSP 24748 . 24812) (HPERR 24814 . 24911) (HVFWDCDREAD 24913 . 25292) (HVBAKREAD 25294 . 33339) (
HVREADCHECKGETFN 33341 . 34740) (HVREADEND 34742 . 35094) (HVRPTREAD 35096 . 35622) (HVFWDREAD 35624
. 36478) (HREAD 36480 . 36802) (HPINITRDTBL 36804 . 37638) (HVREADERR 37640 . 37753) (HPRINSP 37755
. 37893)) (37896 46778 (COPYALL 37906 . 41809) (\COPYDATATYPE 41811 . 42500) (HCOPYALL 42502 . 42812)
(HCOPYALL1 42814 . 46776)) (46779 54061 (EQUALALL 46789 . 52382) (EQUALHASH 52384 . 54059)))))
(FILEMAP (NIL (4174 6712 (MAKEHVPRETTYCOMS 4184 . 5471) (READVARS 5473 . 6039) (HPRINT0 6041 . 6710))
(6714 7047 (READVARS-FROM-STRINGS 6714 . 7047)) (7049 7436 (READVARS-FROM-STREAM 7049 . 7436)) (7437
9365 (READVAR-FROM-STRING 7447 . 7853) (READVARS-FROM-STRING 7855 . 8091) (HPRINT-TO-STRING 8093 .
8299) (HPRINT-TO-STRINGS 8301 . 9363)) (10176 39996 (HPRINT 10186 . 13404) (HPRINT1 13406 . 24908) (
HPRINTEND 24910 . 25946) (RPTPRINT 25948 . 26186) (RPTEND 26188 . 26347) (RPTPUT 26349 . 26847) (
HPRINTSP 26849 . 26913) (HPERR 26915 . 27012) (HVFWDCDREAD 27014 . 27393) (HVBAKREAD 27395 . 35440) (
HVREADCHECKGETFN 35442 . 36841) (HVREADEND 36843 . 37195) (HVRPTREAD 37197 . 37723) (HVFWDREAD 37725
. 38579) (HREAD 38581 . 38903) (HPINITRDTBL 38905 . 39739) (HVREADERR 39741 . 39854) (HPRINSP 39856
. 39994)) (39997 48879 (COPYALL 40007 . 43910) (\COPYDATATYPE 43912 . 44601) (HCOPYALL 44603 . 44913)
(HCOPYALL1 44915 . 48877)) (48880 56227 (EQUALALL 48890 . 54548) (EQUALHASH 54550 . 56225)))))
STOP

BIN
sources/HPRINT.LCOM
View File

Binary file not shown.