;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 130.6
;;; Reason:
;;;  Pretty-printing of arrays was very badly broken, causing infinite loop
;;;  within GRIND-PRINT-IO.  Now we just PRIN1 or PRINC as appropriate.
;;;  Someday someone should figure this one out and really fix it.
;;;  
;;;     -keith+smh
;;; Written 17-Nov-88 20:08:20 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; GRIND.LISP#153 at 17-Nov-88 20:09:05
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; GRIND  "

(defmacro grind-punt (exp stream)
  `(let ((*print-pretty* nil))
     (if *print-escape*
	 (prin1 ,exp ,stream)
       (princ ,exp ,stream))))

))

; From modified file DJ: L.IO; GRIND.LISP#153 at 17-Nov-88 20:09:12
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; GRIND  "


(DEFUN GRIND-ARRAY (EXP LOC)
  ;; +++ This code must have worked once upon a time, but
  ;;     now it causes an infinite loop in GRIND-PRINT-IO.
  ;;     <17-Nov-88 keith>
  #+never
  (IF (= (ARRAY-RANK EXP) 1)
      (IF (EQ (ARRAY-TYPE EXP) 'ART-1B)
	  (GRIND-ATOM EXP GRIND-IO LOC)
	(GRIND-AS-BLOCK (LISTARRAY EXP) NIL
			(CAR (PTTBL-VECTOR *READTABLE*))
			(CDR (PTTBL-VECTOR *READTABLE*))))
    (DOLIST (ELT (PTTBL-ARRAY *READTABLE*))
      (COND ((STRINGP ELT)
	     (GSTRING ELT))
	    ((EQ ELT ':RANK)
	     (LET ((*PRINT-BASE* 10.) (*PRINT-RADIX* NIL) (*NOPOINT T))
	       (GRIND-ATOM (ARRAY-RANK EXP) GRIND-IO NIL)))
	    ((EQ ELT ':SEQUENCES)
	     (OR (GRIND-TRY 'GRIND-ARRAY-CONTENTS
			    EXP 0 0 T)
		 (GRIND-ARRAY-CONTENTS EXP 0 0))))))
  ;;;  $$$ Just PRINT arrays until above code can be fixed. <17-Nov-88 keith>
  (ignore loc)
  (grind-punt exp grind-io))

))