;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 126.83
;;; Reason:
;;;  Implement less simple-minded compiler style checking.
;;;  
;;;  Compiler was invoking style checkers on every call to optimize a given form.
;;;  This frequently causes duplicate warnings for a given mis-formed call.  Also,
;;;  it is very easy to generate multiple duplicate errors within one DEFUN;
;;;  typically, only one warning is enough to show the user what to change.
;;;  
;;;  New scheme is controlled by compiler variable, so those who want lots of
;;;  compiler warnings can turn the new feature off.  The variable doc string
;;;  explains how it works:
;;;  
;;;  (defvar *just-once-for-style-checkers-per-inner-form* T
;;;    "If non-NIL, user only gets one style-check warning within a top-level form,
;;;    for a given combination of style-checker function and form (function call).
;;;  T means condense for all style-checkers; can also be a list of style-checker
;;;    functions to condense in this fashion.")
;;; Written 15-Sep-88 02:18:01 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Breaking Glass from band 3
;;; with Experimental System 126.82, Experimental ZWEI 126.10, Experimental ZMail 74.1, Experimental Local-File 76.0, Experimental File-Server 25.0, Experimental Unix-Interface 14.0, Experimental Tape 25.1, Experimental Lambda-Diag 18.0, microcode 1762, SDU Boot Tape 3.14, SDU ROM 103, Lambda/Falcon Development System.



; From modified file DJ: L.SYS; QCP1.LISP#730 at 15-Sep-88 02:18:53
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCP1  "


(DEFUN QC-TRANSLATE-FUNCTION (FUNCTION-SPEC EXP QC-TF-PROCESSING-MODE QC-TF-OUTPUT-MODE
			      &OPTIONAL (NAME-FOR-FUNCTION FUNCTION-SPEC))
  "Compile one function.  All styles of the compiler come through here.
QC-TF-PROCESSING-MODE should be MACRO-COMPILE or MICRO-COMPILE.
QC-TF-OUTPUT-MODE is used by LAP to determine where to put the compiled code.
 It is COMPILE-TO-CORE for making an actual FEF, QFASL, REL, or
 QFASL-NO-FDEFINE to simply dump a FEF without trying to define a function
EXP is the lambda-expression.
NAME-FOR-FUNCTION is what the fef's name field should say;
 if omitted, FUNCTION-SPEC is used for that too.
In MACRO-COMPILE mode, the return value is the value of QLAPP for the first function."
 (WHEN COMPILER-VERBOSE
   (FORMAT T "~&Compiling ~S" FUNCTION-SPEC))
 (let ((*just-once-for-style-checkers-per-inner-form-alist* NIL))
   (OBJECT-OPERATION-WITH-WARNINGS (NAME-FOR-FUNCTION)
     (LET ((EH:*ERROR-MESSAGE-HOOK* (LET-CLOSED ((FUNCTION-BEING-PROCESSED NAME-FOR-FUNCTION))
				      (LAMBDA ()
					(AND FUNCTION-BEING-PROCESSED
					     (FORMAT T "Error occurred while compiling ~S"
						     FUNCTION-BEING-PROCESSED)))))
	   (COMPILER-QUEUE
	     (NCONS
	       (MAKE-COMPILER-QUEUE-ENTRY
		 :FUNCTION-SPEC FUNCTION-SPEC
		 :FUNCTION-NAME NAME-FOR-FUNCTION
		 :DEFINITION (qc-translate-function-hook function-spec EXP)
		 :DECLARATIONS LOCAL-DECLARATIONS)))
	   (DEFAULT-CONS-AREA QCOMPILE-TEMPORARY-AREA)
	   (INSIDE-QC-TRANSLATE-FUNCTION T)
	   ;; If compiling to code this is (,function-spec ,fef ,fdefinition-has-already-happened)
	   ;;  for fefs which are waiting for their internal functions to be compiled
	   ;;  This should really be a part of the compiler-queue-entry data structure
	   ;;   -- I'm just a little tired now.
	   (PENDING-DEFINITION)
	   THIS-FUNCTION-BARF-SPECIAL-LIST
	   VARIABLES-LISTS
	   )
       (do ((entries compiler-queue (cdr entries))
	    entry
	    (*compiling-breakoffs-p* nil t))
	   ((null entries))
	 (setq entry (car entries))
	 (SETF (FILL-POINTER QCMP-OUTPUT) 0)
	 (LET ((DEFINITION (COMPILER-QUEUE-ENTRY-DEFINITION ENTRY))
	       (FUNCTION-TO-DEFINE (COMPILER-QUEUE-ENTRY-FUNCTION-SPEC ENTRY))
	       (NAME-FOR-FUNCTION (COMPILER-QUEUE-ENTRY-FUNCTION-NAME ENTRY))
	       (LOCAL-DECLARATIONS (COMPILER-QUEUE-ENTRY-DECLARATIONS ENTRY))
	       (*OUTER-CONTEXT-VARS* (COMPILER-QUEUE-ENTRY-VARIABLES ENTRY))
	       (*OUTER-CONTEXT-LOCAL-FUNCTIONS* (COMPILER-QUEUE-ENTRY-LOCAL-FUNCTIONS ENTRY))
	       (*OUTER-CONTEXT-FUNCTION-ENVIRONMENT*
		 (COMPILER-QUEUE-ENTRY-FUNCTION-ENVIRONMENT ENTRY))
	       (*OUTER-CONTEXT-PROGDESC-ENVIRONMENT* (COMPILER-QUEUE-ENTRY-PROGDESCS ENTRY))
	       (*OUTER-CONTEXT-GOTAG-ENVIRONMENT* (COMPILER-QUEUE-ENTRY-GOTAGS ENTRY))
	       THIS-FUNCTION-ARGLIST
	       THIS-FUNCTION-ARGLIST-FUNCTION-NAME)
	   (OBJECT-OPERATION-WITH-WARNINGS (NAME-FOR-FUNCTION)
	     (CATCH-ERROR-RESTART (EH:DEBUGGER-CONDITION
				    "Give up on compiling ~S" NAME-FOR-FUNCTION)
	       (PUSH (QCOMPILE0 DEFINITION FUNCTION-TO-DEFINE
				(or (not (eq *target-computer* 'lambda-interface))
				    (EQ QC-TF-PROCESSING-MODE 'MICRO-COMPILE))
				NAME-FOR-FUNCTION)
		     VARIABLES-LISTS)
	       (AND PEEP-ENABLE
		    (NEQ QC-TF-PROCESSING-MODE 'MICRO-COMPILE)
		    (compiler-target-switch (PEEP QCMP-OUTPUT FUNCTION-TO-DEFINE)))
	       (COND ((NULL HOLDPROG))
		     ((EQ QC-TF-PROCESSING-MODE 'MACRO-COMPILE)
		      (let ((fef (compiler-target-switch
				   (QLAPP (G-L-P QCMP-OUTPUT) QC-TF-OUTPUT-MODE)))
			    tem)
			(if (eq qc-tf-output-mode 'compile-to-core)
			    (cond ((and (eq (car-safe function-to-define) ':internal)
					(setq tem (si:assoc-equal (cadr function-to-define)
								  pending-definition)))
				   ;; we depend on someone
				   (compiler-target-switch
				     (fdefine `(:internal ,(cadr tem) . ,(cddr function-to-define))
					      fef))
				   (push `(,function-to-define ,fef t) pending-definition))
				  (t
				   (push `(,function-to-define ,fef) pending-definition)))
			  (or pending-definition (setq pending-definition fef)))))
		     ((EQ QC-TF-PROCESSING-MODE 'MICRO-COMPILE)
		      (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))
			(MICRO-COMPILE-INTERNAL (G-L-P QCMP-OUTPUT) QC-TF-OUTPUT-MODE))))))))
       (DOLIST (VL VARIABLES-LISTS)
	 (DOLIST (V VL)
	   (COND ((OR (STRING= (VAR-NAME V) "IGNORE")
		      (STRING= (VAR-NAME V) "IGNORED"))
		  (OR (ZEROP (VAR-USE-COUNT V))
		      (WARN 'NOT-IGNORED :IMPLAUSIBLE
			"The variable ~S is bound and not ignored." (VAR-NAME V))))
		 ((GETF (VAR-DECLARATIONS V) 'IGNORE)
		  (OR (ZEROP (VAR-USE-COUNT V))
		      (WARN 'NOT-IGNORED :IMPLAUSIBLE
			"The variable ~S, which is declared to be ignored, was referenced"
			(VAR-NAME V))))
		 ((NOT (GET (VAR-NAME V) 'IGNORABLE-VARIABLE))
		  (AND (ZEROP (VAR-USE-COUNT V))
		       (EQ (VAR-TYPE V) 'FEF-LOCAL)
		       (IF (GET (VAR-NAME V) 'LOCAL-FUNCTION-NAME)
			   (WARN 'NOT-USED :IMPLAUSIBLE
			     "The local function ~S is never used."
			     (GET (VAR-NAME V) 'LOCAL-FUNCTION-NAME))
			 (WARN 'NOT-USED :IMPLAUSIBLE
			   "The variable ~S is bound but never used." (VAR-NAME V))))))))
       (COND ((NEQ QC-TF-PROCESSING-MODE 'MACRO-COMPILE)
	      NIL)
	     ((eq qc-tf-output-mode 'compile-to-core)
	      (setq pending-definition (nreverse pending-definition))
	      (AND SI:*SNAP-INDEXED-FORWARDS*		 ;normally NIL
		   (FBOUNDP 'SI:RELINK-FEF-EXIT-VECTOR)
		   (dolist (e pending-definition)
		     (SI:RELINK-FEF-EXIT-VECTOR (cadr e))))
	      (dolist (e (cdr pending-definition))
		(unless (caddr e)
		  (fdefine (car e) (cadr e) t)))
	      ;; this is the top-level function.  Must do this last.
	      (compiler-target-switch
		(fdefine (caar pending-definition) (cadar pending-definition) t))
	      (cadar pending-definition))
	     (t
	      ;; in the qfasl-output case there is still an internal-function
	      ;; screw, in that the half-defined function may be called (as part of fasload,
	      ;; or from another process) whilst we are still filling in the breakoffs.
	      pending-definition))))))


))


; From modified file DJ: L.SYS; QCP1.LISP#730 at 15-Sep-88 02:19:53
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCP1  "

;;;;;;STYLE CHECKING

(defvar *trace-style-checkers* nil
  "If T, report all style checkers.
If a list, only report the named style checkers.
Reports go to *TRACE-OUTPUT*")

;;;Following are used to set corresponding print control variables
;;;when tracing style checking:

(defvar *trace-style-checkers-print-pretty* T)
(defvar *trace-style-checkers-print-level* 3.)
(defvar *trace-style-checkers-print-length* 5.)

(defvar *just-once-for-style-checkers-per-inner-form* T
  "If non-NIL, user only gets one style-check warning within a top-level form,
  for a given combination of style-checker function and form (function call).
The default, T, means condense for all style-checkers; can also be a list of
  style-checker functions to condense in this function.")

;;;Next is an Alist kept per top-level form to note that we've already seen a
;;;style violation for style-checker/form combination.  CAR's are style-checker
;;;function <names>, like COMPILER:OBSOLETE; the rest of the list contains the
;;;names of any function names for which this particular style violation has
;;;been detected.

(defvar *just-once-for-style-checkers-per-inner-form-alist* NIL)

;;;Utility functions to maintain style-checker/form Alist:

(defun already-checked-style-for-function (style-checker fcn)
  "If STYLE-CHECKER has been not been called before on FCN (in current
style-checking environment), return non-NIL.  Doesn't note invocation.
Otherwise, returns NIL."
  (memq (function-name fcn)
	(cdr (assoc (function-name style-checker)
		    *just-once-for-style-checkers-per-inner-form-alist*))))

(defun note-style-check-for-function (style-checker fcn)
  "Note that STYLE-CHECKER has been called on FCN (in current
style-checking environment)."
  (let* ((function-name (function-name fcn))
	 (style-checker-name (function-name style-checker))
	 (functions-already-checked
	   (assoc style-checker-name
		  *just-once-for-style-checkers-per-inner-form-alist*)))
    (if (null functions-already-checked)
	(push (list style-checker-name function-name)
	      *just-once-for-style-checkers-per-inner-form-alist*)
      (pushnew function-name
	       (cdr (assoc style-checker-name *just-once-for-style-checkers-per-inner-form-alist*))))))

(defun first-style-check-for-function (style-checker fcn)
  "If STYLE-CHECKER has been not been called before on FCN (in current
style-checking environment), return non-NIL and note the invocation.
Otherwise, returns NIL."
  (let* ((function-name (print(function-name fcn)))
	 (style-checker-name (print(function-name style-checker)))
	 (functions-already-checked
	   (assoc style-checker-name *just-once-for-style-checkers-per-inner-form-alist*)))
    (cond
      ((null functions-already-checked)
       (push (list style-checker-name function-name)
	     *just-once-for-style-checkers-per-inner-form-alist*))
      ((memq function-name functions-already-checked)
       nil)
      (:else
       (push function-name
	     (cdr (assoc style-checker-name *just-once-for-style-checkers-per-inner-form-alist*)))))))

;;;Given a function name symbol and the complete form it was found within, this
;;;invokes its style checker (if any), doing the recording and just-once
;;;warning as noted above:

(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)))))
      (when
	(and
	  ;;Is there a style checker for function?
	  (setq style-checker (get fcn 'style-checker))
	  (setq style-checker-name (function-name style-checker))
	  ;;Either we're warning on every un-stylish call,
	  (or (null *just-once-for-style-checkers-per-inner-form*)
	      ;;...Or we're only warning on the first bad call we find,
	      ;;   possibly calling only selected style checkers.
	      (and (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.
		   (prog1 t
			  (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))))))))


;;;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.

(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)
	   (symbolp fn)
	   ;;Are we redundant yet?
	   *check-style-p* (not inhibit-style-warnings-switch)
	   ;;Try to invoke the darn thing:
	   (invoke-style-checker fn form))
      ;; Optimize args to vanilla functions
      (when (symbolp fn)
	;; don't optimize args to macros of special forms, or to frobs 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))))

))