(FILECREATED " 6-Nov-87 10:28:27" {QV}<NOTECARDS>1.3KNEXT>PMIPATCH070.;2
 8461   

      changes to:  (FNS HPRINT1)
		   (VARS PMIPATCH070COMS)

      previous date: " 6-Nov-87 10:22:08" {QV}<NOTECARDS>1.3KNEXT>PMIPATCH070.;1)


(* Copyright (c) 1987 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT PMIPATCH070COMS)

(RPAQQ PMIPATCH070COMS
 ((FNS HPRINT1)))
(DEFINEQ

(HPRINT1

  (LAMBDA (X CDRFLG NOMACROSFLG NOSPFLG)                     (* pmi: " 6-Nov-87 10:27")

                                                             (* 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)
		      (
SETQ
 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)     (* Not sure this will help, but this function was 

							     breaking on HPRINTSP undefined function.

							     I replaced them with HPRINSP in this while.)

					    (while
 VALS
					       do
 (HPRINSP (
GETHASH
 (
CAR
 VALS)
									X))
						    (HPRINSP (
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))))))))))))
)
(PUTPROPS PMIPATCH070 COPYRIGHT ("Xerox Corporation" 1987))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (379 8379 (HPRINT1 389 . 8377)))))
STOP