;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 126.114
;;; Reason:
;;;  Fix to COMPILER:P1 for DEFCONSTANT.
;;;  
;;;  Current state of thought is that the compiler should fold in constants
;;;  defined by DEFCONSTANT when they are EQL-comparable objects.  Recent
;;;  patch to do this wasn't working.  This patch fixes bug from that patch
;;;  in handling of the 'COMPILER:CONSTANT-FOR-COMPILATION property.
;;;  
;;;  Open issue: compiling a DEFCONSTANT doesn't emit code so that after
;;;  loading, the constant symbol is once again a CONSTANT-FOR-COMPILATION.
;;;  (Got that?)  This could cause strange, confusing behaviour.  But that's
;;;  why we're here.
;;; Reason:
;;;  Test DEFCONSTANT fix.
;;; Written 18-Oct-88 18:19:30 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Tonic from band 1
;;; with Experimental System 126.113, Experimental ZWEI 126.21, 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 102, ) This space for rent (.

; From file DJ: L.SYS; QCP1.LISP#742 at 18-Oct-88 20:38:23
#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:
			   `(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))

))