;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 123.254
;;; Reason:
;;;  When pretty-printing, print (function xxx) as #'xxx
;;; Written 4-May-88 23:39:20 by keith at site Gigamos Cambridge
;;; while running on Azathoth from band 3
;;; with Experimental System 123.253, Experimental Local-File 73.5, Experimental FILE-Server 22.4, Experimental Unix-Interface 11.0, Experimental KERMIT 34.3, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, Experimental Tape 22.4, microcode 1756, SDU Boot Tape 3.14, SDU ROM 8, the old ones.



; From modified file DJ: L.IO; GRIND.LISP#150 at 4-May-88 23:39:35
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; GRIND  "


(DEFUN GRIND-FUNCTION (EXP LOC)
  (COND ((AND (CDR EXP) (CONSP (CDR EXP)) (NULL (CDDR EXP)))
	 (GTYO #/# LOC)
	 (GTYO #/' LOC)
	 (GIND (GRIND-AS-BLOCK (CADR EXP) (LOCF (CADR EXP)))))
	(T (GRIND-AS-BLOCK EXP LOC))))

(DEFUN GRIND-LINEAR-FORM (EXP LOC &OPTIONAL (CHECK-FOR-MACROS T) &AUX TEM)
  (COND ((ATOM EXP)					;Atoms print very simply
	 (GRIND-ATOM EXP GRIND-IO LOC))
	((AND PRINLEVEL ( GRIND-DEPTH PRINLEVEL))
	 (GRIND-ATOM (PTTBL-PRINLEVEL *READTABLE*) GRIND-IO LOC))
	;; Prevent errors taking CADR below.
	((ATOM (CDR EXP))
	 (GRIND-LINEAR-TAIL EXP LOC))
	((MEMQ (CAR EXP) '(GRIND-COMMA GRIND-COMMA-ATSIGN GRIND-COMMA-DOT GRIND-DOT-COMMA))
	 (SELECTQ (CAR EXP)
	   (GRIND-COMMA (GTYO #/,))
	   (GRIND-COMMA-ATSIGN (GTYO #/,) (GTYO #/@))
	   (GRIND-COMMA-DOT (GTYO #/,) (GTYO #/.))
	   (GRIND-DOT-COMMA (GTYO #/.) (GTYO-SPACE) (GTYO #/,)))
	 (GRIND-LINEAR-FORM (CADR EXP) (LOCF (CADR EXP))))
	((AND CHECK-FOR-MACROS
	      (OR (AND (SYMBOLP (CAR EXP))			;Check for GRIND-MACRO
		       (NOT (EQ (CAR EXP) 'QUOTE))		;(KLUDGE)
		       (NOT (EQ (CAR EXP) 'FUNCTION))		;(KLUDGE)
		       (SETQ TEM (GET (CAR EXP) 'GRIND-MACRO)))
		  (AND (CONSP (CAR EXP))			;Check for LAMBDA
		       (SYMBOLP (CAAR EXP))
		       (SETQ TEM (GET (CAAR EXP) 'GRIND-L-MACRO)))))
	 (*THROW 'GRIND-DOESNT-FIT-CATCH NIL))		;Macro, don't use linear form
	((EQ (CAR EXP) 'QUOTE)				;(KLUDGE)
	 (GRIND-QUOTE EXP LOC))
	((EQ (CAR EXP) 'FUNCTION)				;(KLUDGE)
	 (GRIND-FUNCTION EXP LOC))
	((EQ (CAR EXP) GRIND-DISPLACED)
	 (GRIND-LINEAR-FORM (CADR EXP) (LOCF (CADR EXP))))
	(T (GRIND-LINEAR-TAIL EXP LOC))))

))

; From modified file DJ: L.IO; GRIND.LISP#150 at 4-May-88 23:39:40
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; GRIND  "

(DEFPROP FUNCTION GRIND-FUNCTION GRIND-MACRO)

))