;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 126.69
;;; Reason:
;;;  Cosmetics -- doc-string for SI:PRINTING-RANDOM-OBJECT, with a better example
;;;  (a :PRINT-FUNCTION for a DEFSTRUCT) and corrected arg-list.
;;; Written 7-Sep-88 21:31:08 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Johannes Brahms from band 3
;;; with Experimental System 126.68, Experimental ZWEI 126.8, Experimental ZMail 74.1, Experimental Local-File 76.0, Experimental File-Server 25.0, Experimental Unix-Interface 14.0, Experimental Tape 25.1, Experimental Lambda-Diag 18.0, microcode 1762, SDU Boot Tape 3.14, SDU ROM 103, Lambda/Falcon Development System.

; From modified file DJ: L.IO; RDDEFS.LISP#64 at 7-Sep-88 21:33:36
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; RDDEFS  "

(DEFMACRO PRINTING-RANDOM-OBJECT ((OBJECT STREAM . OPTIONS) &BODY BODY)
  "A macro for aiding in the printing of /"random/" /(unreadable) objects.
This macro generates a form which:
   1.  Uses the print-table to find the things in which to enclose the
       printed representation of OBJECT.
   2.  By default, includes the virtual address in the printed representation.
   3.  If SI:PRINT-READABLY is non-NIL, signals an error, since OBJECT cannot
       be read back in.
/
Valid OPTIONS include:
	:NO-POINTER to suppress printing the virtual address.
	:TYPE to PRIN1 the TYPE-OF of the object first.
/
Example:
/
/(defun print-ship (ship stream ignore)
  (flet ((maybe-tab ()
		    (format stream /"~:[ ~;~&~5T~]/" *print-pretty*)))
    (si:printing-random-object (ship stream :type :no-pointer)
      (format stream /":X-POSITION ~S/" (ship-x-position ship)) (maybe-tab)
      (format stream /":Y-POSITION ~S/" (ship-y-position ship)) (maybe-tab)
      (format stream /":X-VELOCITY ~S/" (ship-x-velocity ship)) (maybe-tab)
      (format stream /":Y-VELOCITY ~S/" (ship-y-velocity ship))
      (format stream /")/"))))
/
/(defstruct (ship :named (:print-function print-ship))
  (x-position 0.0)
  (y-position 0.0)
  (x-velocity 0.0)
  (y-velocity 0.0))
/
/(let ((*print-pretty* t))
  (print (make-ship)))
/
#<USER::SHIP 
     :X-POSITION 0.0
     :Y-POSITION 0.0
     :X-VELOCITY 0.0
     :Y-VELOCITY 0.0)>
"
  (declare (arglist ((object stream &rest options) &body body)))
  (LET ((%POINTER T)
	(TYPE NIL))
    (IF (EQ STREAM T) (SETQ STREAM '*STANDARD-OUTPUT*))	;inconsistent with decode-print-arg...
    (DO ((L OPTIONS (CDR L)))
	((NULL L))
      (CASE (CAR L)
	(:NO-POINTER (SETQ %POINTER NIL))
	((:TYPE :TYPEP) (SETQ TYPE T))
	;; hysterical lossage.  Perhaps nobody uses this.  They shouldn't!
	(:FASTP (SETQ L (CDR L)))
	(T (FERROR "~S is an unknown keyword in ~S"
		   (CAR L) 'PRINTING-RANDOM-OBJECT))))
    `(progn
       (print-random-object-prefix ,object ,stream ,type ,(not (not (and type body))))
       ,@body
       (print-random-object-suffix ,object ,stream ,(not %pointer))
       ,object)))

))