;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 126.108
;;; Reason:
;;;  First pass at proper compiler style-check handling of top-level file and
;;;  buffer forms (e.g.  IF, DEFSTRUCT).  Anything more innerward seems to get
;;;  handled with optimizers, but top-level forms weren't.  Now, style-check
;;;  before, after macro-expansion of top-level forms, within PROGN, etc.
;;;  
;;;  In a related move, ZWEI's main interval compiling interface now nulls out the
;;;  style-check once-per-inner-form database (so top-level style warnings don't
;;;  get too obnoxious).
;;; Written 14-Oct-88 17:48:38 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Breaking Glass from band 3
;;; with Experimental System 126.104, Experimental ZWEI 126.18, Experimental ZMail 74.9, Experimental Local-File 76.0, Experimental File-Server 25.0, Experimental Lambda-Diag 18.0, Experimental Unix-Interface 15.0, Experimental Tape 26.4, Experimental IMicro 20.0, microcode 1762, SDU Boot Tape 3.14, SDU ROM 103.



; From modified file DJ: L.SYS; QCFILE.LISP#382 at 14-Oct-88 17:49:10
#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)))))
	  (T (FUNCALL PROCESS-FN FORM 'RANDOM)))))

))

; From modified file DJ: L.ZWEI; COMC.LISP#227 at 14-Oct-88 17:49:37
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; COMC  "


(DEFUN COMPILE-INTERVAL-PROCESS-FN (FORM)
  (let ((compiler:*just-once-for-style-checkers-per-inner-form-alist* nil))
    (COMPILER:COMPILE-DRIVER FORM 'COMPILE-INTERVAL-PROCESS-BASIC-FORM
			     'COMPILE-INTERVAL-PREPROCESS-FN)))

;;;COMPILE-DRIVER does all sorts of macro-expand stuff these days, regardless of process-fn 
;;;  and OVERRIDE-FN, so we bypass it if this buffer doesnt contain LISP anyway.

))