(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