;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 126.105
;;; Reason:
;;;  1) Logic fix to INVOKE-STYLE-CHECKER.
;;;  
;;;  2) Define MAYBE-INVOKE-STYLE-CHECKER to centralize testing style-check
;;;  flags, ensure arg is symbol, etc.  May come in handy in COMPILE-DRIVER?
;;; Reason:
;;;  Minor bug in INVOKE-STYLE-CHECKER which goofed up printout when tracing
;;;  style-checker invocations.
;;; Written 14-Oct-88 00:29:53 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, microcode 1762, SDU Boot Tape 3.14, SDU ROM 103.



; From modified file DJ: L.SYS; QCP1.LISP#739 at 14-Oct-88 02:01:42
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCP1  "


(defun invoke-style-checker (fcn form)
  (let (style-checker style-checker-name)
    (flet ((applicable-p (switch)
	    (and switch (or (eq switch t) (member style-checker-name switch)))))
      (and
	;;Is there a style checker for function?
	(setq style-checker (get fcn 'style-checker))
	(setq style-checker-name (function-name style-checker))
	(or
	  ;;Either we're warning on every un-stylish call,
	  ;;...Or we're only warning on the first bad call we find,
	  ;;   possibly calling only selected style checkers.
	  (not (applicable-p *just-once-for-style-checkers-per-inner-form*))
	  (not (already-checked-style-for-function style-checker fcn))
	  ;;Trace when we pass up a style check:
	  (when (applicable-p *trace-style-checkers*)
	    (format *trace-output* "~&{Skipping style-check ~A on ~A}"
		    style-checker-name fcn)))
	(prog (result)
	      ;;Trace, if applicable.  Also see above.
	      (let ((*print-pretty* *trace-style-checkers-print-pretty*)
		    (*print-level* *trace-style-checkers-print-level*)
		    (*print-length* *trace-style-checkers-print-length*))
		(when (applicable-p *trace-style-checkers*)
		  (format *trace-output*
			  "~&~A style-checking ~A: ~~S~~%"
			  style-checker-name fcn form))
		;;Invoke style check:
		(multiple-value-bind (ignore warning?)
		    (funcall style-checker form)
		  (and (setq result (eq warning? 'warn))
		       ;;Note that a warning was issued.
		       (note-style-check-for-function style-checker fcn)))
		(when (applicable-p *trace-style-checkers*)
		  (format *trace-output*
			  "~&  {~:[Style checked OK~;Style warning issued~]}"
			  result))
		(return result)))))))

))

; From modified file DJ: L.SYS; QCP1.LISP#739 at 14-Oct-88 02:01:46
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCP1  "


(defun maybe-invoke-style-checker (form &optional (fn (car form)))
  ;;Are we redundant yet?
  (and *check-style-p* (not inhibit-style-warnings-switch)
       (symbolp fn)
       ;;Try to invoke the darn thing:
       (invoke-style-checker fn form)))


;;;This is the main style-check/optimize/macroexpand transforming function.
;;;
;;;Given a form, apply optimizations and expand macros until no more is
;;;possible (at the top level).  Also apply style-checkers as applicable, to
;;;both inputs and generated outputs.  This function is also in charge of
;;;checking for too few or too many arguments so that this happens before
;;;optimizers are applied.
;;;
;;;DONT-OPTIMIZE means not to run optimizers for the top-level form; this does
;;;not affect the mandatory calling of rewriters for the form.

))

; From modified file DJ: L.SYS; QCP1.LISP#739 at 14-Oct-88 02:01:48
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCP1  "


(defun compiler-optimize (form &optional dont-optimize
			  &aux (*check-style-p* *check-style-p*))
  (cond ((already-optimized-p form)
	 form)
	(t 
    (do (tem fn local-definition rewritten-already)
	;;Do this loop until no more expansions possible.
	((atom form))
      (setq fn (lambda-macro-expand (car form)))
      (unless (eq fn (car form)) (setq form (cons fn (cdr form))))
      (unless rewritten-already
	;; Check for too few or too many arguments
	(check-number-of-args form fn))
      (setq local-definition
	    (and (symbolp fn) (fsymeval-in-function-environment fn *function-environment*)))
      ;; Do style checking, maybe
      (and (not rewritten-already)
	   (not local-definition)
	   (maybe-invoke-style-checker form fn))
      ;; Optimize args to vanilla functions
      (when (symbolp fn)
	;; don't optimize args to macros, special forms, or functions with p1 handlers
	(unless (if local-definition
		    (eq (car local-definition) 'macro)
		  (or (get fn 'p1)
		      (macro-function fn)
		      (special-form-p fn)
		      (and (neq *target-computer* 'lambda-interface)
			   (get fn 'p1cross))))
	  (setq form (cons (car form)
			   (let ((*p1value* 1)) ; Need one value from each argform
			     (mapcar #'compiler-optimize (cdr form)))))))
      (or (unless (or local-definition (not (symbolp fn)))
	    (dolist (opt (get fn 'rewriters))
	      (unless (eq form (setq form (funcall opt form)))
		;; Rewriter changed something, don't do macros this pass
		(setq rewritten-already t)
		(return t))))
	  (unless (or local-definition
		      (not (symbolp fn))
		      dont-optimize
		      *inhibit-optimizers*)
	    (dolist (opt (get fn 'optimizers))
	      (unless (eq form (setq form (invoke-optimizer opt form)))
		;; Optimizer changed something, don't do macros this pass
		(setq rewritten-already t)
		(return t))))
	  ;; No optimizer did anything => try expanding macros.
	  (warn-on-errors ('macro-expansion-error "Error expanding macro ~S:" fn)
	    ;; This LET returns T if we expand something.
	    (or (let ((record-macros-expanded t))
		  (multiple-value-setq (form tem)
		    (compiler-macroexpand-1 form))
		  tem)				;non-nil if macroexpansion happened
		;; Stop looping, no expansions apply
		(return nil)))
	  ;; The body of the WARN-ON-ERRORS either does RETURN or returns T.
	  ;; So if we get here, there was an error inside it.
	  (return (setq form `(error-macro-expanding ',form))))
      ;; Only do style checking the first time around
      (setq *check-style-p* nil))
    ;; Result is FORM
    (cond ((and (listp form)
		(symbolp (car form))
		(fboundp (car form))
		(listp (fdefinition (car form)))
		(eq 'macro (car (fdefinition (car form)))))
	   (fsignal "About to return form containing macro from compiler-optimize")))
    (flag-already-optimized form))))

))