;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Private patches made by keith
;;; Written 29-Oct-88 11:27:44 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Breaking Glass from band 3
;;; with Experimental ZWEI 126.27, Experimental ZMail 74.13, 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 System 128.0, Microcode 1762, SDU Boot Tape 3.14, SDU ROM 103, 10/27.



; From modified file DJ: L.SYS; QCP1.LISP#743 at 29-Oct-88 11:27:54
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCP1  "


(DEFUN P1 (FORM &OPTIONAL DONT-OPTIMIZE &AUX TEM)
  (unless (eq dont-optimize 'dont-rewrite)
    (setq form (compiler-optimize form dont-optimize)))
  (SETQ FORM (COND ((ATOM FORM)
		    (COND ((SELF-EVALUATING-P FORM)
			   `',FORM)
			  ((SETQ TEM (cl:find FORM *VARS* :key #'var-name))
			   (AND (EQ (VAR-KIND TEM) 'FEF-ARG-FREE)
				(ZEROP (VAR-USE-COUNT TEM))
				(PUSH (VAR-NAME TEM) *FREEVARS*))
			   (INCF (VAR-USE-COUNT TEM))
			   (VAR-LAP-ADDRESS TEM))
			  ((TRY-REF-SELF FORM))
			  ((and (symbolp form)		;smh 22aug88
				(setq tem (getdecl form 'compiler:constant-for-compilation))
				(consp tem)		;We expect a list of the value
				;;Type-check constant-value:  |||Keith 10oct88
				(or (numberp (setq tem (car tem)))	;EQL-equivalent objects; smh 13sep88
				    (symbolp tem)
				    (characterp tem)))
			   ;;Got valid constant value:
			   (print`(quote ,tem)))
			  ((integrable-constant? form)
			   `(QUOTE ,(eval form)))
			  ((SPECIALP FORM)
			   (MAKESPECIAL FORM) FORM)
			  ((TRY-REF-LEXICAL-VAR FORM))
			  ((and (symbolp form)
				(eq *target-computer* 'k)
				;; @#$@#$ This should be NC::REGISTER or COMPILER::REGISTER
				(get form :register))
			   form)
			  (T (MAKESPECIAL FORM) FORM)))
		   ((EQ (CAR FORM) 'QUOTE) FORM)
		   ;; Certain constructs must be checked for here
		   ;; so we can call P1 recursively without setting *TLEVEL* to NIL.
		   ((NOT (ATOM (CAR FORM)))
		    ;; Expand any lambda macros -- just returns old function if none found
		    (LET ((FCTN (CAR FORM)))
		      (OR (SYMBOLP (CAR FCTN))
			  (WARN 'BAD-FUNCTION-CALLED :IMPOSSIBLE
				"There appears to be a call to a function whose CAR is ~S."
				(CAR FCTN)))
		      (IF (MEMQ (CAR FCTN) '(LAMBDA NAMED-LAMBDA))
			  (P1LAMBDA FCTN (CDR FORM))
			;; Old Maclisp evaluated functions.
			(WARN 'EXPRESSION-AS-FUNCTION :VERY-OBSOLETE
			      "The expression ~S is used as a function; use ~S."
			      (CAR FORM) 'FUNCALL)
			(P1 `(FUNCALL . ,FORM)))))
		   ((NOT (SYMBOLP (CAR FORM)))
		    (WARN 'BAD-FUNCTION-CALLED :IMPOSSIBLE
			  "~S is used as a function to be called." (CAR FORM))
		    (P1 `(PROGN . ,(CDR FORM))))
		   ((SETQ TEM (ASSQ (CAR FORM) *LOCAL-FUNCTIONS*))
		    (INCF (VAR-USE-COUNT (CADR TEM)))
		    `(funcall ,(try-ref-lexical-home (cadr tem) `(function ,(car form)))
			      . ,(loop for x in (cdr form)
				    collect (p1 x 1))))
		   ((MEMQ (CAR FORM) '(PROG PROG*))
		    (P1PROG FORM))
		   ((MEMQ (CAR FORM) '(LET LET*))
		    (P1LET FORM))
		   ((EQ (CAR FORM) 'BLOCK)
		    (P1BLOCK FORM))
		   ((EQ (CAR FORM) 'TAGBODY)
		    (P1TAGBODY FORM))
		   ((EQ (CAR FORM) '%POP)	;P2 specially checks for this
		    FORM)
		   (T
		    (if *tlevel* (clear-tlevel))
		    ;; Check for functions with special P1 handlers.
		    (setq form (IF (SETQ TEM (or (and (neq *target-computer* 'lambda-interface)
						      (get (car form) 'p1cross))
						 (GET (CAR FORM) 'P1)))
				   (FUNCALL TEM FORM)
				   (P1ARGC FORM (GETARGDESC (CAR FORM)))))
		    (if (setq tem (get (car form) 'qintcmp))
			(let ((len (length (cdr form))))
			  (cond ((= len tem)
				 form)
				;; Have alread barfed about wrong-number-of-args
				;;  Just silently append nils or truncate
				((< len tem)
				 (append form (make-list (- tem len)
							 :initial-element ''())))
				(t
				 (subseq form 0 (1+ tem)))))
		      form)
;		    (IF (NOT (AND ALLOW-VARIABLES-IN-FUNCTION-POSITION-SWITCH
;		 	  (find (CAR FORM) *VARS* :key #'var-name)
;				  (NULL (FUNCTION-P (CAR FORM)))))
;			(P1ARGC FORM (GETARGDESC (CAR FORM)))
;		      (WARN 'EXPRESSION-AS-FUNCTION :VERY-OBSOLETE
;			    "The variable ~S is used in function position; use ~S."
;			    (CAR FORM) 'FUNCALL)
;		      (P1 `(FUNCALL . ,FORM)))
		    )))
  (IF (AND (ATOM FORM) (SELF-EVALUATING-P FORM))
      ;; a p1 handler may return :foo, for example
      `',FORM
      FORM))

))

; From modified file DJ: L.SYS; QCFILE.LISP#384 at 29-Oct-88 11:28:59
#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))
    ;;;Style checkers now being invoked on top level forms...! -Keith 10/88
    ;;;
    (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))
    ;;;$$$ Also need to run optimizers on top level forms.  Especially, now
    ;;; that DEFCONSTANTs only gets folded-in if their values are considered likely EQL-able
    ;;; by comparison to themselves... numbers, characters, etc.
    ;;;
    ;;; So, the following prevents losing advantage of a constant, by allowing optimization on
    ;;; things like (DEFCONSTANT FOO (BYTE 5. 0.)). <29-Oct-88 keith>
    ;;;
;    (setq nform
;	  (warn-on-errors ('form-optimization-error
;			   "Error while compiling (~S ~@[~S ~]...)~
;                            (optimizing) at top level"
;			   (car form) (cadr form))
;	    (compiler-optimize-external form)))
    (SETQ NFORM
	  (WARN-ON-ERRORS ('MACRO-EXPANSION-ERROR
			   "Error while compiling (~S ~@[~S ~]...)~
                            (expanding macro) at top level"
			   (CAR FORM) (cadr 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.SYS; QCOPT.LISP#190 at 29-Oct-88 11:30:35
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "


(defun fold-constants (form)
  "Replace an expression by its value...if it evaluates ok."
  (condition-case (val)
      (multiple-value-list (eval form))
    (error
     (warn 'constant-folding :error
	   "~Error during constant-folding on expression ~S:~%  ~A~" form val)
     form)
    (:no-error
     (if (= (length val) 1)
	 `',(first val)
       `(values . ,(mapcar (lambda (elt) `',elt) val))))))	; Get multiple-values

;;; This really can't do much in the Lambda compiler -- or can it ?

))

; From modified file DJ: L.SYS; QCOPT.LISP#190 at 29-Oct-88 11:31:04
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "

;;;DEFCONSTANT  <$$$ 29-Oct-88 keith>
;;;
;;;In (DEFCONSTANT X (FOO)), optimize (FOO) if possible and sensible.
;;;Sensible means it must be a likely function call.  Prevents common
;;;missed-optimization on things like (DEFCONSTANT X (BYTE 1. 0.))

;Tried calling optimizer on value.  But we don't know if it was expanded this way into code...?

;(defoptimizer optimize-defconst-value defconstant (form &aux (val (third form)))
;  (let ((check-val (and val (consp val) (symbolp (car val)) (compiler-optimize val))))
;    (and check-val (setf (third form) check-val))
;    form))

;;;This should win -- gets same value that is used to fold into code.
;;;Unfortunately, after macroexpansion of DEFCONST, DEFCONSTANT-1 is not getting optimized. @@@bug.

(defoptimizer optimize-constant-for-compilation defconst (form &aux list-of-value)
  (prog1 form
	 (typecase (setq list-of-value (getdecl (car form) 'constant-for-compilation))
	   (null)
	   (cons (setf (third form) (first list-of-value))))))

))