;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 130.7
;;; Reason:
;;;  Prevent array subscript error that occurs printing messed-up array.
;;;  It's possible to create an array for which some element(s) can not be
;;;  accessed.  (Hint: use ADJUST-ARRAY.) With *PRINT-ARRAY* and
;;;  *PRINT-CIRCLE* non-NIL, this caused a subscript error when the
;;;  circularity-detector tripped on an un-accessible element.  I propose
;;;  that the time to get such an error is <not> when printing the offending
;;;  array.
;;;  
;;;  The array code should be fixed to avoid the screw cases!
;;; Written 18-Nov-88 13:55:50 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Breaking Glass from band 3
;;; with Experimental System 130.5, Experimental ZWEI 128.5, Experimental ZMail 75.0, Experimental Local-File 77.0, Experimental File-Server 26.0, Experimental Unix-Interface 16.0, Experimental Tape 27.0, Experimental Lambda-Diag 19.0, Microcode 1762, SDU Boot Tape 3.14, SDU ROM 103, 11/14 Falcon System Loaded.



; From modified file DJ: L.IO; PRINT.LISP#223 at 18-Nov-88 13:55:54
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; PRINT  "


(defun print-record-occurrences (object)
  (flet ((seen (object)
	   (send *print-hash-table* :modify-hash object (lambda (object value foundp)
							  (declare (ignore object value))
							  foundp))))
    (macrolet ((recursep (object)
		 ;; eliminate simple tail-recursive call if possible, since function-call is
		 ;;  so expensive on a cadr-style machine
		 `(if (symbolp ,object)
		      (null (symbol-package ,object))
		    (%pointerp ,object))))
      (when (and (recursep object)
		 (not (seen object)))
	(typecase object
	  (list
	   (do ((tail object (cdr tail))
		(first t nil))
	       ((atom tail)
		(if (recursep tail) (print-record-occurrences tail)))
	     (unless first
	       (if (seen tail) (return nil)))
	   (if (recursep (car tail)) (print-record-occurrences (car tail)))))
	  ;; it is actually wrong not to hack this case, but there is no defined protocol
	  ;;  for doing so.
	  ;(instance)
	  (array
	   (cond ((numberp (cdr (assq (array-type object) array-bits-per-element)))
		  ;;>> this actually cheats somewhat in the complex and complex-float cases
		  t)
		 ((named-structure-p object)
		  ;; this is actually wrong, but there is no other defined protocol
		  (memq ':print-self (named-structure-invoke :which-operations object)))
		 ((and (simple-vector-p object)
		       (> (length object) (or *print-length*
					      *print-simple-vector-length*
					      -1))))
		 ((null *print-array*))
		 (t
		  (dotimes (i (array-length object))
		    (let ((x (condition-case ()
				 (cli:ar-1-force object i)
			       (eh:subscript-error (return-from print-record-occurrences nil)))))
		      (if (recursep x) (print-record-occurrences x)))))))
	  (complex
	   (if (%pointerp (%complex-real-part object))
	       (seen (%complex-real-part object)))
	   (if (%pointerp (%complex-imag-part object))
	       (seen (%complex-real-part object)))))))))
))