;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 126.64
;;; Reason:
;;;  The macroexpansion of DEFCONSTANT now puts a CONSTANT-FOR-COMPILATION
;;;  property into the compilaton-environment, and pass1 knows how to find
;;;  these properties.  Constants so defined will now be substituted into
;;;  compiled code.  This is a slight change to lambda compiler semantics.
;;; Written 22-Aug-88 18:07:24 by smh (Steve Haflich) at site Gigamos Cambridge
;;; while running on Harpo from band 3
;;; with Experimental System 126.61, ZWEI 125.19, ZMail 73.2, Local-File 75.2, File-Server 24.1, Unix-Interface 13.0, Tape 24.2, Lambda-Diag 17.0, microcode 1762, SDU Boot Tape 3.12, SDU ROM 102, kold 4aug88.



; From modified file DJ: L.SYS2; LMMAC.LISP#466 at 22-Aug-88 18:07:37
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; LMMAC  "

(DEFMACRO DEFCONSTANT (VARIABLE INITIAL-VALUE . ARGS)
  "Define a special variable which will never be changed, and the compiler may assume so.
It is set unconditionally to the value of INITIAL-VALUE.
DOCUMENTATION is available if the user asks for the documentation of the symbol VARIABLE."
  (DECLARE (ARGLIST VARIABLE INITIAL-VALUE &OPTIONAL DOCUMENTATION))
  `(PROGN (EVAL-WHEN (COMPILE)
	    (PROCLAIM '(SPECIAL ,VARIABLE))
	    ;; The following added 22aug88 by smh.  It is slightly dangerous because
	    ;; there is no official requirement that the value form be evaluable at
	    ;; compile time.  Ideally, this should be conditionalized on the fact that
	    ;; the value form evaluates without error.  On the other hand, fairly often
	    ;; if it *won't* evaluate, the user probably wants to find out about it
	    ;; because he has loaded files in the wrong order, or some such lossage.
	    (putdecl ',variable 'compiler:constant-for-compilation (list ,initial-value)))
	  (EVAL-WHEN (LOAD EVAL)
	    (DEFPROP ,VARIABLE T SYSTEM-CONSTANT))
	  (EVAL-WHEN (LOAD EVAL)
	    (DEFCONST-1 ,VARIABLE ,INITIAL-VALUE . ,ARGS))))



))

; From modified file DJ: L.SYS; QCP1.LISP#728 at 22-Aug-88 18:08:48
#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)))
			   `(quote ,(car 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))

))