(FILECREATED "30-Nov-87 16:28:15" {QV}<NOTECARDS>1.3KNEXT>KOTOSYSTEMPATCHES.;6 27731
changes to: (VARS KOTOSYSTEMPATCHESCOMS)
previous date: "31-Aug-87 15:36:21" {QV}<NOTECARDS>1.3KNEXT>KOTOSYSTEMPATCHES.;5)
(* Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT KOTOSYSTEMPATCHESCOMS)
(RPAQQ KOTOSYSTEMPATCHESCOMS [(* * to compile SHAPEW must have EXPORTS.ALL loaded)
(DECLARE: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY (FILES EXPORTS.ALL
(LOADFROM)
NSPRINT))
(FNS SHAPEW \NSPRINT.INTERNAL COPY.TEXT.TO.IMAGE)
(RESOURCES HPRINTHARRAY)
(MACROS HPRINTSTRING)
(GLOBALVARS HPFILLSTRING)
[DECLARE: EVAL@COMPILE DONTCOPY
(VARS HPFILLCHAR HPBAKCHAR (HPFILLSTRING
(PACKC (LIST HPBAKCHAR HPFILLCHAR]
(FNS HPRINT HPRINT1 HCOPYALL HCOPYALL1 HPRINTEND HPRINTSP)
(* * fgh&rht 8/6/86: Insure that correct imageobj HPRINTMACRO is at
front of the HPRINTMACROS list.)
(FNS WRITE.IMAGEOBJ)
(DECLARE: DONTEVAL@LOAD (ADDVARS (HPRINTMACROS (IMAGEOBJ .
WRITE.IMAGEOBJ])
(* * to compile SHAPEW must have EXPORTS.ALL loaded)
(DECLARE: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY
(FILESLOAD EXPORTS.ALL (LOADFROM)
NSPRINT)
)
(DEFINEQ
(SHAPEW
(LAMBDA (WINDOW NEWREGION) (* fgh: " 6-Jun-86 19:31")
(* entry that shapes a window checking the userfns for DON'T and interacting to get a region if necessary.
This also checks for a user function to do the actual reshaping. look for a function on windowprop INITCORNERSFN,
which will take the window and return the initcorners for the window, to be passed to getregion.)
(SETQ WINDOW (\INSUREWINDOW WINDOW))
(PROG (USERFN X)
(COND
((\USERFNISDON'T (fetch (WINDOW RESHAPEFN) of WINDOW))
(* don't allow the window to be reshaped.)
(PROMPTPRINT "This window cannot be reshaped.")
(RETURN NIL)))
(SETQ X (MINIMUMWINDOWSIZE WINDOW))
(SETQ X (COND
(NEWREGION (COND
((OR (LESSP (fetch (REGION WIDTH) of NEWREGION)
(CAR X))
(LESSP (fetch (REGION HEIGHT) of NEWREGION)
(CDR X))) (* given a region that is too small)
(CREATEREGION (fetch (REGION LEFT) of NEWREGION)
(fetch (REGION BOTTOM) of NEWREGION)
(MAX (CAR X)
(fetch (REGION WIDTH) of NEWREGION))
(MAX (CDR X)
(fetch (REGION HEIGHT) of NEWREGION))))
(T NEWREGION)))
((WINDOWPROP WINDOW (QUOTE INITCORNERSFN))
(GETREGION (CAR X)
(CDR X)
(WINDOWREGION WINDOW (QUOTE SHAPEW))
(fetch NEWREGIONFN of WINDOW)
WINDOW
(APPLY* (WINDOWPROP WINDOW (QUOTE INITCORNERSFN))
WINDOW)))
(T (GETREGION (CAR X)
(CDR X)
(WINDOWREGION WINDOW (QUOTE SHAPEW))
(fetch NEWREGIONFN of WINDOW)
WINDOW))))
(RETURN (COND
((SETQ USERFN (WINDOWPROP WINDOW (QUOTE DOSHAPEFN)))
(APPLY* USERFN WINDOW X))
(T (SHAPEW1 WINDOW X)))))))
(\NSPRINT.INTERNAL
[LAMBDA (PRINTER OPTIONS TRANSFERFN) (* Randy.Gobbel "11-Dec-86 12:37")
(* * Calls the PRINT program for PRINTER, interpreting OPTIONS as a plist of print options.
TRANSFERFN is a function applied to the transfer stream to actually send the Interpress master)
(PROG ((MEDIUM (OR (LISTGET OPTIONS (QUOTE MEDIUM))
NSPRINT.DEFAULT.MEDIUM))
(STAPLE? (LISTGET OPTIONS (QUOTE STAPLE?)))
(TWO.SIDED? (EQ 2 (OR (LISTGET OPTIONS (QUOTE #SIDES))
EMPRESS#SIDES)))
(SENDER.NAME (OR (LISTGET OPTIONS (QUOTE SENDER.NAME))
(USERNAME NIL NIL T)))
(DOCNAME (OR (LISTGET OPTIONS (QUOTE DOCUMENT.NAME))
"Document"))
PROPERTIES ATTRIBUTES COURIERSTREAM VALUE PRINTOPTIONS STATUS)
[SETQ ATTRIBUTES (BQUOTE ((PRINT.OBJECT.NAME , DOCNAME)
(PRINT.OBJECT.CREATE.DATE , (OR (LISTGET OPTIONS
(QUOTE
DOCUMENT.CREATION.DATE))
(IDATE)))
(SENDER.NAME , SENDER.NAME]
[SETQ PRINTOPTIONS (BQUOTE ((COPY.COUNT , (FIX (OR (LISTGET OPTIONS
(QUOTE #COPIES))
1]
(* This "option" seems to be required)
[COND
((SETQ VALUE (LISTGET OPTIONS (QUOTE RECIPIENT.NAME)))
(push PRINTOPTIONS (LIST (QUOTE RECIPIENT.NAME)
(OR (STRINGP VALUE)
(MKSTRING VALUE]
[COND
((SETQ VALUE (LISTGET OPTIONS (QUOTE PRIORITY)))
(push PRINTOPTIONS (LIST (QUOTE PRIORITY.HINT)
(SELECTQ VALUE
((HOLD LOW NORMAL HIGH)
VALUE)
(\ILLEGAL.ARG VALUE]
[COND
((SETQ VALUE (LISTGET OPTIONS (QUOTE MESSAGE)))
(push PRINTOPTIONS (LIST (QUOTE MESSAGE)
(OR (STRINGP VALUE)
(MKSTRING VALUE]
[COND
((SETQ VALUE (LISTGET OPTIONS (QUOTE PAGES.TO.PRINT)))
(* A page range to print, (first# last#))
(COND
((AND (LISTP VALUE)
(LISTP (CDR VALUE))
(NULL (CDDR VALUE))
(SMALLPOSP (CAR VALUE))
(SMALLPOSP (CADR VALUE)))
(push PRINTOPTIONS (LIST (QUOTE PAGES.TO.PRINT)
VALUE)))
(T (\ILLEGAL.ARG VALUE]
RETRY
(COND
((NOT (SETQ COURIERSTREAM (\NSPRINT.COURIER.OPEN PRINTER)))
(printout PROMPTWINDOW .TAB0 0 "No response from printer " (fetch NSPRINTERNAME
of PRINTER))
(DISMISS 5000)
(GO RETRY)))
(RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE)
COURIERSTREAM)) (* Check the status of the printer.)
(bind (LASTSTATUS ← 0)
do (SETQ STATUS (COURIER.CALL COURIERSTREAM (QUOTE PRINTING)
(QUOTE GET.PRINTER.STATUS)
(QUOTE RETURNERRORS)))
[COND
((EQ (CAR STATUS)
(QUOTE ERROR))
(COND
((NOT (EQUAL STATUS LASTSTATUS))
(printout PROMPTWINDOW T "[From " (fetch NSPRINTERNAME of PRINTER)
" Error: "
(SUBSTRING (CDR STATUS)
2 -2)
"; will retry]"))) (* Wait longer for this problem)
(DISMISS 30000))
((NEQ (SETQ STATUS (CADR (ASSOC (QUOTE SPOOLER)
STATUS)))
LASTSTATUS)
(SELECTQ STATUS
(Available (RETURN))
(Busy (printout PROMPTWINDOW T "[From " (fetch NSPRINTERNAME
of PRINTER)
" Status: Spooler busy; will retry]"))
(ERROR "Printer spooler" STATUS]
(SETQ LASTSTATUS STATUS)
(DISMISS 5000))
[COND
((OR MEDIUM STAPLE? TWO.SIDED?) (* Check that the printer supports these options.)
(SETQ PROPERTIES (COURIER.CALL COURIERSTREAM (QUOTE PRINTING)
(QUOTE GET.PRINTER.PROPERTIES)
(QUOTE RETURNERRORS)))
(COND
((EQ (CAR PROPERTIES)
(QUOTE ERROR))
(SETQ STATUS PROPERTIES)
(GO HANDLE.ERROR)))
[COND
(MEDIUM (COND
((SETQ VALUE (\NSPRINT.MEDIUM.CHECK MEDIUM
(CADR (ASSOC (QUOTE MEDIA)
PROPERTIES))
PRINTER))
(push PRINTOPTIONS (LIST (QUOTE MEDIUM.HINT)
VALUE))
(SETQ MEDIUM]
[COND
(STAPLE? (COND
((CADR (ASSOC (QUOTE STAPLE)
PROPERTIES))
(push PRINTOPTIONS (LIST (QUOTE STAPLE)
T))
(SETQ STAPLE?))
(T (printout PROMPTWINDOW .TAB0 0
"[Printer does not support stapled copies]"]
(COND
(TWO.SIDED? (COND
((CADR (ASSOC (QUOTE TWO.SIDED)
PROPERTIES))
(push PRINTOPTIONS (QUOTE (TWO.SIDED T)))
(SETQ TWO.SIDED?))
(T (printout PROMPTWINDOW .TAB0 0
"Printer does not support two-sided copies"]
(* * Finally, send the print document)
(SETQ STATUS (COURIER.CALL COURIERSTREAM (QUOTE PRINTING)
(QUOTE PRINT)
TRANSFERFN ATTRIBUTES PRINTOPTIONS (QUOTE RETURNERRORS)))
(COND
((NEQ (CAR STATUS)
(QUOTE ERROR))
(RETURN STATUS)))
HANDLE.ERROR
(ERROR (CONCAT "Unexpected error from " (fetch NSPRINTERNAME of PRINTER)
" attempting to print " DOCNAME "
RETURN to try again.")
(CDR STATUS))
(CLOSEF COURIERSTREAM)
(GO RETRY])
(COPY.TEXT.TO.IMAGE
[LAMBDA (INFILE IMAGESTREAM FONTS TABS) (* Randy.Gobbel "28-Jan-87 18:22")
(* Copy text to an image stream, obeying PSPOOL
control characters)
(LET* ((IMAGESTREAM (GETSTREAM IMAGESTREAM (QUOTE OUTPUT)))
C FC (FONTARRAY (FONTMAPARRAY FONTS))
(MAXFONT (ARRAYSIZE FONTARRAY))
(INSTRM (GETSTREAM INFILE (QUOTE INPUT)))
(INEOLC (GETFILEINFO INSTRM (QUOTE EOL)))
(RIGHTMAR (DSPRIGHTMARGIN NIL IMAGESTREAM)))
(replace (STREAM ENDOFSTREAMOP) of INSTRM with (FUNCTION ZERO))
(bind (SHIFTEDCHARSET ← (UNFOLD (ffetch CHARSET of INSTRM)
256))
do (BLOCK)
(COND
((AND (EQ 0 (SETQ C (\NSIN INSTRM SHIFTEDCHARSET SHIFTEDCHARSET)))
(EOFP INSTRM))
(RETURN))
((AND RIGHTMAR (IGREATERP (DSPXPOSITION NIL IMAGESTREAM)
RIGHTMAR))
(* Not to walk off the right edge of the paper)
(TERPRI IMAGESTREAM)))
(COND
([IGREATERP C (CONSTANT (APPLY (FUNCTION MAX)
(CHARCODE (↑F CR LF ↑L TAB NULL]
(\OUTCHAR IMAGESTREAM C))
(T (SELCHARQ C
[↑F (* Font shift)
(SELCHARQ (SETQ FC (\NSIN INSTRM SHIFTEDCHARSET SHIFTEDCHARSET)
)
[↑T (* tab to absolute pos.)
(COND
((EQ 0 (SETQ FC (\NSIN INSTRM SHIFTEDCHARSET
SHIFTEDCHARSET)))
(\OUTCHAR IMAGESTREAM (CHARCODE ↑F))
(\OUTCHAR IMAGESTREAM (CHARCODE ↑T))
(AND (\EOFP INSTRM)
(RETURN))
(\OUTCHAR IMAGESTREAM FC))
(T
(* TEXTDEFAULTTABS is a hack, since it depends on the units of the stream. Should really be a property of the
stream or imagetype, or defined in terms of standard scale)
(SETQ FC
(OR (CAR (NTH (OR TABS
TEXTDEFAULTTABS)
FC))
(ERROR
"Undefined absolute tab number"
FC)))
(DSPXPOSITION FC IMAGESTREAM]
(NULL (\OUTCHAR IMAGESTREAM (CHARCODE ↑F))
(AND (\EOFP INSTRM)
(RETURN))
(\OUTCHAR IMAGESTREAM FC)
(* EOS after ↑F)
)
(COND
((AND (IGEQ MAXFONT FC)
(NEQ FC 0))
(DSPFONT (ELT FONTARRAY FC)
IMAGESTREAM))
(T (\OUTCHAR IMAGESTREAM (CHARCODE ↑F))
(\OUTCHAR IMAGESTREAM C]
(CR (* Don't call generic \CHECKEOLC macro, because we are
trying to disciminate the raw CR and raw LF cases for
printing)
(* Note: Assumes, as does \CHECKEOLC and \FILEOUTCHARFN that the LF character will be generated immediately after
the CR, independent of the encoding, perhaps by a file-transfer protocol)
(SELECTQ INEOLC
(CR (TERPRI IMAGESTREAM))
[CRLF (COND
((EQ (CHARCODE LF)
(\PEEKBIN INSTRM T))
(BIN INSTRM)
(TERPRI IMAGESTREAM))
(T (DSPXPOSITION (DSPLEFTMARGIN NIL
IMAGESTREAM)
IMAGESTREAM)
(* Move to left margin)
]
(DSPXPOSITION (DSPLEFTMARGIN NIL IMAGESTREAM)
IMAGESTREAM)))
(TAB (OR (NLSETQ (RELMOVETO (TIMES (CHARWIDTH
(CHARCODE SPACE)
IMAGESTREAM)
8)
0 IMAGESTREAM))
(\OUTCHAR IMAGESTREAM C)))
[LF (COND
((EQ INEOLC (QUOTE LF))
(TERPRI IMAGESTREAM))
(T (DSPXPOSITION (PROG1 (DSPXPOSITION NIL IMAGESTREAM)
(TERPRI IMAGESTREAM))
IMAGESTREAM]
(NULL (AND (EOFP INSTRM)
(RETURN))
(\OUTCHAR IMAGESTREAM C))
(\OUTCHAR IMAGESTREAM C])
)
(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]
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS HPFILLSTRING)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(RPAQQ HPFILLCHAR 0)
(RPAQQ HPBAKCHAR 123)
(RPAQ HPFILLSTRING (PACKC (LIST HPBAKCHAR HPFILLCHAR)))
)
(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])
(HPRINTSP
[LAMBDA (X)
(HPRINT1 X)
(PRIN1 " "])
)
(* * fgh&rht 8/6/86: Insure that correct imageobj HPRINTMACRO is at front of the HPRINTMACROS
list.)
(DEFINEQ
(WRITE.IMAGEOBJ
(LAMBDA (IMAGEOBJ STREAM) (* rrb "19-Dec-84 14:50")
(* HPRINT function for writing out IMAGE OBJECTS)
(* write out the name of the function to read things
back in with.)
(PRINT (LIST (fetch (IMAGEFNS GETFN) of (fetch (IMAGEOBJ IMAGEOBJFNS) of IMAGEOBJ)))
STREAM HPRINTRDTBL)
(APPLY* (fetch (IMAGEFNS PUTFN) of (fetch (IMAGEOBJ IMAGEOBJFNS) of IMAGEOBJ))
IMAGEOBJ STREAM)
T))
)
(DECLARE: DONTEVAL@LOAD
(ADDTOVAR HPRINTMACROS (IMAGEOBJ . WRITE.IMAGEOBJ))
)
(PUTPROPS KOTOSYSTEMPATCHES COPYRIGHT ("Xerox Corporation" 1986 1987))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1267 13613 (SHAPEW 1277 . 3372) (\NSPRINT.INTERNAL 3374 . 9232) (COPY.TEXT.TO.IMAGE
9234 . 13611)) (14073 26784 (HPRINT 14083 . 15496) (HPRINT1 15498 . 23223) (HCOPYALL 23225 . 23499) (
HCOPYALL1 23501 . 25936) (HPRINTEND 25938 . 26712) (HPRINTSP 26714 . 26782)) (26893 27554 (
WRITE.IMAGEOBJ 26903 . 27552)))))
STOP