;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 130.11
;;; Reason:
;;;  The cross compiler now understands DEFAFUN both in files and editor buffers.
;;;  For the present it only understands COMPILER::DEFAFUN, but the symbol will
;;;  presently be made available in other packages.
;;; Written 22-Nov-88 19:00:34 by smh (Steve Haflich) at site Gigamos Cambridge
;;; while running on Alex from band 1
;;; with Experimental System 130.9, Experimental ZWEI 128.7, 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 102, 11/18 Falcon System Loaded.



; From modified file DJ: L.SYS; QCP1.LISP#746 at 22-Nov-88 19:01:09
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCP1  "

(defun compile-defafun (form)
  (compiler-target-switch (defafun form 'compile-to-core)))

))

; From modified file DJ: L.SYS; QCFILE.LISP#384 at 22-Nov-88 19:04:02
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCFILE  "

(DEFUN QC-FILE-FORM (FORM)
  (PROG (TEM FV)
    (COND ((ATOM FORM))
	  ((EQ (CAR FORM) 'COMMENT))		;Delete comments entirely
	  ((EQ (CAR FORM) 'DEFUN)
	   (SETQ TEM (CADR FORM))
	   (SETQ FV (SI:PROCESS-DEFUN-BODY TEM (CDDR FORM)))
	   (COND (QC-FILE-LOAD-FLAG
		     (RPLACA (FUNCTION-CELL-LOCATION TEM) FV)	;In case used interpreted
		     (COMPILE-1 TEM FV)
		     (RETURN (QC-FILE-FASD-FORM FORM T))))
           (QC-TRANSLATE-FUNCTION TEM FV
				  'MACRO-COMPILE
				  (IF QC-FILE-REL-FORMAT 'REL 'QFASL))
	   (IF (AND *MICROCOMPILE-SWITCH*
		    (GETDECL TEM 'MICROCOMPILE))
	       (QC-TRANSLATE-FUNCTION
		 TEM FV				;Once more, with feeling
		 'MICRO-COMPILE
		 (COND (QC-FILE-REL-FORMAT 'REL)
		       (T 'QFASL))))
	   (RETURN NIL))
	  ((eq (car form) 'defafun)		; $$$ added <22-Nov-88 smh>
	   (return (compiler-target-switch (defafun form 'qfasl))))
	  (QC-FILE-LOAD-FLAG (EVAL FORM)))
    (RETURN (QC-FILE-FASD-FORM FORM T))))

))

; From modified file DJ: L.SYS; QCFILE.LISP#384 at 22-Nov-88 19:04:15
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCFILE  "

(DEFUN COMPILE-DRIVER (FORM PROCESS-FN OVERRIDE-FN &OPTIONAL COMPILE-TIME-TOO (TOP-LEVEL-P T)
		       &AUX FN (OFORM FORM))
  ;; The following loop is essentially MACROEXPAND,
  ;; but for each expansion, we create an appropriate warn-on-errors message
  ;; containing the name of the macro about to be (perhaps) expanded this time.
  (DO ((NFORM))
      (())
    (IF (AND OVERRIDE-FN
	     (FUNCALL OVERRIDE-FN FORM))
	(RETURN-FROM COMPILE-DRIVER NIL))
    (IF (ATOM FORM) (RETURN NIL))
    (maybe-invoke-style-checker form)
;    ;; Don't expand LOCALLY into PROGN here!
;    ;; This way, we protect DECLAREs inside the LOCALLY
;    ;; from being treated as top-level DECLARE, which would be erroneous.
;    ;; The LOCALLY form will just be executed as a random form.
;    (IF (EQ (CAR FORM) 'LOCALLY)
;	 (RETURN))
    (SETQ NFORM
	  (WARN-ON-ERRORS ('MACRO-EXPANSION-ERROR "Error expanding macro ~S at top level"
			   (CAR FORM))
	    (MACROEXPAND-1 FORM)))
    (IF (EQ FORM NFORM) (RETURN)
      (SETQ FORM NFORM)))
  ;; If this was a top-level macro, supply a good guess
  ;; for the function-parent for any DEFUNs inside the expansion.
  (LET ((LOCAL-DECLARATIONS LOCAL-DECLARATIONS))
    (COND ((ATOM FORM))
	  ((AND (NEQ FORM OFORM) (SYMBOLP (CADR OFORM)))
	   (PUSH `(FUNCTION-PARENT ,(CADR OFORM)) LOCAL-DECLARATIONS))
	  ((EQ (CAR OFORM) 'DEFSTRUCT)
	   (PUSH `(FUNCTION-PARENT ,(IF (SYMBOLP (CADR OFORM)) (CADR OFORM) (CAADR OFORM)))
		 LOCAL-DECLARATIONS)))
    (AND (CONSP FORM)
	 (NEQ (CAR FORM) 'EVAL-WHEN)
	 COMPILE-TIME-TOO
	 (FUNCALL PROCESS-FN FORM 'DECLARE))
    (COND ((ATOM FORM)
	   (FUNCALL PROCESS-FN FORM 'RANDOM))
	  ((EQ (CAR FORM) 'EVAL-WHEN)
	   (OR (AND (CL:LISTP (CADR FORM))
		    (LOOP FOR TIME IN (CADR FORM)
			  ALWAYS (MEMQ TIME '(EVAL LOAD COMPILE))))
	       (FERROR "~S invalid ~S times;~%  must be a list of ~S, ~S, and//or ~S."
			   (CADR FORM) 'EVAL-WHEN 'EVAL 'LOAD 'COMPILE))
	   (LET* ((COMPILE (MEMQ 'COMPILE (CADR FORM)))
		  (LOAD (MEMQ 'LOAD (CADR FORM)))
		  (EVAL (MEMQ 'EVAL (CADR FORM)))
		  (EVAL-NOW (OR COMPILE (AND COMPILE-TIME-TOO EVAL))))
	     (DOLIST (FORM1 (CDDR FORM))
	       (IF LOAD
		   (IF EVAL-NOW
		       (COMPILE-DRIVER FORM1 PROCESS-FN OVERRIDE-FN T NIL)
		     (COMPILE-DRIVER FORM1 PROCESS-FN OVERRIDE-FN NIL NIL))
		 (IF EVAL-NOW
		     (FUNCALL PROCESS-FN FORM1 'DECLARE))))))
	  ((EQ (SETQ FN (CAR FORM)) 'DEFF)
	   (COMPILATION-DEFINE (CADR FORM))
	   (FUNCALL PROCESS-FN FORM 'RANDOM))
	  ((EQ FN 'DEF)
	   (COMPILATION-DEFINE (CADR FORM))
	   (MAPC (LAMBDA (FORM)
		   (COMPILE-DRIVER FORM PROCESS-FN OVERRIDE-FN COMPILE-TIME-TOO NIL))
		 (CDDR FORM)))
	  ((EQ FN 'WITH-SELF-ACCESSIBLE)
	   (MAPC (LAMBDA (FORM)
		   (COMPILE-DRIVER FORM PROCESS-FN OVERRIDE-FN COMPILE-TIME-TOO NIL))
		 (CDDR FORM)))
	  ((EQ FN 'PROGN)
	   (MAPC (LAMBDA (FORM)
		   (COMPILE-DRIVER FORM PROCESS-FN OVERRIDE-FN COMPILE-TIME-TOO T))
		 (CDR FORM)))
	  ((MEMQ FN '(MACRO DEFSUBST))
	   (FUNCALL PROCESS-FN FORM 'MACRO))
	  ((AND TOP-LEVEL-P
		(MEMQ FN '(SPECIAL UNSPECIAL MAKE-PACKAGE IN-PACKAGE SHADOW SHADOWING-IMPORT
			   EXPORT UNEXPORT USE-PACKAGE UNUSE-PACKAGE IMPORT DEFF-MACRO
			   REQUIRE)))
	   (FUNCALL PROCESS-FN FORM 'SPECIAL))
	  ((EQ FN 'DECLARE)
	   (COMPILE-DECLARE (CDR FORM) PROCESS-FN))
	  ((EQ FN 'PROCLAIM)
	   (COMPILE-PROCLAIM (CDR FORM) PROCESS-FN))
	  ((EQ FN 'COMMENT) NIL)
	  ((EQ FN 'PATCH-SOURCE-FILE)
	   (COMPILE-DRIVER `(EVAL-WHEN (LOAD EVAL)
			      (SETQ SI:PATCH-SOURCE-FILE-NAMESTRING ,(CADR FORM)))
			   PROCESS-FN OVERRIDE-FN COMPILE-TIME-TOO T)
	   (MAPC (LAMBDA (FORM)
		   (COMPILE-DRIVER FORM PROCESS-FN OVERRIDE-FN COMPILE-TIME-TOO T))
		 (CDDR FORM))
	   (COMPILE-DRIVER `(EVAL-WHEN (LOAD EVAL)
			      (SETQ SI:PATCH-SOURCE-FILE-NAMESTRING NIL))
			   PROCESS-FN OVERRIDE-FN COMPILE-TIME-TOO T))
	  ((EQ FN 'COMPILER-LET)
	   (PROGW (CADR FORM)
	     (COMPILE-DRIVER `(PROGN . ,(CDDR FORM))
			     PROCESS-FN OVERRIDE-FN COMPILE-TIME-TOO T)))
	  ((EQ FN 'DEFUN)
	   (LET (TEM)
	     (WARN-ON-ERRORS ('MALFORMED-DEFUN "Malformed DEFUN")
	       (SETQ TEM (DEFUN-COMPATIBILITY (CDR FORM))))
	     (COND ((EQ (CDR TEM) (CDR FORM))
		    (IF (NULL (CDDR TEM))
			(WARN 'MALFORMED-DEFUN :IMPOSSIBLE "Malformed defun ~S" FORM)
		      (FUNCALL PROCESS-FN FORM 'DEFUN)))
		   (T (COMPILE-DRIVER TEM PROCESS-FN OVERRIDE-FN COMPILE-TIME-TOO NIL)))))
	  ((eq fn 'defafun)			; $$$ added <22-Nov-88 smh>
	   (funcall process-fn form 'defafun))
	  (T (FUNCALL PROCESS-FN FORM 'RANDOM)))))

))