;;; -*- Mode:Common-Lisp; Package:Compiler; Base:10; Patch-file:T -*-

;;; Reason: Compiler update:
;;; * Fixed SLOT-VALUE optimization to handle a THE form as the object argument.
;;; * Added optimizations for COMPLEMENT and CONSTANTLY.
;;; * Warn about use of undefined SETF functions.
;;; * When (> (- SAFETY (MAX SPEED SPACE)) 1), generate run-time code to check 
;;;   bindings and assignments to make sure the value is consistent with any type 
;;;   declarations.
;;; * Use the microcoded version of &KEY argument decoding.
;;; * Other assorted minor fixes and optimizations.

;;;                           RESTRICTED RIGHTS LEGEND
;;;
;;; Use, duplication, or disclosure by the Government is subject to
;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;; Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;   TEXAS INSTRUMENTS INCORPORATED      
;;;   P.O. BOX 2909, M/S 2151             
;;;   AUSTIN, TEXAS 78769                 
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Patch file for REL6H version 6.9
;;; Written 05/05/89 17:29:10 by GRAY,
;;; while running on Kelvin from band LOD2
;;; With Experimental REL6H 6.8, Experimental SYSTEM 6.0, Experimental VIRTUAL-MEMORY 6.0,
;;;  Experimental EH 6.0, Experimental MAKE-SYSTEM 6.0, Experimental MICRONET 6.0,
;;;  Experimental LOCAL-FILE 6.0, Experimental BASIC-PATHNAME 6.0, Experimental NETWORK-SUPPORT-COLD 6.0,
;;;  Experimental BASIC-NAMESPACE 6.0, Experimental NETWORK-NAMESPACE 6.0, Experimental DISK-IO 6.0,
;;;  Experimental DISK-LABEL 6.0, Experimental BASIC-FILE 6.0, Experimental MAC-PATHNAME 6.0,
;;;  Experimental NETWORK-PATHNAME 6.0, Experimental COMPILER 6.0, Experimental TV 6.0,
;;;  Experimental DATALINK 6.0, Experimental CHAOSNET 6.0, Experimental GC 6.0, Experimental MEMORY-AUX 6.0,
;;;  Experimental NVRAM 6.0, Experimental SYSLOG 6.0, Experimental STREAMER-TAPE 6.0,
;;;  Experimental CLEH 1.0, Experimental UCL 6.0, Experimental INPUT-EDITOR 6.0, Experimental METER 6.0,
;;;  Experimental ZWEI 6.0, Experimental DEBUG-TOOLS 6.0, Experimental NETWORK-SUPPORT 6.0,
;;;  Experimental NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0, Experimental FONT-EDITOR 6.0,
;;;  Experimental SERIAL 6.0, Experimental PRINTER 6.0, Experimental MAC-PRINTER-TYPES 6.0,
;;;  Experimental PRINTER-TYPES 6.0, Experimental IMAGEN 6.0, Experimental SUGGESTIONS 6.0,
;;;  Experimental MAIL-DAEMON 6.0, Experimental MAIL-READER 6.0, Experimental TELNET 6.0,
;;;  Experimental VT100 6.0, Experimental NAMESPACE-EDITOR 6.0, Experimental PROFILE 6.0,
;;;  VISIDOC 6.0, Inconsistent TI-CLOS 17.3, Experimental CLX 5.0, Experimental CLUE 20.0,
;;;  Experimental X11M 3.0, Experimental RPC 6.0, Experimental NFS 6.0, Experimental BUG 11.4,
;;;  IP 3.45, Experimental DOCUMENTER 618.0,  microcode 426, Band Name: Rel6H,Scribe,
;;; &c, u426 5/4

(export '(compiler:get-from-frame-list) :system)


#!C
; From file DEFS.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; DEFS.#"


(DEFSUBST VAR-DECLARED-TYPE (VAR)
  ;; The declared type as it appeared in the source code before canonicalization.
  ;;  4/29/89 DNG - Original.
  (OR (GETF (VAR-DECLARATIONS VAR) 'DECLARED-TYPE)
      (VAR-DATA-TYPE VAR)))
))


#!C
; From file P1HAND.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1HAND.#"


(EVAL-WHEN ( EVAL LOAD )
  (DOLIST ( F '( ; ; ;
		;; the following added 4/27/89 by DNG
		SYS:%INSTANCE-REF TICLOS:FLAVOR-INSTANCE-ACCESS TICLOS:STANDARD-INSTANCE-ACCESS
		))
    (SETF (GET F 'P1) 'P1ACCESSOR)))
))

#!C
; From file TYPEOPT.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; TYPEOPT.#"


(DEFUN EXPR-TYPE-P ( ORIGINAL-FORM TYPE )
  "Test whether a Lisp form [after P1] always produces a value of the indicated type."
  ;; When the second argument is a type specifier, return true if the value of
  ;;   FORM is known to always be of type TYPE.
  ;; When the second argument is RETURN-THE-TYPE, return a type specifier for
  ;;   the type of FORM, or T if no type information is available.  This should only
  ;;   be used by the macro TYPE-OF-EXPRESSION.
  ;; Note: the type NIL indicates a form that does not return [for example, GO].
  ;;
  ;;  4/21/86 - Original for release 3.
  ;;  4/28/86 - Add special handling for DEFCONSTANT symbols.
  ;;  5/08/86 - Add special handling for COND form.
  ;;  5/10/86 - Add special handling for PROGN, PROG1, etc.
  ;;  6/30/86 - Re-designed, combining EXPR-TYPE-P and TYPE-OF-EXPRESSION.
  ;;  8/09/86 - Replaced use of UNKNOWN with T [except in THE-EXPR].
  ;;  8/26/86 - Get type of BREAKOFF-FUNCTION from COMPILAND-PLIST.
  ;;  8/29/86 - Use array element type.
  ;; 10/11/86 - For a local variable which is not altered, can get type from initial value.
  ;; 11/05/87 - Check (SI:TYPE-SPECIFIER-P FORM-TYPE) before doing (TYPEP 'NIL FORM-TYPE). [SPR 6875]
  ;;  2/24/88 - If OPT-SAFETY is 3, do not allow optimizations. [SPR 7312]
  ;;  2/17/89 - Add recognition of MAKE-INSTANCE.
  ;;  4/10/89 - Use new function VAR-INIT-FORM .
  ;;  4/17/89 - Recognize that (FORMAT NIL ...) returns a string.
  ;;  4/25/89 - Add handling for %STANDARD-INSTANCE-REF and STANDARD-INSTANCE-ACCESS.
  ;;  4/26/89 - Add handling for %LET and %LET*.
  ;;  4/28/89 - Add use of *LOOP-VAR-BIT* to criteria for using the initial 
  ;;		value of a local variable.  Add special handling for SELF in a flavor 
  ;;		method.
  ;;  5/02/89 - Add handling for calls to SETF and LOCF functions.
  (DECLARE (ARGLIST FORM TYPE))
  (LET ( (FORM ORIGINAL-FORM) FORM-TYPE FORM-VALUE (THE-EXPR-FORM NIL) )
    (TAGBODY
	
	(WHEN (NULL FORM) ; if run past end of argument list then match fails.
	  #+compiler:debug
	  (assert (not (EQL TYPE RETURN-THE-TYPE)))
	  (RETURN-FROM EXPR-TYPE-P NIL) )
	(WHEN (EQ TYPE 'T)		   ; T matches anything
	  (RETURN-FROM EXPR-TYPE-P T) )
	
     START-OVER-WITH-NEW-FORM
	
	(IF (ATOM FORM)
	    (COND ((AND (SYMBOLP FORM)
			(GET-FOR-TARGET FORM 'SYSTEM-CONSTANT)
			(BOUNDP-FOR-TARGET FORM))
		   ;; Check value of DEFCONSTANT
		   (SETQ FORM-VALUE (SYMEVAL-FOR-TARGET FORM))
		   (GO VALUE-KNOWN) )
		  ((OR (= (OPT-SAFETY OPTIMIZE-SWITCH) 3)
		       (> (OPT-SAFETY OPTIMIZE-SWITCH)
			  (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)))
		   ;; Don't rely on user's declarations.
		   (GO NOTHING-KNOWN))
		  ((EQ FORM 'SELF)
		   (IF (AND SELF-FLAVOR-DECLARATION ; in a flavor method
			    (NULL (LOOKUP-VAR FORM))) ; a free reference
		       (PROGN (SETQ FORM-TYPE (CAR SELF-FLAVOR-DECLARATION))
			      (GO TYPE-KNOWN))
		     (GO NOTHING-KNOWN)))
		  ;; Else fetch the variable's type declaration.
		  ((SYMBOLP FORM)
		   (SETQ FORM-TYPE
			 (IF (OR UNDO-DECLARATIONS-FLAG LOCAL-DECLARATIONS)
			     (GETDECL FORM 'VARIABLE-TYPE 'T)
			   (GET-FOR-TARGET FORM 'VARIABLE-TYPE 'T)))
		   (GO TYPE-KNOWN))
		  (T (BARF FORM 'TYPE-OF-EXPRESSION 'BARF)))
	  (CASE (FIRST FORM)
		( QUOTE
		 (SETQ FORM-VALUE (SECOND FORM))
		 (GO VALUE-KNOWN) )
		( LOCAL-REF		   ; local variable
		 (IF (OR (= (OPT-SAFETY OPTIMIZE-SWITCH) 3)
			 (> (OPT-SAFETY OPTIMIZE-SWITCH)
			    (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)))
		     ;; Don't rely on user's declarations.
		     (GO NOTHING-KNOWN)
		   ;; Else fetch the variable's type declaration.
		   (LET ((V (SECOND FORM)))
		     (SETQ FORM-TYPE (VAR-DATA-TYPE V))
		     (WHEN (AND (EQ FORM-TYPE 'T)
				(MEMBER (VAR-INIT-KIND V) '(FEF-INI-COMP-C FEF-INI-SETQ)) ; not an argument
				;; If there is no possibility that the value has been altered,
				;; we can use the type of the initial value expression.
				(OR (MEMBER 'FEF-ARG-NOT-ALTERED (VAR-MISC V))
				    (AND (>= (CDDR FORM) *LOOP-VAR-BIT*) ; not in a loop
					 (MEMBER (VAR-USE-COUNT V) '(NIL 0))) ; no assignment yet
				    (EQ (VAR-NAME V) '.VALUE.) ; used in type checking code
				    ))
		       (SETQ FORM (VAR-INIT-FORM V))
		       (GO START-OVER-WITH-NEW-FORM))
		     (GO TYPE-KNOWN))))
		( VALUES
		 (RETURN-FROM EXPR-TYPE-P
		   (COND ((AND (CONSP TYPE)
			       (EQ (FIRST TYPE) 'VALUES))
			  (EVERY #'EXPR-TYPE-P (REST FORM) (REST TYPE)))
			 ((AND (CDR FORM) (NULL (CDDR FORM)))
			  (SETQ FORM (SECOND FORM))
			  (GO START-OVER-WITH-NEW-FORM))
			 ((EQL TYPE RETURN-THE-TYPE)
			  (CONS 'VALUES
				(MAPCAR #'TYPE-OF-EXPRESSION (REST FORM)) ))
			 (T NIL))))
		( SETQ
		 (DO ((ARGS (REST FORM) (CDDR ARGS)))
		     ((NULL (CDDR ARGS))
		      (RETURN-FROM EXPR-TYPE-P
			(IF (EQL TYPE RETURN-THE-TYPE)
			    (LET (( EXP-TYPE (TYPE-OF-EXPRESSION (SECOND ARGS)) ))
			      (IF (EQ EXP-TYPE 'T)
				  (PROGN (SETQ FORM (FIRST ARGS))
					 (GO START-OVER-WITH-NEW-FORM))
				EXP-TYPE ))
			  (OR (EXPR-TYPE-P (SECOND ARGS) TYPE)
			      (EXPR-TYPE-P (FIRST ARGS) TYPE)))))
		   ))
		(( PROGN PROGN-WITH-DECLARATIONS LET LET* LET-FOR-LAMBDA %LET %LET*)
		 ;; use type of last argument
		 (SETQ FORM (CAR (LAST (CDR FORM))))
		 (GO START-OVER-WITH-NEW-FORM))
		(( PROG1 SUBSEQ COPY-SEQ REVERSE NREVERSE REMOVE-DUPLICATES DELETE-DUPLICATES )
		 ;; use type of first argument
		 (SETQ FORM (SECOND FORM))
		 (GO START-OVER-WITH-NEW-FORM))
		( COND
		 (LET (( LAST-TEST NIL ))
		   (IF (EQL TYPE RETURN-THE-TYPE)
		       (PROGN
			 (DOLIST ( CLAUSE (REST FORM) )
			   (LET (( EXP-TYPE (TYPE-OF-EXPRESSION (FIRST (LAST CLAUSE))) ))
			     (COND ((EQ EXP-TYPE 'T)
				    (SETQ FORM-TYPE EXP-TYPE)
				    (GO TYPE-KNOWN))
				   ((NULL FORM-TYPE)
				    (SETQ FORM-TYPE EXP-TYPE))
				   ((EQUAL FORM-TYPE EXP-TYPE))
				   ((SUBTYPEP EXP-TYPE FORM-TYPE *COMPILE-FILE-ENVIRONMENT*))
				   ((SUBTYPEP FORM-TYPE EXP-TYPE *COMPILE-FILE-ENVIRONMENT*)
				    (SETQ FORM-TYPE EXP-TYPE))
				   ((EQ (CAR-SAFE FORM-TYPE) 'OR)
				    (SETQ FORM-TYPE `(OR ,EXP-TYPE . ,(REST FORM-TYPE))))
				   (T (SETQ FORM-TYPE `(OR ,EXP-TYPE ,FORM-TYPE))) ))
			   (SETQ LAST-TEST (FIRST CLAUSE)) )
			 (UNLESS (OR (ALWAYS-TRUE LAST-TEST)
				     (AND (TYPE-SPECIFIER-P FORM-TYPE *COMPILE-FILE-ENVIRONMENT*)
					  ;; FORM-TYPE acceptable to TYPEP [could be (VALUES ...) or (FUNCTION ...)]
					  (TYPEP 'NIL FORM-TYPE)))
			   (SETQ FORM-TYPE `(OR NULL ,FORM-TYPE)))
			 (GO TYPE-KNOWN) )
		     (PROGN
		       (DOLIST ( CLAUSE (REST FORM) )
			 (UNLESS (EXPR-TYPE-P (FIRST (LAST CLAUSE)) TYPE)
			   (RETURN-FROM EXPR-TYPE-P NIL))
			 (SETQ LAST-TEST (FIRST CLAUSE)) )
		       (RETURN-FROM EXPR-TYPE-P
			 (IF (ALWAYS-TRUE LAST-TEST)
			     T
			   (TYPEP 'NIL TYPE) ))))))
		( THE-EXPR
		 (LET (( EXP-TYPE (EXPR-TYPE FORM) ))
		   (IF (EQ EXP-TYPE 'UNKNOWN)
		       (PROGN (SETQ THE-EXPR-FORM FORM)
			      (SETQ FORM (EXPR-FORM FORM))
			      (GO START-OVER-WITH-NEW-FORM))
		     (PROGN (SETQ FORM-TYPE EXP-TYPE)
			    (GO TYPE-KNOWN)))))
		(( FUNCALL APPLY LEXPR-FUNCALL REDUCE )
		 (LET (( FN (SECOND FORM) ))	   ; function to be called
		   (IF (AND (CONSP FN)
			    (OR (EQ (FIRST FN) 'FUNCTION)
				(EQ (FIRST FN) 'QUOTE)))
		       (IF (SYMBOLP (SECOND FN))
			   (PROGN
			     (SETQ FORM-TYPE
				   (GETDECL (SECOND FN) 'FUNCTION-RESULT-TYPE 'T))
			     (GO TYPE-KNOWN))
			 (CASE (CAR-SAFE (SECOND FN))
			   ( SETF (SETQ FORM (THIRD FORM))
				  (GO START-OVER-WITH-NEW-FORM))
			   ( LOCF (SETQ FORM-TYPE 'LOCATIVE)
				  (GO TYPE-KNOWN))
			   (OTHERWISE (GO NOTHING-KNOWN))))
		     (LET (( FT (TYPE-OF-EXPRESSION FN) ))
		       (IF (AND (CONSP FT)
				(EQ (FIRST FT) 'FUNCTION)
				(CDDR FT))
			   (PROGN (SETQ FORM-TYPE (THIRD FT))
				  (GO TYPE-KNOWN))
			 (GO NOTHING-KNOWN) )))))
		( COERCE
		 (IF (QUOTEP (THIRD FORM))
		     (PROGN (SETQ FORM-TYPE (SECOND (THIRD FORM)))
			    (GO TYPE-KNOWN))
		   (GO NOTHING-KNOWN) ))
		(( CONCATENATE MAKE-SEQUENCE MAP )
		 (SETQ FORM-TYPE (IF (QUOTEP (SECOND FORM))
				     (OR (SECOND (SECOND FORM)) 'NULL) ; (MAP 'NIL ...)=>NIL
				   'SEQUENCE))
		 (GO TYPE-KNOWN))
		(( REMOVE DELETE REMOVE-IF REMOVE-IF-NOT DELETE-IF DELETE-IF-NOT )
		 ;; result has same type as second argument
		 (SETQ FORM (THIRD FORM))
		 (GO START-OVER-WITH-NEW-FORM) )
		( BREAKOFF-FUNCTION
		 ;; get type saved by REF-LOCAL-FUNCTION-VAR 
		 (SETQ FORM-TYPE
		       (GETF (COMPILAND-PLIST (SECOND FORM)) 'TYPE 'FUNCTION))
		 (GO TYPE-KNOWN))
		(( COMMON-LISP-AR-1 COMMON-LISP-AR-2 COMMON-LISP-AR-3 AREF GLOBAL:AR-1 AR-2 )
		 (LET ((ARRAY-TYPE (TYPE-OF-EXPRESSION (SECOND FORM))))
		  (COND ((AND (CONSP ARRAY-TYPE)
			      (MEMBER (FIRST ARRAY-TYPE) '(ARRAY VECTOR SIMPLE-ARRAY))
			      (NOT (MEMBER (SECOND ARRAY-TYPE) '(T * NIL))))
			 (SETQ FORM-TYPE (SECOND ARRAY-TYPE))
			 (GO TYPE-KNOWN))
			((EQ ARRAY-TYPE 'STRING)
			 (SETQ FORM-TYPE (IF (EQ (FIRST FORM) 'GLOBAL:AR-1)
					     'FIXNUM
					   'CHARACTER))
			 (GO TYPE-KNOWN))
			(T (GO NOTHING-KNOWN)))))
		( MAKE-INSTANCE
		 (SETQ FORM-TYPE (IF (QUOTEP (SECOND FORM))
				     (SECOND (SECOND FORM))
				   '(NOT NULL)))
		 (GO TYPE-KNOWN))
		( %STANDARD-INSTANCE-REF
		 ;; (%STANDARD-INSTANCE-REF object mapping-table class-name slot-name)
		 (LET* ((CLASS (TICLOS:CLASS-NAMED (FOURTH FORM) T *COMPILE-FILE-ENVIRONMENT*))
			(SD (AND CLASS (FIND (FIFTH FORM) (IF (TICLOS:CLASS-FINALIZED-P CLASS)
							      (TICLOS:CLASS-SLOTS CLASS)
							    (TICLOS:CLASS-DIRECT-SLOTS CLASS))
					     :KEY #'TICLOS:SLOT-DEFINITION-NAME :TEST #'EQ))))
		   (IF (NULL SD)
		       (GO NOTHING-KNOWN)
		     (PROGN (SETQ FORM-TYPE (TICLOS:SLOT-DEFINITION-TYPE SD))
			    (GO TYPE-KNOWN)))))
		( TICLOS:STANDARD-INSTANCE-ACCESS 
		 ;; (STANDARD-INSTANCE-ACCESS object slot-name)
		 (IF (QUOTEP (THIRD FORM))
		     (LET ((TYPE (TYPE-OF-EXPRESSION (SECOND FORM))))
		       (IF (EQ TYPE 'T)
			   (GO NOTHING-KNOWN)
			 (LET* ((CLASS (TICLOS:CLASS-NAMED TYPE T *COMPILE-FILE-ENVIRONMENT*))
				(SD (AND CLASS (FIND (SECOND (THIRD FORM))
						     (IF (TICLOS:CLASS-FINALIZED-P CLASS)
							 (TICLOS:CLASS-SLOTS CLASS)
						       (TICLOS:CLASS-DIRECT-SLOTS CLASS))
						     :KEY #'TICLOS:SLOT-DEFINITION-NAME :TEST #'EQ))))
			   (IF (NULL SD)
			       (GO NOTHING-KNOWN)
			     (PROGN (SETQ FORM-TYPE (TICLOS:SLOT-DEFINITION-TYPE SD))
				    (GO TYPE-KNOWN))))))
		   (GO NOTHING-KNOWN)))
		( THE
		 (SETQ FORM-TYPE (SECOND FORM))
		 (GO TYPE-KNOWN))
		( FORMAT
		 (IF (EQUAL (SECOND FORM) '(QUOTE NIL))
		     (PROGN (SETQ FORM-TYPE 'STRING) (GO TYPE-KNOWN))
		   (GO NOTHING-KNOWN)))
		(OTHERWISE
		 (SETQ FORM-TYPE
		       (IF (OR (EQ UNDO-DECLARATIONS-FLAG 'FUNCTION-RESULT-TYPE)
			       LOCAL-DECLARATIONS)
			   (GETDECL (FIRST FORM) 'FUNCTION-RESULT-TYPE 'T)
			 (GET-FOR-TARGET (FIRST FORM) 'FUNCTION-RESULT-TYPE 'T)))
		 (GO TYPE-KNOWN))
		))
	
     TYPE-KNOWN
	(WHEN THE-EXPR-FORM
	  ;; Record what we learned so we won't have to traverse that tree again.
	  (SETF (EXPR-TYPE THE-EXPR-FORM) FORM-TYPE))
	(RETURN-FROM EXPR-TYPE-P
	  (COND ((EQL TYPE RETURN-THE-TYPE)
		 FORM-TYPE)
		;; To save time, try to handle the simple cases here without calling SUBTYPE.
		((EQ FORM-TYPE 'T) NIL)
		((EQ FORM-TYPE 'NIL) T)
		((EQUAL FORM-TYPE TYPE) T)
		((AND (CONSP FORM-TYPE)
		      (EQ (FIRST FORM-TYPE) TYPE))
		 T)
		;; SUBTYPEP doesn't handle VALUES type specifiers
		((EQ (CAR-SAFE FORM-TYPE) 'VALUES)
		 (COND ((EQ (CAR-SAFE TYPE) 'VALUES)
			(EVERY #'SUBTYPEP (REST FORM-TYPE) (REST TYPE)))
		       ((NULL (REST FORM-TYPE)) NIL)
		       (T (SUBTYPEP (SECOND FORM-TYPE) TYPE *COMPILE-FILE-ENVIRONMENT*))))
		;; Not obvious; have to do it the hard way.
		(T (SUBTYPEP FORM-TYPE TYPE *COMPILE-FILE-ENVIRONMENT*) )))
	
     NOTHING-KNOWN
        (RETURN-FROM EXPR-TYPE-P
	  (IF (EQL TYPE RETURN-THE-TYPE)
	      'T
	    NIL))			   ; match fails
	
     VALUE-KNOWN
	(RETURN-FROM EXPR-TYPE-P
          (IF (EQL TYPE RETURN-THE-TYPE)
	      (IF (NULL FORM-VALUE)
		  'NULL
		(TYPE-OF FORM-VALUE))
	    (TYPEP FORM-VALUE TYPE) ))
	)))

))

#!C
; From file P1OPT.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1OPT.#"


(DEFUN %LET-OPT (FORM &OPTIONAL DELETE-ALL)
 ;; 1/25/85 DNG - Call DISCARD on initial value of deleted variable.
 ;; 2/27/85 DNG - Fix for duplicated variable names.
 ;; 3/04/85 DNG - Move check for special variables referenced by the
 ;;               microcode from here to VARS-USED.
 ;; 1/09/86 DNG - Fix handling of doubly-defined variables. [SPR 1518]
 ;; 1/20/86 DNG - Another fix for handling of doubly-defined variables.
 ;; 9/16/86 DNG - Permit deleting variable initialized to (UNDEFINED-VALUE).
 ;; 9/25/86 DNG - Optimize out some variables which are used only once.
 ;;10/02/86 DNG - Don't call DISCARD on a value deleted by PROPAGATE-VALUES.
 ;;10/14/86 DNG - Optimize binding of *STANDARD-OUTPUT* around print functions.
 ;;10/18/86 DNG - Handle more cases of variables used once.
 ;;10/21/86 DNG - Fix for variable used once that depends on special variable bindings.
 ;; 7/02/87 DNG - When substituting the initial value of a variable into its
 ;;		only use in the first body form, check first that it is independent
 ;;		of the value forms of any following bindings.  [SPR 5926]
 ;; 4/25/89 DNG - Fix initial value form to match the VAR-INIT-FORM when 
 ;;		SETQ-OPT has changed the latter.
 ;; 4/26/89 DNG - Original version of %LET-OPT adapted from LET-OPT.
 ;; 4/27/89 DNG - Fix *STANDARD-OUTPUT* optimization (wasn't optimizing when 
 ;;		value of FORMAT was used).
 ;; 4/28/89 DNG - Before trying to propagate the initial value of a variable, 
 ;;		make sure that the value expression is independent of the value forms of 
 ;;		any following bindings. [SPR 9631]
 ;; 5/05/89 DNG - Don't optimize (LET ((a x)) a) ==> x if x is a LABELS functions that closes over a.
  (UNLESS PROPAGATE-ENABLE
    (RETURN-FROM %LET-OPT FORM))
 (DESTRUCTURING-BIND ((BOUNDVARS VARS OLD-VARS BINDP CLOSUREP) &REST BODY) (REST FORM)
    (DECLARE (UNSPECIAL BINDP) (IGNORE CLOSUREP))
  (LET (BLIST
	(CHANGED NIL)
	V USED INIT-FORM
	(NEW-PROPAGATE 0))
    (FLET ((USES-SPECIAL-BINDINGS-P (V OLD-VARS)
	     ;; Does the initial value of this variable use any special variables
	     ;; which are bound in this same LET?
	     (VARS-USED (VAR-INIT-FORM V)
			(LET ((SPECIALS NIL))
			  (DO ((VS VARS (CDR VS)))
			      ((EQ VS OLD-VARS))
			    (WHEN (EQ (VAR-TYPE (CAR VS)) 'FEF-SPECIAL)
			      (PUSH (VAR-LAP-ADDRESS (CAR VS))
				    SPECIALS)))
			  SPECIALS)) ))
    ;; delete unused variables from the lambda list
    (SETQ BLIST
      (LOOP
	FOR BLIST-TAIL ON BOUNDVARS
	FOR V = (FIRST BLIST-TAIL) ; each variable in lambda list
	DO (DEBUG-ASSERT (MEMBER V VARS :TEST #'EQ))
	IF (OR (AND (OR (NULL (SETQ USED (VAR-USE-COUNT V)))   ; never referenced
			(ZEROP USED)	   ; value never used
			DELETE-ALL)	   ; called from DISCARD to throw all away
		    (MEMBER (VAR-KIND V)
			    '(FEF-ARG-INTERNAL-AUX FEF-ARG-FREE FEF-ARG-DELETED)
			    :TEST #'EQ)
		    (OR (PROGN (SETQ INIT-FORM (VAR-INIT-FORM V))
			        (EQ (VAR-TYPE V) 'FEF-LOCAL))
			DELETE-ALL
			(AND (OR (NEQ (FIRST FORM) '%LET*)
				 (NULL (REST BLIST-TAIL)))
			     (OR (NULL BODY)
				 (AND (OR (NULL (REST BODY))
					  (AND (QUOTEP (SECOND BODY))
					       (NULL (CDDR BODY))))
				      (OR 
					;; Check for references in the body form.
					(AND (< (OPT-SAFETY OPTIMIZE-SWITCH)
						(OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))
					     (NULL (VARS-USED (FIRST BODY)
							      (LIST (VAR-LAP-ADDRESS V)))))
					;; Can binding be replaced by an optional argument?
					(AND (EQ (VAR-NAME V) '*STANDARD-OUTPUT*)
					     (MEMBER (CAR-SAFE (FIRST BODY))
						     '( PRIN1 PRINT PPRINT PRINC
						       WRITE-CHAR WRITE-STRING WRITE-LINE
						       WRITE-BYTE))
					     (= (LENGTH (FIRST BODY)) 2)
					     (NOT (NULL INIT-FORM))
					     (INDEPENDENT-EXPRESSIONS-P
					       (SECOND (FIRST BODY)) INIT-FORM)
					     (PROGN
					       ;; (LET ((*STANDARD-OUTPUT* x)) (PRINT a)) ==> (PRINT a x)
					       ;; [such forms are created by the FORMAT optimizer]
					       (SETF (CDDR (FIRST BODY))
						     (LIST INIT-FORM))
					       (SETF INIT-FORM NIL)
					       T))
					)))))
		    (OR (NULL INIT-FORM)
			DELETE-ALL
			(NO-SIDE-EFFECTS-P INIT-FORM)))
	       (AND (EQL USED 1)
		    (MEMBER 'FEF-ARG-NOT-ALTERED (VAR-MISC V))
		    (<= (OPT-SAFETY OPTIMIZE-SWITCH)
			(OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))
		    (NULL (REST BODY))
		    (CONSP (FIRST BODY))
		    (NOT (QUOTES-ANY-ARGS (FIRST (FIRST BODY))))
		    (MEMBER (VAR-LAP-ADDRESS V) (FIRST BODY) :TEST #'EQ)
		    (NOT (USES-SPECIAL-BINDINGS-P V OLD-VARS))
		    (OR (NULL (SETQ INIT-FORM (VAR-INIT-FORM V)))
			 (DOLIST (X (REST BLIST-TAIL) T)
			   (UNLESS (INDEPENDENT-EXPRESSIONS-P INIT-FORM (OR (VAR-INIT-FORM X) ''NIL))
			     (RETURN NIL))))
		    (DO ((ARGS (REST (FIRST BODY)) (REST ARGS)))
			((NULL ARGS) NIL)
		      (COND ((EQ (FIRST ARGS) (VAR-LAP-ADDRESS V))
			     ;; (LET ((x (foo a))) (bar x)) ==> (bar (foo a))
			     (SETF (FIRST ARGS) (OR INIT-FORM ''NIL))
			     (SETF INIT-FORM NIL)
			     (RETURN T))
			    ((NULL INIT-FORM))
			    ((INDEPENDENT-EXPRESSIONS-P INIT-FORM (FIRST ARGS)))
			    (T (RETURN NIL))))
	       ))			   ; variable can be deleted
	DO (PROGN ;; Now mark the variable deleted.
		  (SETF (VAR-KIND V) 'FEF-ARG-DELETED)
		  (UNLESS (OR (NULL INIT-FORM)
			      (EQ INIT-FORM 'DELETED-VALUE)
			      (NOT (EQ (VAR-INIT-KIND V) 'FEF-INI-COMP-C)))
		    (DISCARD INIT-FORM))
		  (SETQ CHANGED T))
	ELSE COLLECT
	(PROGN
	  (WHEN (AND (EQL USED 1)
		     (MEMBER 'FEF-ARG-NOT-ALTERED (VAR-MISC V))
		     (<= (OPT-SAFETY OPTIMIZE-SWITCH)
			 (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))
		     (OR ;;(ZEROP ALTERED-VAR-SET) ; include this when have time to debug it.
		       (LET ((INIT (VAR-INIT-FORM V)))
			 (OR (NULL INIT)
			     (INVULNERABLE-EXPRESSION-P INIT)
			     (DOLIST (X (REST BLIST-TAIL)
					(INDEPENDENT-EXPRESSIONS-P INIT (CONS 'VALUES BODY)))
			       (WHEN (AND (EQ (VAR-INIT-KIND X) 'FEF-INI-COMP-C)
					  (NOT (INDEPENDENT-EXPRESSIONS-P INIT (VAR-INIT-FORM X))))
				 (RETURN NIL))))))
		     (NOT (USES-SPECIAL-BINDINGS-P V OLD-VARS)))
	    ;; Local variable used exactly once; try to replace the
	    ;; reference with the initial value expression.
	    (SETQ NEW-PROPAGATE
		  (LOGIOR NEW-PROPAGATE (CDDR (VAR-LAP-ADDRESS V)))))
	  V))))
    (IF (AND (NULL BLIST) ; empty lambda list
	     (NOT BINDP)	   ;  no BIND
	     )
      (CONS 'PROGN BODY)	; (LET () body) ==> (PROGN body)
      (PROGN
	(WHEN CHANGED; some variables deleted
	 ;; change the form instead of creating a new list so that
	 ;;  POST-OPTIMIZE won't waste time calling %LET-OPT again.
	  (SETF (FIRST (SECOND FORM)) BLIST))
	(IF (AND (NULL (REST BLIST))
		 (NULL (REST BODY))
		 (EQ (VAR-LAP-ADDRESS (SETQ V (FIRST BLIST)))
		     (FIRST BODY))
		 (NOT BINDP)	   ; no BIND
		 ;; This next check is because LABELS constructs a LET where the initial 
		 ;; value can reference the variable being bound.
		 (NOT (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC V) :TEST #'EQ))
		 )
	    ;;  (let ((a x)) a) ==> x
	    (PROGN (SETF (VAR-KIND V) 'FEF-ARG-DELETED)
		   (OR (VAR-INIT-FORM V) ''NIL))
	  (IF (NOT (ZEROP (LOGDIF NEW-PROPAGATE PROPAGATE-VAR-SET)))
	      (LET* ((PROPAGATE-VAR-SET NEW-PROPAGATE)
		     (DONT-PROPAGATE-INTO-LOOP NEW-PROPAGATE)
		     (NEW-FORM (PROPAGATE-VALUES FORM)))
		(IF (EQ NEW-FORM FORM)
		    (%LET-OPT FORM) ; remove variables whose use counts have now become 0
		  NEW-FORM))
	    FORM)))))))

))

#!C
; From file COMPILE.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; COMPILE.#"


(DEFUN BREAKOFF (LAMBDA-EXPRESSION EPHEMERAL)
  ;; 07/09/85 DNG - Modify choice of FNAME-TO-GIVE.
  ;; 07/12/85 DNG - Update LOCAL-FUNCTION-MAP.
  ;; 12/11/85 DNG - Use function name instead of offset number in
  ;;		    :INTERNAL function specs.
  ;; 12/23/85 DNG - Increment use count for variables holding local functions.
  ;;  2/01/86 DNG - New queue slot VISIBLE-VARS. [for SPR 958 and 1073]
  ;;  2/21/86 DNG - Add support for MAKE-EPHEMERAL-LEXICAL-CLOSURE;
  ;;		no longer disable Tail Recursion Elimination.
  ;;  4/28/86 DNG - Cold load warning no longer needed for VM2.
  ;;  5/01/86 DNG - Make sure PROGDESC-USED-IN-LEXICAL-CLOSURES-FLAG does not
  ;;		point to a function spec in the temporary area since it is used
  ;;		as a CATCH tag and hence becomes a constant in the FEF.
  ;;  6/09/86 DNG - Cons the name in background-cons-area when compiling in memory.
  ;;  6/21/86 DNG - Change to use *LOCAL-ENVIRONMENT* instead of LOCAL-MACROS.
  ;;  7/12/86 DNG - Major re-design to use recursive invocation of pass 1
  ;;		instead of CW-TOP-LEVEL-LAMBDA-EXPRESSION.
  ;;  8/12/86 DNG - Reset ephemeral flag for closures used by a non-ephemeral closure.
  ;;  9/25/86 DNG - Added call to OBJECT-OPERATION-WITH-WARNINGS .
  ;; 10/18/86 DNG - Adjustments for use by EXTEND-LOCAL-VARIABLES .
  ;; 11/24/86 DNG - Add warning for a DEFSUBST that is a lexical closure; fix
  ;;		handling of a macro expander that is a lexical closure.
  ;; 12/22/86 DNG - More adjustments for use by EXTEND-LOCAL-VARIABLES .
  ;;  2/16/87 DNG - Set COMPILAND-INITIAL-ENVIRONMENT-VARS .
  ;;  3/17/87 DNG - Fix so lexical closure is not ephemeral if it has any
  ;;		children that are non-ephemeral lexical closures.
  ;;  7/31/87 DNG - Fix to preserve non-symbol function name. [SPR 6128]
  ;;  9/23/87 DNG - Use new function NOT-EPHEMERAL.
  ;; 11/11/87 DNG - Add FEF-ARG-ALTERED-IN-LEXICAL-CLOSURES flag to VAR-MISC to fix SPR 6881.
  ;;  9/19/88 DNG - Add binding of *OVERLAP-CANDIDATES* to fix SPR 8756.
  ;; 11/11/88 DNG - Fix for a NAMED-LAMBDA with a name of NIL.
  ;; 11/15/88 DNG - Don't push a non-symbol name on COMPILAND-LOCAL-FUNCTION-MAP.
  ;; 11/17/88 DNG - Don't use lambda name that is a gensym.
  ;;  4/27/89 DNG - Add binding of *LOOP-VAR-BIT*.
  ;;  4/29/89 DNG - Move the binding of *LOOP-VAR-BIT* to include the call to UPDATE-PROPAGATE-VAR-SET.
  (WHEN INLINE-EXPANSIONS ; kick back to function PROCEDURE-INTEGRATION
    (THROW (SECOND (FIRST INLINE-EXPANSIONS)) 'BREAKOFF) )
  (LET* ((LEXICAL NIL)
	 FNAME  FNAME-TO-GIVE  CHILD
	 (PARENT *CURRENT-COMPILAND*)
	 (FUNCTION-TO-BE-DEFINED (COMPILAND-FUNCTION-SPEC PARENT))
	 (NAME-TO-GIVE-FUNCTION  (COMPILAND-FUNCTION-NAME PARENT)))
    (DECLARE (UNSPECIAL FUNCTION-TO-BE-DEFINED NAME-TO-GIVE-FUNCTION))
    (MULTIPLE-VALUE-BIND ( LAMBDA-NAME NAMEDP )
	(FUNCTION-NAME LAMBDA-EXPRESSION)
      (LET ((LAMBDA-ID
	     (IF (AND NAMEDP
		      (SYMBOLP LAMBDA-NAME)
		      (NOT (NULL LAMBDA-NAME))
		      (NOT (NULL (SYMBOL-PACKAGE LAMBDA-NAME)))
		      (NOT (MEMBER LAMBDA-NAME
				   (COMPILAND-LOCAL-FUNCTION-MAP PARENT)
				   :TEST #'EQ)))
		 ;; When the function has a unique name, use it.
		 LAMBDA-NAME
	       ;; Else, identify it with a number.
	       (LENGTH (COMPILAND-CHILDREN PARENT))) )
	    ( DEFAULT-CONS-AREA (IF (AND QC-FILE-IN-PROGRESS
					 (NOT QC-FILE-LOAD-FLAG))
				    DEFAULT-CONS-AREA
				  BACKGROUND-CONS-AREA) ))
	(SETQ FNAME-TO-GIVE `(:INTERNAL ,NAME-TO-GIVE-FUNCTION ,LAMBDA-ID)
	      FNAME (IF (EQUAL FUNCTION-TO-BE-DEFINED NAME-TO-GIVE-FUNCTION)
			FNAME-TO-GIVE
		      `(:INTERNAL ,FUNCTION-TO-BE-DEFINED ,LAMBDA-ID)))
	(WHEN (AND (EQ FUNCTION-TO-BE-DEFINED NIL)
		   NAMEDP
		   (OR (EQ LAMBDA-ID LAMBDA-NAME)
		       (NOT (SYMBOLP LAMBDA-NAME))))
	  (SETQ FNAME-TO-GIVE LAMBDA-NAME) ))
      (SETF CHILD (MAKE-COMPILAND
		  :FUNCTION-SPEC	FNAME
		  :FUNCTION-NAME	FNAME-TO-GIVE
		  :DEFINITION		LAMBDA-EXPRESSION
		  :PARENT		PARENT
		  :FLAVOR	        SELF-FLAVOR-DECLARATION
		  :NESTING-LEVEL	(1+ (COMPILAND-NESTING-LEVEL PARENT))
		  :USE-COUNT		1-IF-LIVE-CODE
		  ;; The following fields are only used by procedure integration.
		  :INHERITED-VARS	VARS
		  :DECLARATIONS		LOCAL-DECLARATIONS
		  :INHERITED-GOTAGS	GOTAGS
		  :INHERITED-PROGDESCS	PROGDESCS
		  :INHERITED-RETPROGDESC RETPROGDESC
		  :INHERITED-LOCAL-FUNCTIONS LOCAL-FUNCTIONS
		  :INHERITED-LOCAL-MACROS *LOCAL-ENVIRONMENT*
		  ))
      (UNLESS (ZEROP 1-IF-LIVE-CODE)
	(PUSH (AND NAMEDP (SYMBOLP LAMBDA-NAME) LAMBDA-NAME)
	      (COMPILAND-LOCAL-FUNCTION-MAP PARENT))
	(PUSH CHILD
	      (COMPILAND-CHILDREN PARENT))))
    (LET* (( MASK (- VAR-BIT 1))
	   ( *VAR-LEVEL-COUNTS* (MAKE-LIST (COMPILAND-NESTING-LEVEL CHILD)
					   :INITIAL-ELEMENT '0) )
	   (*LOOP-VAR-BIT* VAR-BIT)
	   ( FORM
	    (PROG1 (LET ((PROPAGATE-VAR-SET 0)
			 (SUBST-VAR-SET 0)
			 (VARS VARS)
			 (*CURRENT-COMPILAND* CHILD)
			 (*LOOP-LEVEL* 0)
			 (*OVERLAP-CANDIDATES* T))
		     ;; perform pass 1 of compilation.
		     (IF (AND COMPILER-WARNINGS-CONTEXT
			      (NULL SI:OBJECT-WARNINGS-OBJECT-NAME)
			      (SYMBOLP FNAME-TO-GIVE))
			 (OBJECT-OPERATION-WITH-WARNINGS (FNAME-TO-GIVE)
			   (P1-WITH-ANNOTATION CHILD #'QCOMPILE1))
		       (P1-WITH-ANNOTATION CHILD #'QCOMPILE1)))
		   (UPDATE-PROPAGATE-VAR-SET)) )
	   ;; lexical entities referenced by the function but defined outside of it:
	   ( USED    (LOGAND (EXPR-USED    FORM) MASK) )
	   ( ALTERED (LOGAND (EXPR-ALTERED FORM) MASK) )
	   ( LEXICAL-VAR-REF-SET (LOGDIF (LOGIOR USED ALTERED) SPECIAL-VAR-BIT) )
	   )
      (UNLESS (OR (ZEROP LEXICAL-VAR-REF-SET)
		  (ZEROP 1-IF-LIVE-CODE))
	;; At this point we know that the function contained non-local lexical
	;; references, but they could be to variables, BLOCK names, or GO tags.
	;; Only variable references require making a lexical closure.
	(DOLIST ( V VARS )
	  (WHEN (EQ (VAR-TYPE V) 'FEF-LOCAL)
	    (LET (( THIS-VAR-BIT (CDDR (VAR-LAP-ADDRESS V))))
	      (WHEN (IF THIS-VAR-BIT ; could be nil when called from EXTEND-LOCAL-VARIABLES .
			(LOGTEST LEXICAL-VAR-REF-SET THIS-VAR-BIT)
		      (VAR-USE-COUNT V))
		;; This is one of the referenced variables
		(SETF LEXICAL T)	   ; making a lexical closure
		(WHEN (AND THIS-VAR-BIT (LOGTEST ALTERED THIS-VAR-BIT))
		  (PUSHNEW 'FEF-ARG-ALTERED-IN-LEXICAL-CLOSURES ; tested in VAR-COMPUTE-INIT
			   (VAR-MISC V)))
		(PUSHNEW 'FEF-ARG-USED-IN-LEXICAL-CLOSURES
			 (VAR-MISC V))
		(UNLESS EPHEMERAL
		  ;; If this closure is not ephemeral, then any that it uses can't be either.
		  (LET ((INIT (VAR-INIT V)))
		    (WHEN (AND (CONSP INIT)
			       (EQ (CAR-SAFE (SECOND INIT)) 'LEXICAL-CLOSURE))
		      (NOT-EPHEMERAL (SECOND INIT)))))
		(SETF (VAR-OVERLAP-VAR V) NIL)
		(WHEN (AND THIS-VAR-BIT
			   (ZEROP (SETF LEXICAL-VAR-REF-SET
					(LOGDIF LEXICAL-VAR-REF-SET THIS-VAR-BIT))))
		  ;; Found all that we were looking for.
		  (RETURN))
		))))
	(WHEN LEXICAL
	  (INCF LEXICAL-CLOSURE-COUNT)
	  (WHEN (> LEXICAL-CLOSURE-COUNT MAX-LEXICAL-CLOSURE-COUNT)
	    (IF (ZEROP MAX-LEXICAL-CLOSURE-COUNT) ; the first time
		(SETF (COMPILAND-INITIAL-ENVIRONMENT-VARS PARENT)
		      VARS)
	      (DO ((IVARS (COMPILAND-INITIAL-ENVIRONMENT-VARS PARENT) (REST IVARS)))
		  ((OR (NULL IVARS)
		       (MEMBER (FIRST IVARS) VARS :TEST #'EQ))
		   (SETF (COMPILAND-INITIAL-ENVIRONMENT-VARS PARENT) IVARS))))
	    (SETQ MAX-LEXICAL-CLOSURE-COUNT LEXICAL-CLOSURE-COUNT))
	  (SETF (GETF (COMPILAND-PLIST CHILD) 'VAR-LEVEL-COUNTS)
		(NREVERSE *VAR-LEVEL-COUNTS*))
	  (WHEN (COMPILAND-SUBST-FLAG CHILD)
	    ;; not meaningful for a DEFSUBST to be a closure.
	    (WARN 'COMPILAND-SUBST-FLAG ':IMPLAUSIBLE
		  "DEFSUBST ~S references non-local lexical variables so cannot be expanded inline."
		  FNAME-TO-GIVE)) )
	)
      (SETF (COMPILAND-USED-VAR-SET CHILD) USED)
      (SETF (COMPILAND-ALTERED-VAR-SET CHILD) ALTERED)
     )
    (IF LEXICAL
	(LET ((DEF `(LEXICAL-CLOSURE
		      ,CHILD
		      ,(AND (OR EPHEMERAL
				;; from PROCESS-PERVASIVE-DECLARATIONS:
				(GETF (COMPILAND-PLIST CHILD)
				      'SI:DOWNWARD-FUNCTION))
			    (DOLIST (GRANDCHILD (COMPILAND-CHILDREN CHILD) T)
			      (LET ((X (COMPILAND-LEXICAL-CLOSURE-FLAG GRANDCHILD)))
				(WHEN (AND (CONSP X) (NOT (THIRD X)))
				  ;; current closure can't be ephemeral if it has
				  ;; any children that are not.
				  (RETURN NIL)))) ))))
	   (SETF (COMPILAND-LEXICAL-CLOSURE-FLAG CHILD) DEF)
	   (INCF EXPRESSION-SIZE 2)
	   (IF (COMPILAND-MACRO-FLAG CHILD)
	       ;; need to cons on the macro flag here instead of in QLAPP.
	       (PROGN (SETF (COMPILAND-MACRO-FLAG CHILD) NIL)
		      (INCF EXPRESSION-SIZE 2)
		      `(CONS 'MACRO ,DEF))
	     DEF))
      `(BREAKOFF-FUNCTION ,CHILD))))

))

#!C
; From file P1FUNS.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1FUNS.#"



(DEFUN RECEIVE-CLOS-MAPS (LL)
  ;;  5/05/88 DNG - Original.
  ;;  5/09/88 DNG - Moved (PUSH VAR VARS) into MAKE-MAP-HOME .
  ;;  5/10/88 DNG - Warn about method args declared SPECIAL.
  ;;  5/23/88 CLM - Save the number of mapping-tables in a new field,
  ;;                  :MAP-SLOTS, in the debug-info.
  ;;  5/23/88 DNG - Use TICLOS::SPECIALIZERS declaration saved by PROCESS-PERVASIVE-DECLARATIONS.
  ;;  6/03/88 CLM - Changed to never delete the Continuation, even if not referenced later.
  ;; 11/22/88 DNG - Don't warn about special arguments whose class is T.
  ;;  4/28/89 DNG - Store class in both VAR-DATA-TYPE and VAR-DECLARATIONS.  
  ;;		Permit specializer name to be an anonymous class object.
  ;;  4/28/89 DNG - Don't warn about special arguments for any built-in class.
  ;;  5/05/89 DNG - Don't do CLASS-OF on an EQL form that has not yet been evaluated.
  (LET ((SPECIFIERS (OR (GETF (COMPILAND-PLIST *CURRENT-COMPILAND*) 'TICLOS::SPECIALIZERS)
			(LET ((FNAME (COMPILAND-FUNCTION-NAME *CURRENT-COMPILAND*)))
			  (AND (CONSP FNAME)
			       (EQ (CAR FNAME) 'TICLOS:METHOD)
			       (CAR (LAST FNAME)))))))
    (UNLESS (NULL SPECIFIERS)
      ;; This function is for a CLOS method.
      (LET ((SLOT-NUMBER SYS:LOCAL-FOR-FIRST-MAPPING-TABLE)
	    (count 0))
	(DO ((LL-TAIL LL (REST LL-TAIL))
	     (SPEC-TAIL SPECIFIERS (REST SPEC-TAIL)))
	    ((NULL SPEC-TAIL))
	  (WHEN (MEMBER (FIRST LL-TAIL) LAMBDA-LIST-KEYWORDS :TEST #'EQ)
	    (SETQ LL-TAIL NIL))
	  (LET* ((ARG-NAME (FIRST LL-TAIL))
		 (CLASS-NAME (IF (TICLOS::INDIVIDUAL-TYPEP (FIRST SPEC-TAIL))
				 (LET ((EXP (TICLOS::INDIVIDUAL-TYPE (FIRST SPEC-TAIL))))
				   (DECLARE (NOTINLINE SELF-EVALUATING-P TICLOS:CLASS-OF)) ; don't need speed here.
				   (IF (OR QC-FILE-LOAD-FLAG (SELF-EVALUATING-P EXP))
				       (TICLOS:CLASS-OF EXP)
				     ;; Else the form may not have been evaluated yet.
				     'T))
			       (FIRST SPEC-TAIL)))
		 (MAP-VAR (MAKE-MAP-HOME (IF (OR (NULL ARG-NAME)
						 (NULL (SYMBOL-PACKAGE ARG-NAME)))
					     (GENSYM)
					   (INTERN (STRING-APPEND "map for " ARG-NAME)))
					 SLOT-NUMBER)))
	    (UNLESS (NULL ARG-NAME)
	      (LET ((VAR (LOOKUP-VAR ARG-NAME VARS)))
		(WHEN (AND (EQ (VAR-TYPE VAR) 'FEF-SPECIAL)
			   (NOT (TYPEP (TICLOS:CLASS-NAMED CLASS-NAME T *COMPILE-FILE-ENVIRONMENT*)
				       'TICLOS:BUILT-IN-CLASS)))
		  (WARN 'RECEIVE-CLOS-MAPS :IMPLAUSIBLE
			"Method argument ~S is special; this will prevent optimization of slot accesses."
			ARG-NAME))
		(SETF (GETF (VAR-DECLARATIONS VAR) 'MAPPING-TABLE) MAP-VAR)
		(LET ((DECLARED-TYPE (VAR-DATA-TYPE VAR)))
		  (COND ((NOT (OR (EQ DECLARED-TYPE CLASS-NAME)
				  (SUBTYPEP DECLARED-TYPE CLASS-NAME *COMPILE-FILE-ENVIRONMENT*)
				  (SUBTYPEP CLASS-NAME DECLARED-TYPE *COMPILE-FILE-ENVIRONMENT*)))
			 (WARN 'RECEIVE-CLOS-MAPS :IMPLAUSIBLE
			       "Parameter ~S DECLAREd type ~S, inconsistent with specializer ~S."
			       ARG-NAME DECLARED-TYPE (FIRST SPEC-TAIL)))
			((AND (EQ CLASS-NAME 'T)
			      (NOT (TYPEP (TICLOS:CLASS-NAMED DECLARED-TYPE T *COMPILE-FILE-ENVIRONMENT*)
					  'TICLOS:BUILT-IN-CLASS)))
			 (WARN 'RECEIVE-CLOS-MAPS :IMPLAUSIBLE
			       "Parameter ~S has been DECLAREd to be of type ~S, so
you might as well say that it is specialized on that class, which will enable
more efficient code to be generated for slot accesses."
			      ARG-NAME (TICLOS:CLASS-PROPER-NAME DECLARED-TYPE)))))
		(SETF (VAR-DATA-TYPE VAR) CLASS-NAME)
		(SETF (GETF (VAR-DECLARATIONS VAR) 'TYPE) CLASS-NAME)
		)))
	  (SETQ SLOT-NUMBER (MAX SYS:LOCALS-FOR-MAPPING-TABLE-BASE
				 (1+ SLOT-NUMBER)))
	  (incf count)
	  )					; end DO
	(LET ((VAR  (MAKE-MAP-HOME '.NEXT-METHOD-LIST. SLOT-NUMBER)))
	  (SETF (VAR-KIND VAR) 'FEF-ARG-KEY) ; never delete* (old - delete if not referenced later)
	  ;;add new field to debug-info list indicating number of mapping-tables
	  (push `(:map-slots . ,count) (compiland-debug-info *current-compiland*))
	  )
	)))
  (VALUES))


))

#!C
; From file CLOS.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; CLOS.#"


(DEFUN STD-IVAR-OPT (FORM) ; optimize (STANDARD-INSTANCE-ACCESS instance slot-name)
  ;;  5/09/88 DNG - Original.
  ;;  5/10/88 DNG - Use TICLOS:TYPE-NAME instead of ENSURE-CLASS-NAME .
  ;;  4/25/89 DNG - Watch out for class T.
  ;;  4/28/89 DNG - Add handling for THE forms. 
  (LET ((OBJECT-ARG (SECOND FORM))
	(SLOT-ARG (THIRD FORM))
	OBJECT-VAR MAP-VAR)
    (WHEN (EQ (CAR-SAFE OBJECT-ARG) 'THE-EXPR)
      (SETQ OBJECT-ARG (EXPR-FORM OBJECT-ARG)))
    (IF (AND (QUOTEP SLOT-ARG)			; slot name is a constant
	     (NULL (CDDDR FORM))		; right number of arguments
	     (EQ (CAR-SAFE OBJECT-ARG) 'LOCAL-REF)
	     (SETQ MAP-VAR (GETF (VAR-DECLARATIONS (SETQ OBJECT-VAR (SECOND OBJECT-ARG)))
				 'MAPPING-TABLE)) )
	;; Can optimize to %STANDARD-INSTANCE-REF
	(LET ((CLASS-NAME (TICLOS:TYPE-NAME (VAR-DATA-TYPE OBJECT-VAR))))
	  (IF (EQ CLASS-NAME 'T)
	      FORM
	    (IF (AND (EQ (VAR-COMPILAND OBJECT-VAR) *CURRENT-COMPILAND*)
		     (EQ (VAR-COMPILAND MAP-VAR) *CURRENT-COMPILAND*))
		`(%STANDARD-INSTANCE-REF ,OBJECT-ARG ,(VAR-LAP-ADDRESS MAP-VAR)
					 ,CLASS-NAME ,(SECOND SLOT-ARG))
	      (WITH-STACK-LIST* (VARS MAP-VAR VARS)
		(P1 `(LET ((.OBJECT. ,(MARK-P1-DONE OBJECT-ARG))
			   (.MAP. ,(VAR-NAME MAP-VAR)))
		       (%STANDARD-INSTANCE-REF .OBJECT. .MAP.
					       ,CLASS-NAME ,(SECOND SLOT-ARG)) )
		    )))))
      FORM)))

))

#!C
; From file CLOS.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; CLOS.#"


(DEFUN SETF-STD-IVAR-OPT (FORM)
  ;; optimize (FUNCALL #'(SETF STANDARD-INSTANCE-ACCESS) value instance slot-name)
  ;;  5/10/88 DNG - Original.
  ;;  2/27/89 DNG - Add handling for FLAVOR-INSTANCE-ACCESS .
  ;;  3/3/89 DNG - Add optimization for calls to #'(SETF SLOT-VALUE) where the 
  ;;		class of the object was not apparent until after other optimizations 
  ;;		were done [particularly the one in SETQ-OPT].
  ;;  3/8/89 DNG - Permit optimizing HYBRID-CLASS.
  ;; 4/22/89 DNG - Fix to not try to reference slots in class T.
  ;;  4/28/89 DNG - Add handling for THE forms. 
  (IF (AND (OR (EQUAL (SECOND FORM) '(FUNCTION (SETF TICLOS:STANDARD-INSTANCE-ACCESS)))
	       (EQUAL (SECOND FORM) '(FUNCTION (SETF ticlos:flavor-instance-access))))
	   (= (LENGTH FORM) 5))
      (LET ((OBJECT-ARG (FOURTH FORM))
	    (SLOT-ARG (FIFTH FORM))
	    OBJECT-VAR MAP-VAR)
	(WHEN (EQ (CAR-SAFE OBJECT-ARG) 'THE-EXPR)
	  (SETQ OBJECT-ARG (EXPR-FORM OBJECT-ARG)))
	(IF (AND (QUOTEP SLOT-ARG)		; slot name is a constant
		 (EQ (CAR-SAFE OBJECT-ARG) 'LOCAL-REF)
		 (SETQ MAP-VAR (GETF (VAR-DECLARATIONS (SETQ OBJECT-VAR (SECOND OBJECT-ARG)))
				     'MAPPING-TABLE)) )
	    ;; Can optimize to %STANDARD-INSTANCE-REF
	    (LET ((CLASS-NAME (TICLOS:TYPE-NAME (VAR-DATA-TYPE OBJECT-VAR))))
	      (IF (EQ CLASS-NAME 'T)
		  FORM
		(IF (AND (EQ (VAR-COMPILAND OBJECT-VAR) *CURRENT-COMPILAND*)
			 (EQ (VAR-COMPILAND MAP-VAR) *CURRENT-COMPILAND*))
		    `(SETQ (%STANDARD-INSTANCE-REF ,OBJECT-ARG ,(VAR-LAP-ADDRESS MAP-VAR)
						   ,CLASS-NAME ,(SECOND SLOT-ARG))
			   ,(THIRD FORM))
		  (WITH-STACK-LIST* (VARS MAP-VAR VARS)
		    (P1 `(LET ((.OBJECT. ,(MARK-P1-DONE OBJECT-ARG))
			       (.MAP. ,(VAR-NAME MAP-VAR)))
			   ;; Can't use SETQ here because the pass 1 handler for SETQ won't accept it.
			   (%SET-STANDARD-INSTANCE-REF ,(MARK-P1-DONE (THIRD FORM))
						       .OBJECT. .MAP. ,CLASS-NAME ,(SECOND SLOT-ARG))
			   ))))))
	  (IF (EQUAL (SECOND FORM) '(FUNCTION (SETF ticlos:flavor-instance-access)))
	      ;; use equivalent of inline expansion of SET-IN-INSTANCE
	      (P1 (LET ((VALUE (GENSYM)))
		    `(LET ((,VALUE ,(MARK-P1-DONE (THIRD FORM))))
		       (SYS:SETCDR ,(MARK-P1-DONE `(LOCATE-IN-INSTANCE ,OBJECT-ARG ,SLOT-ARG)) ,VALUE))))
	    FORM)))
    (IF (EQUAL (SECOND FORM) '(FUNCTION (SETF TICLOS:SLOT-VALUE)))
	(LET* ((OBJECT-ARG (FOURTH FORM))
	       (CLASS (TYPE-OF-EXPRESSION OBJECT-ARG))
	       CLASS-OBJECT)
	  (IF (AND (= (LENGTH FORM) 5)
		   (NOT (EQ CLASS 'T))
		   (SETQ CLASS-OBJECT (TICLOS::CLASS-NAMED CLASS T *LOCAL-ENVIRONMENT*))
		   ;; Do this only for STANDARD-CLASS because it is the only one that we 
		   ;; know will return a form suitable for pass 2.
		   (MEMBER (TICLOS:CLASS-NAME (TICLOS:CLASS-OF CLASS-OBJECT))
			   '(TICLOS:STANDARD-CLASS TICLOS:HYBRID-CLASS)) )
	      (TICLOS:OPTIMIZE-SETF-SLOT-VALUE CLASS-OBJECT FORM)
	    FORM))
      FORM)))

))

#!C
; From file P1OPT.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1OPT.#"


(DEFUN THE-EXPR-OPT (FORM)
 ;; 1/23/85 - Original version.
 ;; 2/19/85 - More cases for removing annotation.
 ;; 3/10/86 - Don't discard type information.
 ;; 9/19/86 - Call POST-OPTIMIZE in P1-WITH-ANNOTATION instead of here.
 ;;10/11/86 - Do re-optimize the arg if P1VALUE has changed.
 ;;10/17/86 - Return 2nd value of T when result doesn't need further optimization.
 ;;11/19/86 - Test OPCODE property instead of QLVAL.
 ;; 4/28/89 DNG - Remove annotation when TYPE is a class object and 
 ;;		TYPE-OF-EXPRESSION is the name of the same class.
  (LET* ((ARG (EXPR-FORM FORM)))
    (COND
      ((OR (QUOTEP ARG)	; annotation not needed on constant
	   (AND (OR (TRIVIAL-FORM-P ARG)   ; annotation not needed on variable
		    (NOT (GET (FIRST ARG) 'P2)) ; not a special form, annotation not needed
		    (GET (FIRST ARG) 'OPCODE) ; machine instruction, not worth annotating
		    )
		;; is the type redundant?
		(LET ((TYPE (EXPR-TYPE FORM)))
		  (OR (EQ TYPE 'UNKNOWN)
		      (SUBTYPEP (TYPE-OF-EXPRESSION ARG) TYPE *COMPILE-FILE-ENVIRONMENT*))))
	   (MEMBER (CAR-SAFE ARG) '(RETURN-FROM GO *THROW THROW) :TEST #'EQ)
	   ;; annotation would get in way of optimization
	   (AND (EQ (CAR-SAFE ARG) 'THE-EXPR)
		(OR (EQ (EXPR-TYPE FORM) 'UNKNOWN)
		    (NOT (EQ (EXPR-TYPE ARG) 'UNKNOWN))))
	   )
       (VALUES ARG T))   	; remove annotation
      ((AND (SYMBOLP P1VALUE)
	    (NOT (EQ P1VALUE (EXPR-DEST FORM))))
       (MAKE-EXPR :EXPR-FORM (POST-OPTIMIZE ARG)
		  :EXPR-USED (EXPR-USED FORM)
		  :EXPR-ALTERED (EXPR-ALTERED FORM)
		  :EXPR-OPTIMIZE (EXPR-OPTIMIZE FORM)
		  :EXPR-TYPE (EXPR-TYPE FORM)))
      (T FORM))))

))

#!C
; From file P1FUNS.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1FUNS.#"


(DEFUN PROCESS-BINDING-DECLARATIONS ( BOUND-VARS DECL-LIST )
  ;; This function records the information specified by any
  ;;  declarations that are associated with variable bindings,
  ;;  except for SPECIAL which is handled in FIND-TYPE.
  ;;  Declarations currently implemented here are TYPE and IGNORE.
  ;;  Other declarations are handled by PROCESS-PERVASIVE-DECLARATIONS
  ;;  which also issues warnings for unrecognized declarations.
  ;;
  ;;  8/27/86 DNG - Use new function STANDARD-TYPE-NAME-P; make
  ;;		RECORD-VAR-DECLARATIONS a local function; recognize dummy
  ;;		declarations .AUX. and .ARG.; use CANONICALIZE-TYPE-FOR-COMPILER .
  ;; 10/20/86 DNG - Warn about variables declared both SPECIAL and IGNORE.
  ;;  4/25/89 DNG - Add setting of VAR-DATA-TYPE and DECLARED-TYPE .
  ;;  5/03/89 DNG - Support (DECLARE (FUNCTION {var-name}*)).
  ;;		Add support for DEFAULT-TYPE.
  (LET ((DUPLICATED NIL))
    (FLET ((RECORD-VAR-DECLARATIONS ( DECL-KIND DECL-VALUE VAR-NAME-LIST &OPTIONAL NO-WARN)
	     ;; Enters data into the VAR-DECLARATIONS slot of a variable.
	     (DOLIST ( VARNAME VAR-NAME-LIST )
	       (LET (( V (LOOKUP-VAR VARNAME BOUND-VARS) ))
		 (COND
		   ((NULL V)
		    (UNLESS (OR DUPLICATED NO-WARN)
		      (WARN 'VAR-DECLARATIONS ':IMPLAUSIBLE
			    "~S declaration given for variable ~S which is not bound at the current level."
			    DECL-KIND VARNAME) ))
		   ((GETF (VAR-DECLARATIONS V) DECL-KIND)
		    (UNLESS NO-WARN
		      (WARN 'VAR-DECLARATIONS ':IMPLAUSIBLE
			    "There is more than one ~S declaration for variable ~S."
			    DECL-KIND VARNAME)))
		   ((AND (EQ DECL-KIND 'IGNORE)
			 (EQ (VAR-TYPE V) 'FEF-SPECIAL))
		    (WARN 'IGNORE-SPECIAL ':IMPLAUSIBLE
			  "IGNORE declaration given for special variable ~S." VARNAME))
		   (T
		    (SETF (GETF (VAR-DECLARATIONS V) DECL-KIND) DECL-VALUE)
		    (WHEN (EQ DECL-KIND 'TYPE)
		      (SETF (VAR-DATA-TYPE V) DECL-VALUE)
		      (WHEN (EQ (VAR-TYPE V) 'FEF-SPECIAL)
			(PUSH `(VARIABLE-TYPE ,VARNAME ,DECL-VALUE)
			      LOCAL-DECLARATIONS)) )))))) )
      (DOLIST ( DECL DECL-LIST )
	(WHEN (CONSP DECL)
	  (LET (( DT (FIRST DECL) ))
	    (COND ((NOT (SYMBOLP DT)) NIL) ; avoid error on GETL
		  ((EQ DT 'IGNORE)
		   (RECORD-VAR-DECLARATIONS 'IGNORE 'T (REST DECL)) )
		  ((EQ DT 'TYPE)
		   (LET ((CANON (CANONICALIZE-TYPE-FOR-COMPILER (SECOND DECL) 'DECLARE)))
		     (UNLESS (EQ CANON 'UNKNOWN) ; unless erroneous
		       (RECORD-VAR-DECLARATIONS 'DECLARED-TYPE (SECOND DECL) (CDDR DECL) T)
		       (RECORD-VAR-DECLARATIONS 'TYPE CANON (CDDR DECL)))))
		  ((STANDARD-TYPE-NAME-P DT)
		   (RECORD-VAR-DECLARATIONS 'TYPE DT (REST DECL)) )
		  ((AND (EQ DT 'FUNCTION)
			(OR (NULL (CDDR DECL))
			    (NOT (LISTP (THIRD DECL)))))
		   ;; Apparently using (DECLARE (FUNCTION x y z)) as an abbreviation for
		   ;; (DECLARE (TYPE FUNCTION x y z)).  This isn't consistent with my 
		   ;; interpretation of CLtL, but it has been adopted by X3J13.
		   (RECORD-VAR-DECLARATIONS 'TYPE DT (REST DECL)) )
		  ((MEMBER DT '(.AUX. .ARG.))
		   ;; Function P1AUX, EXPAND-LAMBDA, or EXPAND-KEYED-LAMBDA has
		   ;; split a lambda-list into args and aux-vars and duplicated
		   ;; the declarations.  Thus we might see declarations
		   ;; that refer to variables not bound here.
		   (SETQ DUPLICATED T))
		  ((EQ DT 'DEFAULT-TYPE)
		   ;; Like TYPE, except just ignore it if the type has already been declared.
		   ;; This is used by TICLOS::PARSE-METHOD
		   (LET ((CANON (CANONICALIZE-TYPE-FOR-COMPILER (SECOND DECL) 'DECLARE)))
		     (UNLESS (EQ CANON 'UNKNOWN) ; unless erroneous
		       (RECORD-VAR-DECLARATIONS 'TYPE CANON (CDDR DECL) T))))
		  (T NIL) )		   ; ignore others here
	    ))))))

))

#!C
; From file TYPEOPT.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; TYPEOPT.#"


(DEFUN DECLARE-FTYPE (DECL &OPTIONAL (LOCAL-FUNCTION-ALIST 'GLOBAL) LOCAL-DECLS)
  ;; Process declarations FTYPE and FUNCTION.
  ;;  8/29/86 DNG - Original.
  ;;  9/08/86 DNG - Set FUNCTION-ARG-TYPES property in target environment.
  ;;  9/09/86 DNG - Give warning in cold-load file.
  ;; 10/07/86 DNG - Permit VALUES list as result type.
  ;;  4/28/89 DNG - Support (DECLARE (FUNCTION {var-name}*)).
  ;;  5/02/89 DNG - Add recording for non-symbol function specs.
  (BLOCK ESCAPE
    (LET ( ARG-TYPES RESULT-TYPE FUNCTION-NAMES )
      (CASE (FIRST DECL)
	    ( FTYPE
	     (SETQ FUNCTION-NAMES (CDDR DECL))
	     (LET (( FUNCTION-TYPE (TYPE-CANONICALIZE (SECOND DECL) *COMPILE-FILE-ENVIRONMENT*)))
	       (UNLESS (AND (CONSP FUNCTION-TYPE)
			    (EQ (FIRST FUNCTION-TYPE) 'FUNCTION)
			    (= (LENGTH FUNCTION-TYPE) 3))
		 (WARN 'FTYPE ' :IGNORABLE-MISTAKE
		       "Invalid function~A type in declaration: ~S" "" DECL)
		 (RETURN-FROM ESCAPE) )
	       (SETQ ARG-TYPES (SECOND FUNCTION-TYPE))
	       (SETQ RESULT-TYPE (THIRD FUNCTION-TYPE)) ))
	    ( FUNCTION
	     (SETQ FUNCTION-NAMES (LIST (SECOND DECL)))
	     (SETQ ARG-TYPES (THIRD DECL))
	     (WHEN (OR (NULL (CDDR DECL))
		       (AND (SYMBOLP ARG-TYPES) (NOT (NULL ARG-TYPES))))
	       ;; Must be using (DECLARE (FUNCTION X Y Z)) as an abbreviation for
	       ;; (DECLARE (TYPE FUNCTION X Y Z)).  This isn't consistent with my 
	       ;; interpretation of CLtL, but it has been adopted by X3J13.
	       (WHEN (EQ LOCAL-FUNCTION-ALIST 'GLOBAL) ; if called from PROCLAIM
		 (RECORD-SPECIAL-VAR-TYPE (FIRST DECL) (REST DECL)))
	       ;; Else just ignore it here; PROCESS-BINDING-DECLARATIONS will handle it.
	       (RETURN-FROM ESCAPE))
	     (SETQ RESULT-TYPE
		   (IF (= (LENGTH DECL) 4)
		       (FOURTH DECL)
		     (CONS 'VALUES (CDDDR DECL)))) )
	    #+compiler:debug
	    ( T (BARF (FIRST DECL) 'DECLARE-FTYPE 'BARF)))
      (SETQ RESULT-TYPE (CANONICALIZE-TYPE-FOR-COMPILER RESULT-TYPE DECL T))
      (WHEN (EQ RESULT-TYPE 'UNKNOWN)
	(RETURN-FROM ESCAPE))
      (UNLESS (AND (LISTP ARG-TYPES)
		   (LET ((KEY NIL))
		     (DOLIST (ARG ARG-TYPES T)
		       (UNLESS (OR (MEMBER ARG LAMBDA-LIST-KEYWORDS :TEST #'EQ)
				   (AND KEY (LISTP ARG) (SYMBOLP (FIRST ARG))
					(TYPE-SPECIFIER-P (SECOND ARG) *COMPILE-FILE-ENVIRONMENT*))
				   (TYPE-SPECIFIER-P ARG *COMPILE-FILE-ENVIRONMENT*))
			 (RETURN NIL))
		       (WHEN (EQ ARG '&KEY) (SETQ KEY T)) )))
	(WARN 'FTYPE ' :IGNORABLE-MISTAKE
	      "Invalid function~A type in declaration: ~S" " argument" DECL)
	(SETQ ARG-TYPES ':ERROR))
      (DOLIST ( FUNCTION-NAME FUNCTION-NAMES )
	(COND ((SYMBOLP FUNCTION-NAME)
	       (IF (LISTP LOCAL-FUNCTION-ALIST)
		   ;; called from PROCESS-PERVASIVE-DECLARATIONS
		   (LET (( TEMP (ASSOC FUNCTION-NAME LOCAL-FUNCTION-ALIST :TEST #'EQ) )
			 ( VALUE (LIST 'FUNCTION ARG-TYPES RESULT-TYPE)))
		     (IF TEMP
			 (SETF (VAR-DATA-TYPE (SECOND TEMP)) VALUE)
		       (PUSH (LIST 'FUNCTION-RESULT-TYPE FUNCTION-NAME VALUE)
			     LOCAL-DECLS)
		       ))
		 ;; else called from PROCLAIM
		 (IF UNDO-DECLARATIONS-FLAG
		     (PROGN
		       (WHEN SI:FILE-IN-COLD-LOAD
			 (WARN 'DECLARE-FTYPE ':IMPLAUSIBLE
			       "Warning: (PROCLAIM '~A) has no effect at cold-load time."
			       DECL))
		       (SETF (GETDECL FUNCTION-NAME 'FUNCTION-RESULT-TYPE)
			     RESULT-TYPE)
		       (SETF UNDO-DECLARATIONS-FLAG 'FUNCTION-RESULT-TYPE)
		       (WHEN (AND (LISTP ARG-TYPES)
				  (NOT (DECLARED-DEFINITION FUNCTION-NAME)))
			 ;; remember argument list for CHECK-NUMBER-OF-ARGS
			 (SETF (GETDECL FUNCTION-NAME 'FUNCTION-ARG-TYPES) ARG-TYPES)))
		   (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))
		     (SETF (GET-FOR-TARGET FUNCTION-NAME 'FUNCTION-RESULT-TYPE)
			   RESULT-TYPE)
		     (WHEN (AND (LISTP ARG-TYPES)
				(NOT (DECLARED-DEFINITION FUNCTION-NAME)))
		       ;; remember argument list for CHECK-NUMBER-OF-ARGS
		       (SETF (GET-FOR-TARGET FUNCTION-NAME 'FUNCTION-ARG-TYPES)
			     ARG-TYPES))))))
	      ((SI:VALIDATE-FUNCTION-SPEC FUNCTION-NAME)
	       (WHEN (AND (EQ TARGET-PROCESSOR HOST-PROCESSOR)
			  (LISTP ARG-TYPES)
			  (NOT (DECLARED-DEFINITION FUNCTION-NAME)))
		 ;; record for COMPILATION-DEFINEDP .
		 (FUNCTION-SPEC-PUTPROP-IN-ENVIRONMENT
		   FUNCTION-NAME ARG-TYPES 'FUNCTION-ARG-TYPES *LOCAL-ENVIRONMENT*)
		 ))
	      (T (WARN 'DECLARE-FTYPE :IGNORABLE-MISTAKE
		       "Invalid function spec ~S in declaration ~S."
		       FUNCTION-NAME DECL))))))
  LOCAL-DECLS)

))

#!C
; From file TYPEOPT.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; TYPEOPT.#"


 (OPTIMIZE-PATTERN (COERCE FUNCTION 'FUNCTION)	(PROGN 1))
 (OPTIMIZE-PATTERN (COERCE SYMBOL 'FUNCTION)	(SYMBOL-FUNCTION 1))

 (OPTIMIZE-PATTERN (SYS:CONSTANTLY 'NIL)	(PROGN #'IGNORE))
 (OPTIMIZE-PATTERN (SYS:CONSTANTLY 'T)		(PROGN #'SYS:CONSTANTLY-T))
 (OPTIMIZE-PATTERN (SYS:CONSTANTLY '0)		(PROGN #'SYS:CONSTANTLY-0))
))

#!C
; From file TYPEOPT.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; TYPEOPT.#"


;;  4/26/89 DNG - Added the next 4.
(DEFPROP MAKE-SYMBOL	SYMBOL	FUNCTION-RESULT-TYPE)
(DEFPROP COPY-SYMBOL	SYMBOL	FUNCTION-RESULT-TYPE)
(DEFPROP GENSYM		SYMBOL	FUNCTION-RESULT-TYPE)
(DEFPROP GENTEMP	SYMBOL	FUNCTION-RESULT-TYPE)
))

#!C
; From file TYPEOPT.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; TYPEOPT.#"


;; 5/3/89 DNG added next 8
(DEFPROP SI:UNION*		LIST FUNCTION-RESULT-TYPE)
(DEFPROP SI:NUNION*		LIST FUNCTION-RESULT-TYPE)
(DEFPROP SI:INTERSECTION*	LIST FUNCTION-RESULT-TYPE)
(DEFPROP SI:NINTERSECTION*	LIST FUNCTION-RESULT-TYPE)
(DEFPROP SI:SET-DIFFERENCE*	LIST FUNCTION-RESULT-TYPE)
(DEFPROP SI:NSET-DIFFERENCE*	LIST FUNCTION-RESULT-TYPE)
(DEFPROP SI:SET-EXCLUSIVE-OR* 	LIST FUNCTION-RESULT-TYPE)
(DEFPROP SI:NSET-EXCLUSIVE-OR*	LIST FUNCTION-RESULT-TYPE)
))

#!C
; From file P1OPT.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1OPT.#"


(DEFPARAMETER *COMPLEMENTS*
	      '((EQ . NEQ)
		(= . /=)
		(< . >=)
		(> . <=)
		(ODDP . EVENP)
		(TRUE . FALSE)
		(SYMBOLP . NSYMBOLP)
		(ATOM . CONSP)
		(LISTP . NLISTP)
		(CHAR= . CHAR/=) (CHAR< . CHAR<=) (CHAR> . CHAR<=)
		(CHAR-EQUAL . CHAR-NOT-EQUAL)
		(CHAR-LESSP . CHAR-NOT-LESSP)
		(CHAR-GREATERP . CHAR-NOT-GREATERP)
		(STRING= . STRING/=) (STRING< . STRING<=) (STRING> . STRING<=)
		(STRING-EQUAL . STRING-NOT-EQUAL)
		(STRING-LESSP . STRING-NOT-LESSP)
		(STRING-GREATERP . STRING-NOT-GREATERP)
		))
(ADD-POST-OPTIMIZER SYS:COMPLEMENT COMPLEMENT-OPT)
(DEFUN COMPLEMENT-OPT (FORM)
  ;;  5/01/89 DNG - Original.
  (LET ((ARG (SECOND FORM)) FN)
    (IF (AND (CONSP ARG)
	     (MEMBER (FIRST ARG) '(QUOTE FUNCTION))
	     (NULL (CDDR FORM))
	     (SYMBOLP (SETQ FN (SECOND ARG))))
	(LET ((X (ASSOC FN *COMPLEMENTS* :TEST #'EQ)))
	  (IF X `(FUNCTION ,(CDR X))
	    (IF (SETQ X (RASSOC FN *COMPLEMENTS* :TEST #'EQ))
		`(FUNCTION ,(CAR X))
	      (IF (EQ FN 'IDENTITY)
		  `(FUNCTION NOT)
		FORM))))
      FORM)))
))


#!C
; From file P1OPT.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1OPT.#"


(DEFUN FUNCTION-WITHOUT-SIDE-EFFECTS-P (FUNCTION-NAME)
  ;;  9/15/86 DNG - Original version separated from NO-SIDE-EFFECTS-P.
  ;; 10/18/86 DNG - Check for some new P1 handlers besides P1SIMPLE.
  ;;  8/04/88 DNG - Return true for VARIABLE-LOCATION and QUOTE-LOAD-TIME-EVAL .
  ;;  5/05/89 DNG - Return true for CONSTANTLY and COMPLEMENT.
  (DECLARE (OPTIMIZE SPEED) (TYPE SYMBOL FUNCTION-NAME))
  (OR (MEMBER (GET FUNCTION-NAME 'P1) '(P1SIMPLE P1ARITHMETIC P1ACCESSOR P1AREF) :TEST #'EQ)
      (MEMBER FUNCTION-NAME
	      '( LIST CONS LIST* EQ NCONS CONS-IN-AREA VALUES VARIABLE-LOCATION 
		QUOTE-LOAD-TIME-EVAL SYS:CONSTANTLY SYS:COMPLEMENT)
	      :TEST #'EQ)
      (LET (( OPTS (GET FUNCTION-NAME 'POST-OPTIMIZERS) ))
	(IF (LISTP OPTS)
	    (LOOP FOR X IN OPTS
		  THEREIS
		  (IF (ATOM X)
		      (MEMBER X
			      '(FOLD-ONE-ARG ARITH-OPT-NON-ASSOCIATIVE
				FOLD-NUMBERS ADD-1-OPT *TIMES-OPT
				AND-OPT OR-OPT 3CXR-OPTIMIZE FOLD-STRING-EQUAL)
			      :TEST #'EQ)
		    (MEMBER (CAR X) '(FOLD-TYPE-PREDICATE)
			    :TEST #'EQ)))
	  (MEMBER OPTS
		  '(FOLD-ONE-ARG ARITH-OPT-NON-ASSOCIATIVE
				 FOLD-NUMBERS ADD-1-OPT *TIMES-OPT
				 AND-OPT OR-OPT 3CXR-OPTIMIZE FOLD-STRING-EQUAL)
		  :TEST #'EQ))))   ; operator for which constant folding is enabled
  )

(DEFUN NO-SIDE-EFFECTS-P (FORM)
  ;; Returns true if FORM is known to not produce any side-effects when it is
  ;;   evaluated; returns NIL if FORM has side-effects or if we don't know.
  ;; The current criteria is rather simple and could be improved later.
  ;; 09/01/84 DNG - Fixed for no side-effects of C...R and EQ.
  ;; 02/06/85 DNG - Check for P1SIMPLE handler; beware of functions
  ;;                passed as arguments.
  ;; 03/05/85 DNG - Add FOLD-NUMBERS to list of constant folders.
  ;; 06/26/85 DNG - Fix DECLARE so TRIVIAL-FORM-P will be inline.
  ;; 12/02/85 DNG - Don't use TRIVIAL-FORM-P in order to exclude BREAKOFF-FUNCTION.
  ;;  3/10/86 DNG - Add handling of THE-EXPR form.
  ;;  5/30/86 DNG - Fix for POST-OPTIMIZERS property which is not a list.
  ;;  6/06/86 DNG - Recognize users of FOLD-TYPE-PREDICATE as not having side-effects.
  ;;  7/12/86 DNG - BREAKOFF-FUNCTION and LEXICAL-CLOSURE can now be considered to have no side-effects.
  ;;  9/11/86 DNG - Return true for (UNDEFINED-VALUE).
  ;;  9/15/86 DNG - Use new function FUNCTION-WITHOUT-SIDE-EFFECTS-P .
  ;;  9/25/86 DNG - Return true for (%FUNCTION-INSIDE-SELF).
  ;;  4/17/89 DNG - Return true for %STANDARD-INSTANCE-REF .
  ;;  5/05/89 DNG - Recognize that COMPLEMENT doesn't invoke its argument.
  (DECLARE (OPTIMIZE SPEED) (INLINE TRIVIAL-FORM-P))
  (IF (OR (ATOM FORM)
	  (MEMBER (CAR FORM)
		  '(QUOTE LOCAL-REF SELF-REF LEXICAL-REF
		    FUNCTION BREAKOFF-FUNCTION LEXICAL-CLOSURE
		    UNDEFINED-VALUE %STANDARD-INSTANCE-REF)
		  :TEST #'EQ)
	  (AND				   ; function call
	    ;; don't bother with recursive expression traversal if user
	    ;;   is most concerned with fast compilation.
	    (< (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH) 3)
	    ;; This function is usually used to decide whether an expression
	    ;;   can be either deleted or moved.  Since such optimizations
	    ;;   could confuse debugging, don't do them when the user has
	    ;;   requested extra safety.  Also, deleting an expression
	    ;;   could hide an error that would have occurred if it had
	    ;;   been executed.
	    (< (OPT-SAFETY OPTIMIZE-SWITCH) 2)
	    (COND
	      ((EQ (FIRST FORM) 'COND)
	       (DOLIST (C (REST FORM))
		 (DOLIST (X C)
		   (UNLESS (NO-SIDE-EFFECTS-P X)
		     (RETURN-FROM NO-SIDE-EFFECTS-P NIL))))
	       (RETURN-FROM NO-SIDE-EFFECTS-P T))
	      ((EQ (FIRST FORM) 'THE-EXPR)
	       (AND (ZEROP (EXPR-ALTERED FORM))
		    (OR SIDE-EFFECT-ENABLE
			(NO-SIDE-EFFECTS-P (EXPR-FORM FORM)))))
	      ((NULL (CDR FORM)) ; no arguments
	       (EQ (FIRST FORM) '%FUNCTION-INSIDE-SELF))
	      (T
	       (AND (FUNCTION-WITHOUT-SIDE-EFFECTS-P (FIRST FORM))
		    (DOLIST (ARG (REST FORM) T)   ; check each argument
		      (COND
			((ATOM ARG))
			((MEMBER (FIRST ARG)
				 '(QUOTE LOCAL-REF SELF-REF LEXICAL-REF)
				 :TEST #'EQ))
			((EQ (FIRST ARG) 'FUNCTION)
			 ;; If a function is being passed as an argument,
			 ;; then it may have side-effects when it is invoked.
			 (UNLESS (OR (MEMBER (FIRST FORM)
					     ;; these don't call the function
					     '(PROGN AND OR EQ EQL EQUAL NOT SYS:COMPLEMENT)
					     :TEST #'EQ)
				     (AND (SYMBOLP (SECOND ARG))
					  (FUNCTION-WITHOUT-SIDE-EFFECTS-P (SECOND ARG))))
			   (RETURN NIL)))
			((MEMBER (FIRST ARG)
				 '(BREAKOFF-FUNCTION LEXICAL-CLOSURE) :TEST #'EQ)
			 (UNLESS (ZEROP (COMPILAND-ALTERED-VAR-SET (SECOND ARG)))
			   (RETURN NIL)))
			(T (UNLESS (NO-SIDE-EFFECTS-P ARG)
			     (RETURN NIL))))))))))
      T
    NIL))
))

#!C
; From file P1HAND.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1HAND.#"


(DEFUN (:PROPERTY HACK-FUNCALL P1) (FORM)
  ;;  5/05/89 DNG - Watch out for the possibility of the form being optimized into something different.
  ;;  5/10/89 clm - It appears the new check for optimization didn't cover all cases.  Ran into a problem
  ;;                of FORM being (HACK-FUNCALL xxxx (P1-HAS-BEEN-DONE (FUNCALL...).  This was failing the
  ;;                EQ test against FORM2, which after passing through P1 no longer had the P1-HAS-BEEN-DONE 
  ;;                tag.
  (LET ((FORM2 (P1 (THIRD FORM))))
    (IF (or (EQ (FIRST FORM2) (FIRST (THIRD FORM)))
	    (eq (first form2) (first (fourth (third form)))))
	;; Unless optimized into something different
	(PROGN
	  (ARBITRARY-SIDE-EFFECTS)
	  (LIST* (FIRST FORM2) (P1V (SECOND FORM)) (CDDR FORM2)) )
      FORM2)))

))

#!C
; From file P1OPT.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1OPT.#"


(DEFUN FUNCALL-FUNCTION (FORM)
  ;; 1/26/85 - Changed from pre-optimizer to post-optimizer.
  ;; 1/06/86 - Disable style checks for P1 call.
  ;; 6/25/86 - Fix to not optimize (FUNCALL '#<DTP-FUNCTION ...> ...).
  ;; 7/17/86 - Inline expansion of local functions.
  ;; 9/09/86 - Increment COMPILAND-USE-COUNT when expanded inline.
  ;; 9/19/86 - Use MARK-P1-DONE instead of P1-ALREADY-DONE; abort recursive inline expansion.
  ;; 10/1/86 - COMPILAND-BREAKOFF-COUNT replaced by COMPILAND-CHILDREN.
  ;; 12/15/88 DNG - Moved optimization of (FUNCALL SELF ...) to here from FUNCALL-OPT.
  ;; 12/16/88 - Fix to not optimize (FUNCALL 'symbol ...) when it has the same 
  ;;		name as a local function.
  ;;  4/17/89 DNG - Consider USED-ONLY-ONCE flag in inline criteria.
  ;;  5/01/89 DNG - Add handling for CONSTANTLY.
  ;;  5/04/89 DNG - Bind VARS, PROPAGATE-VAR-SET, etc. around call to P1 so the 
  ;;		function is in a null lexical environment.
  ;;  5/05/89 DNG - Add optimization for COMPLEMENT.
  (LET ((FNFORM (SECOND FORM)))
    (COND ((ATOM FNFORM)
	   (IF (AND (EQ FNFORM 'SELF)
		    ;; Turn (FUNCALL SELF ...) into (FUNCALL-SELF ...) if within a
		    ;; method or a function with a :SELF-FLAVOR declaration.
		    ;; Leave it alone otherwise -- that would be a pessimization.
		    (NOT (NULL SELF-FLAVOR-DECLARATION)))
	       `(FUNCALL (%FUNCTION-INSIDE-SELF) . ,(CDDR FORM))
	     FORM))
	  ((AND (MEMBER (CAR FNFORM) '(FUNCTION QUOTE) :TEST #'EQ)
		(OR (SYMBOLP (SECOND FNFORM))
		    (CONSP (SECOND FNFORM)))
		;; removed 5/4/89, bind LOCAL-FUNCTIONS to NIL below instead.
		;;(NOT (ASSOC (SECOND FNFORM) LOCAL-FUNCTIONS :TEST #'EQUAL)) ; 12/16/88
		(FUNCTIONP (SECOND FNFORM)))
	   ;; Pass the new call through P1 to enable DEFSUBST expansion
	   ;; and pre-optimizations.
	   (DISCARD FNFORM)
	   (LET ((INHIBIT-STYLE-WARNINGS-SWITCH T)
		 (VARS NIL) (PROPAGATE-VAR-SET 0)
		 (LOCAL-FUNCTIONS NIL) 
		 (GOTAGS NIL) (PROGDESCS NIL)
		 (*LOCAL-ENVIRONMENT* *COMPILE-FILE-ENVIRONMENT*))
	     (P1 (CONS (SECOND FNFORM)
		       (LOOP FOR ARG IN (CDDR FORM)
			     COLLECT (MARK-P1-DONE ARG))))))
	  ((AND (EQ (CAR FNFORM) 'SYS:CONSTANTLY)
		(= (LENGTH FNFORM) 2))
	   ;; (FUNCALL (CONSTANTLY x)) ==> x
	   `(PROG1 ,(SECOND FNFORM) . ,(CDDR FORM)))
	  ((AND (EQ (CAR FNFORM) 'SYS:COMPLEMENT)
		(= (LENGTH FNFORM) 2))
	   ;; (FUNCALL (COMPLEMENT f) a ...) ==> (NOT (FUNCALL f a ...))
	   `(NOT ,(LET ((P1VALUE 'D-INDS))
		    (POST-OPTIMIZE `(FUNCALL ,(SECOND FNFORM) . ,(CDDR FORM))))))
	  (T (LET (( VAR-REF NIL ))
	       (WHEN (AND (EQ (FIRST FNFORM) 'LOCAL-REF)
			  (DOLIST (X LOCAL-FUNCTIONS NIL)
			    (WHEN (EQ (SECOND FNFORM) (SECOND X))
			      (SETQ VAR-REF FNFORM)
			      (RETURN T))))
		 (SETQ FNFORM (VAR-INIT-FORM (SECOND FNFORM))))
	       (OR (AND (MEMBER (FIRST FNFORM) '( BREAKOFF-FUNCTION LEXICAL-CLOSURE ) :TEST #'EQ)
			(LET* (( FC (SECOND FNFORM) )
			       ( NAME (COMPILAND-FUNCTION-SPEC FC) )
			       ( INDECL (INLINE-DECL NAME) ))
			  (LET ((TM (ASSOC NAME INLINE-EXPANSIONS :TEST #'EQ)))
			    (WHEN TM
			      ;; This is a recursive call to a function which we are
			      ;;   currently in the process of expanding inline.
			      ;; Abort the inline expansion.
			      (THROW (SECOND TM) 'RECURSIVE) ))
			  (AND (OR (EQ INDECL 'INLINE)
				   (EQ INDECL 'TRY-INLINE)
				   (AND (NEQ INDECL 'NOTINLINE)
					(OR (< (COMPILAND-EXPRESSION-SIZE FC) 30.)
					    (GETF (COMPILAND-PLIST FC) 'USED-ONLY-ONCE))
					(>= (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)
					    (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH))
					(>= (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)
					    (OPT-SAFETY OPTIMIZE-SWITCH))
					(< (LENGTH (COMPILAND-ALLVARS FC)) 12.)))
			       (NULL (COMPILAND-CHILDREN FC))
			       (EQ (COMPILAND-FLAVOR FC) SELF-FLAVOR-DECLARATION)
			       (LET (( EXPANSION 
				      (PROCEDURE-INTEGRATION
					NAME (CDDR FORM) (COMPILAND-DEFINITION FC)
					INDECL (COMPILAND-DEBUG-INFO FC) FC) ))
				 (UNLESS (NULL EXPANSION)
				   (UNLESS (NULL VAR-REF)
				     (DECF (VAR-USE-COUNT (SECOND VAR-REF))))
				   (INCF (COMPILAND-USE-COUNT FC))
				   EXPANSION) ))))
		   FORM))))))
))

#!C
; From file COMPILE.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; COMPILE.#"


(DEFUN PRINT-FUNCTIONS-REFERENCED-BUT-NOT-DEFINED ()
  "Record and print warnings about any functions referenced in compilation but not defined."
  ;; 10/25/85 DNG - Improve wording of warning message.
  ;;  6/04/86 DNG - Use FORMAT with ~{ instead of FORMAT:PRINT-LIST;
  ;;		clean up the programming style.
  ;;  9/25/86 DNG - Add local function POSSIBLY.
  ;; 11/19/86 DNG - Show possible names in TICL package.
  ;;  8/11/88 DNG - Bind *PACKAGE* to match first file where referenced.  [SPR 6850]
  ;;  8/15/88 DNG - Add use of FILE-OPERATION-WITH-WARNINGS so that warnings 
  ;;		are recorded correctly at the end of MAKE-SYSTEM.
  ;;  8/22/88 DNG - Fix above two changes to not error in GET-SOURCE-FILE-NAME.
  ;;  3/17/89 DNG - Show possible names in the CLOS and TICLOS packages.
  ;;  4/03/89 DNG - Fix for package attribute which is a list.  [SPR 9112]
  ;;  4/05/89 DNG - Added test (NEQ SYM F).
  ;;  5/01/89 DNG - Add CONDITIONS, COMMON-LISP, and CLUE to the package search list.

  ;; Discard any functions that have since become defined.
  (SETQ FUNCTIONS-REFERENCED
	(DELETE-IF #'(LAMBDA (X) (COMPILATION-DEFINEDP (CAR X)))
		   (THE LIST FUNCTIONS-REFERENCED)) )
  ;; Record warnings about the callers, saying that they called an undefined function.
  (DOLIST (FREF FUNCTIONS-REFERENCED)
    (DOLIST (CALLER (CDR FREF))
      (IF (NULL SI:FILE-WARNINGS-PATHNAME) ; when called from MAKE-SYSTEM
	  (FILE-OPERATION-WITH-WARNINGS ((OR (AND (SYMBOLP CALLER)
						  (GET-FOR-TARGET CALLER ':COMPILATION-DEFINED))
					     (IGNORE-ERRORS (GET-SOURCE-FILE-NAME CALLER 'DEFUN)))
					 ':COMPILE
					 NIL)
	    (OBJECT-OPERATION-WITH-WARNINGS (CALLER NIL T)
	      (RECORD-WARNING 'UNDEFINED-FUNCTION-USED ':PROBABLE-ERROR NIL
			      "The undefined function ~S was called."
			      (CAR FREF))))
	(OBJECT-OPERATION-WITH-WARNINGS (CALLER NIL T)
	  (RECORD-WARNING 'UNDEFINED-FUNCTION-USED ':PROBABLE-ERROR NIL
			  "The undefined function ~S was called."
			  (CAR FREF))))))
  (UNLESS (NULL FUNCTIONS-REFERENCED)
    ;; Now print messages describing the undefined functions used.
    (FORMAT T
      "~&The following functions were referenced but do not seem to be defined:")
    (WHEN (< *RETURN-STATUS* WARNINGS)
      (SETQ *RETURN-STATUS* WARNINGS) )
    (FLET ((POSSIBLY (F BY)
	     ;; Help the user out if they reference a function that used to
	     ;; be in the GLOBAL package but is now in ZLC or SYS instead.
	     (WHEN (SYMBOLP F)
	       (LET* ((NAME (SYMBOL-NAME F)))
		 ;; Look it up first in the Compiler package because it inherits
		 ;; from all the right places: LISP, TICL, ZLC, and SYS.
		 (DOLIST (P '("COMPILER" "CLOS" "CONDITIONS" "COMMON-LISP" "W" "FS" "TICLOS" "TIME"
			      "CLUE" ; includes XLIB and CLUEI
			      ))
		   (LET ((PKG (FIND-PACKAGE P)))
		     (UNLESS (NULL PKG)
		       (LET ((SYM (FIND-SYMBOL NAME PKG)))
			 (WHEN (AND SYM
				    (EXTERNAL-SYMBOL-P SYM)
				    (OR (FBOUNDP SYM) (GETL SYM '(P1 P2 OPCODE)))
				    (NEQ SYM F))
			   (LET* ((BY-FILE (OR (AND (SYMBOLP BY)
						    (GET-FOR-TARGET BY ':COMPILATION-DEFINED))
					       (IGNORE-ERRORS (GET-SOURCE-FILE-NAME BY 'DEFUN))))
				  (*PACKAGE* (IF (INSTANCEP BY-FILE)
						 (FIND-PACKAGE (LET ((A (SEND BY-FILE :GET :PACKAGE *PACKAGE*)))
								 (IF (CONSP A) (CAR A) A)))
					       *PACKAGE*))
				  (NEW (OR (GET SYM 'SUPERSEDED)
					   (GET SYM 'SUPERSEDED-BY))))
			     (FORMAT T "~&~8TPerhaps you want ~S ?"
				     (IF (AND NEW (SYMBOLP NEW)) NEW SYM)))
			   (RETURN) ; from DOLIST
			   ))) ))))))
    (IF (SEND *STANDARD-OUTPUT* :OPERATION-HANDLED-P :ITEM)
	(DOLIST (X FUNCTIONS-REFERENCED)
	  (FORMAT T "~& ~S referenced by " (CAR X))
	  (DO ((L (CDR X) (CDR L))
	       (LINEL (OR (SEND *STANDARD-OUTPUT* :SEND-IF-HANDLES :SIZE-IN-CHARACTERS)
			  95.)))
	      ((NULL L))
	    (WHEN (> (+ (SEND *STANDARD-OUTPUT* :READ-CURSORPOS :CHARACTER)
			(FLATSIZE (CAR L))
			3)
		     LINEL)
	      (FORMAT T "~%  "))
	    (SEND *STANDARD-OUTPUT* :ITEM 'FUNCTION-NAME (CAR L)
		  "~S" (CAR L))
	    (WHEN (CDR L) (PRINC ", ")))
	  (POSSIBLY (CAR X) (CADR X))
	  (FORMAT T "~&"))
      (DOLIST (X FUNCTIONS-REFERENCED)
	(FORMAT T "~& ~S referenced by ~{~S~^, ~}~&" (CAR X) (CDR X))
	(POSSIBLY (CAR X) (CADR X))
	)))))

))

#!C
; From file DEFS.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; DEFS.#"


(DEFUN COMPILATION-DEFINE (FUNCTION-SPEC)
  "Record that a definition of FUNCTION-SPEC has been compiled."
  ;;  3/14/86 DNG - Set target property.
  ;;  5/15/86 DNG - Don't bother setting the :COMPILATION-DEFINED property
  ;;		unless it really provides useful information.
  ;;  5/05/89 DNG - Add recording of SETF and LOCF functions specs.
  (TYPECASE FUNCTION-SPEC
    (SYMBOL (WHEN (OR (NOT (FBOUNDP FUNCTION-SPEC))
		      (NOT (EQ (GET-FOR-TARGET FUNCTION-SPEC :SOURCE-FILE-NAME)
			       FDEFINE-FILE-PATHNAME)))
	      (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))
		(SETF (GET-TARGET-PROPERTY FUNCTION-SPEC :COMPILATION-DEFINED)
		      (OR FDEFINE-FILE-PATHNAME T)))))
    (CONS (WHEN (AND (MEMBER (FIRST FUNCTION-SPEC) '(SETF LOCF) :TEST #'EQ)
		     (NOT (FDEFINEDP FUNCTION-SPEC)))
	    (LET ((UNDO-DECLARATIONS-FLAG NIL)
		  (DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))
	      (SETF (FUNCTION-SPEC-GET FUNCTION-SPEC :COMPILATION-DEFINED)
		    (OR FDEFINE-FILE-PATHNAME T)))))))

(DEFUN COMPILATION-DEFINEDP (FUNCTION-SPEC)
  "T if the function spec is defined or a definition of it has been compiled.
Always returns T if function spec is not a symbol."
  ;;  3/04/86 DNG - Use FBOUNDP-FOR-TARGET instead of FDEFINEDP.
  ;;  3/14/86 DNG - Alternate handling when *DEFAULT-DEFS-FROM-HOST* is false.
  ;;  3/18/86 DNG - Fix for when *DEFAULT-DEFS-FROM-HOST* is true.
  ;;  8/29/86 DNG - Consider a function type declaration to be a definition.
  ;;  5/05/89 DNG - Add handling for function spec lists.
  (IF (OR *DEFAULT-DEFS-FROM-HOST* (EQ TARGET-PROCESSOR HOST-PROCESSOR))
      (TYPECASE FUNCTION-SPEC
	(CONS (OR (NOT (MEMBER (FIRST FUNCTION-SPEC) '(SETF LOCF) :TEST #'EQ))
		  (DECLARED-DEFINITION FUNCTION-SPEC)
		  (FUNCTION-SPEC-GET FUNCTION-SPEC :COMPILATION-DEFINED)
		  (LISTP (FUNCTION-SPEC-GET-FROM-ENVIRONMENT
			   FUNCTION-SPEC 'FUNCTION-ARG-TYPES :UNDEFINED *LOCAL-ENVIRONMENT*))))
	(NULL NIL)
	(SYMBOL (OR (FBOUNDP-FOR-TARGET FUNCTION-SPEC)
		    (NOT (MEMBER (GET-FOR-TARGET FUNCTION-SPEC :COMPILATION-DEFINED)
				 '(NIL :UNDEFINED)
				 :TEST #'EQ))
		    (LISTP (GETDECL FUNCTION-SPEC 'FUNCTION-ARG-TYPES :UNDEFINED))))
	(T NIL))
    (OR (DECLARED-DEFINITION FUNCTION-SPEC)
	(AND (SYMBOLP FUNCTION-SPEC)
	     (GET-TARGET-PROPERTY FUNCTION-SPEC :COMPILATION-DEFINED)))))
))

#!C
; From file MINDEFS.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; MINDEFS.#"


;; As of release 6.0, this function is no longer used in code generated by the 
;; compiler, but its definition is retained for compatibility with XLD files 
;; compiled on earlier releases.
(DEFUN MAKE-DYNAMIC-CLOSURE (SYMBOL-LIST FUNCTION)
  ;;  3/25/87 DNG - Original.  Calls to this are generated by P1CLOSURE.
  ;;  5/02/89 DNG - Removed check for (USES-TAIL-REC-P FUNCTION).
  (CLOSURE SYMBOL-LIST FUNCTION))
))

#!C
; From file P1HAND.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1HAND.#"


(DEFUN P1CLOSURE (FORM)
  ;;  9/16/86 - Update USED-VAR-SET.
  ;;  3/25/87 - Watch out for use of D-TAIL-REC calls in the function being closed over.
  ;;  5/02/89 DNG - Removed special handling for tail-recursive calls, which 
  ;;		has been made unnecessary by later microcode changes.
  (AND (NOT (ATOM (CADR FORM)))
       (EQ (CAADR FORM) 'QUOTE)
       (MAPC #'MSPL2 (CADADR FORM)))
  (SETF USED-VAR-SET (LOGIOR USED-VAR-SET SPECIAL-VAR-BIT))
  (LET* ((NEW-FORM (P1EVARGS FORM))
	 (ARG (THIRD NEW-FORM)))
    ;;(LOOP WHILE (AND (CONSP ARG)
    ;;		     (MEMBER (FIRST ARG)
    ;;			     '( SETQ PROGN PROGN-WITH-DECLARATIONS %LET %LET*)))
    ;;	  DO (SETQ ARG (FIRST (LAST ARG))))
    (WHEN (AND (CONSP ARG)
	       (MEMBER (FIRST ARG) '(BREAKOFF-FUNCTION LEXICAL-CLOSURE)))
      (SETF (GETF (COMPILAND-PLIST (SECOND ARG)) 'KEEP-CURRENT-FRAME) T)	; tested in PASS2
      )
    NEW-FORM))
))

#!C
; From file P1OPT.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1OPT.#"


(DEFUN REFORM-ARG-LIST (KEY-ARGS OPT-ARGS FCTN-NAME)
  ;;  9/23/86 CLM - Original version.  Convert keyword arguments into optional args.
  ;;  9/29/86 CLM - Added test to make sure switching the argument order is possible,
  ;;                i.e. no order dependencies.
  ;;  9/29/86 DNG - Change the error message to lower case.
  ;; 10/01/86 DNG - Default the :TEST argument to #'EQL instead of NIL; fix to
  ;;		gracefully handle an odd number of keyword and value args or an
  ;;		atom where a quoted keyword is expected.  Use :TEST #'EQ in the calls to POSITION.
  ;; 10/02/86 DNG - Modify previous fix to not specify both :TEST and :TEST-NOT.
  ;; 11/18/86 CLM - Default :start1 and :start2 keyword args to 0.
  ;;  3/13/87 DNG - Also default :START to 0 when not the last argument.
  ;;  5/04/89 DNG - Add optimization for COMPLEMENT used as the :TEST.
  (DECLARE (UNSPECIAL FCTN-NAME))
  (LET ((OPT-A (COPY-LIST OPT-ARGS))
	(TEST-NOT NIL))
    (DECLARE (TYPE LIST OPT-A))
    ;;loop thru key-args list to see if key-arg is valid for the function; if not,
    ;;signal an error.  also see if key-arg is a variable and if so, return nil
    ;;signalling no optimizations can be done.
    (DO ((KARG KEY-ARGS (CDDR KARG)))
	((NULL KARG))
      (IF (AND (QUOTEP (CAR KARG))
	       (MEMBER (CADAR KARG) OPT-ARGS :TEST #'EQ))
	  (UNLESS (CDR KARG)
	    (WARN 'KEYWORD-NOT-VALID :IMPOSSIBLE
		  "Missing value for last keyword in (~S ... ~S)."
		  FCTN-NAME (CADAR KARG))
	    (RETURN-FROM REFORM-ARG-LIST NIL))

	  (DO ((RESTARGS (CDDR KARG) (CDDR RESTARGS)))
	      ((NULL RESTARGS))
	    (UNLESS (INDEPENDENT-EXPRESSIONS-P (SECOND KARG) (SECOND RESTARGS))
	      (WHEN (< (POSITION (CADAR KARG) OPT-A :TEST #'EQ)
		       (POSITION (CADAR RESTARGS) OPT-A :TEST #'EQ))
		(RETURN-FROM REFORM-ARG-LIST NIL))))
	(PROGN
	  (WHEN (QUOTEP (CAR KARG))
	    (WARN 'KEYWORD-NOT-VALID :IMPOSSIBLE
		  "The function ~S was called with the invalid keyword argument ~S."
		  FCTN-NAME (CADAR KARG)))
	  (RETURN-FROM REFORM-ARG-LIST NIL))))
    (DO ((OPT-ARG OPT-A (CDR OPT-ARG))
	 (ANY-SUPPLIED NIL))
	((NULL OPT-ARG)
	 ;;REMOVE TRAILING NILS
	 (DO ((ARGS OPT-A (CDR ARGS)))
	     ((NOT (EQUAL (CAR ARGS) '(QUOTE NIL))))
	   (POP OPT-A))
	 (RETURN  (NREVERSE OPT-A)))
      (DO ((KEY-ARG KEY-ARGS (CDDR KEY-ARG)))
	  ((NULL KEY-ARG)
	   (SETF (CAR OPT-ARG)
		 (IF KEY-ARGS
		     (COND ((AND (EQ (CAR OPT-ARG) ':TEST)
				 (NOT TEST-NOT))
			    '(FUNCTION EQL))
			   ((MEMBER (CAR OPT-ARG) '(:START1 :START2))
			    '(QUOTE 0))
			   ((AND (EQ (CAR OPT-ARG) ':START) ANY-SUPPLIED)
			    '(QUOTE 0))
			   (T '(QUOTE NIL)))
		     '(QUOTE NIL))
		 ))
	;;IF KEY-ARG IN NOT ON THE OPT-ARG LIST, THAT INDICATES THAT
	;;THE KEY IS A DUPLICATE AND IN SUCH CASES REFERENCES AFTER THE FIRST
	;;ARE DISCARDED
	(WHEN (EQ (CADAR KEY-ARG) (CAR OPT-ARG))
	  (CASE (CAR OPT-ARG)
	    ( :TEST-NOT (SETQ TEST-NOT T))
	    ( :TEST (WHEN (AND (EQ (CAR-SAFE (CADR KEY-ARG)) 'SYS:COMPLEMENT)
			       (NOT TEST-NOT)
			       (>= (OPT-SPEED OPTIMIZE-SWITCH)
				   (OPT-DEBUG OPTIMIZE-SWITCH))
			       (MEMBER ':TEST-NOT OPT-ARGS))
		      ;; (f :TEST (COMPLEMENT x)) ==> (f :TEST-NOT x)
		      (RETURN-FROM REFORM-ARG-LIST
			(REFORM-ARG-LIST (LIST* '':TEST-NOT (SECOND (CADR KEY-ARG))
						'':TEST ''NIL
						KEY-ARGS)
					 OPT-ARGS FCTN-NAME)))))
	  (SETF (CAR OPT-ARG) (CADR KEY-ARG))
	  (SETF ANY-SUPPLIED T)
	  (RETURN))  )
	)))

))

#!C
; From file P1OPT.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1OPT.#"


(ADD-POST-OPTIMIZER SI:FIND-IF* (IF-TO-IF-NOT SI:FIND-IF-NOT*))
(ADD-POST-OPTIMIZER SI:POSITION-IF* (IF-TO-IF-NOT SI:POSITION-IF-NOT*))
(ADD-POST-OPTIMIZER SI:COUNT-IF* (IF-TO-IF-NOT SI:COUNT-IF-NOT*))
(ADD-POST-OPTIMIZER SI:REMOVE-IF* (IF-TO-IF-NOT SI:REMOVE-IF-NOT*))
(ADD-POST-OPTIMIZER SI:DELETE-IF* (IF-TO-IF-NOT SI:DELETE-IF-NOT*))
(ADD-POST-OPTIMIZER SI:ASSOC-IF (IF-TO-IF-NOT SI:ASSOC-IF-NOT))
(ADD-POST-OPTIMIZER SI:RASSOC-IF (IF-TO-IF-NOT SI:RASSOC-IF-NOT))
(DEFUN IF-TO-IF-NOT (FORM OPPOSITE)
  ;;  5/04/89 DNG - Original.
  (LET ((TEST (SECOND FORM)))
    (IF (AND (CONSP TEST)
	     (EQ (CAR TEST) 'SYS:COMPLEMENT)
	     (= (LENGTH TEST) 2)
	     (>= (OPT-SPEED OPTIMIZE-SWITCH)
		 (OPT-DEBUG OPTIMIZE-SWITCH)))
	;; (FIND-IF (COMPLEMENT f) s) ==> (FIND-IF-NOT f s)
	(LIST* OPPOSITE (SECOND TEST) (CDDR FORM))
      FORM)))
))

#!C
; From file MINDEFS.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; MINDEFS.#"



;; These three functions are used for run-time error reporting when the compiler 
;; has generated code to validate conformance to type declarations.
(DEFUN ASSIGNMENT-TYPE-ERROR (VALUE VARIABLE-NAME TYPE-SPECIFIER)
  ;;  5/03/89 DNG - Original.
  (UNLESS (TYPEP VALUE TYPE-SPECIFIER)
    (CERROR "Proceed, assigning the value anyway."
	    "Assigning value ~S to variable ~S, which was declared to be of type ~S."
	    VALUE VARIABLE-NAME TYPE-SPECIFIER))
  VALUE)

(DEFUN ARGUMENT-TYPE-ERROR (VALUE VARIABLE-NAME TYPE-SPECIFIER)
  ;;  5/03/89 DNG - Original.
  (UNLESS (TYPEP VALUE TYPE-SPECIFIER)
    (CERROR "Proceed, using the value anyway."
	    "Parameter ~S was declared to be of type ~S, but is being given the value ~S."
	    VARIABLE-NAME TYPE-SPECIFIER VALUE))
  VALUE)

(DEFUN THE-TYPE-ERROR (VALUE FORM TYPE-SPECIFIER)
  ;;  5/04/89 DNG - Original.
  (UNLESS (TYPEP VALUE TYPE-SPECIFIER)
    (CERROR CONTINUE-MESSAGE
	    "Type mismatch in (THE ~S ~A); the actual value is ~S."
	    TYPE-SPECIFIER FORM VALUE))
  VALUE)

(DEFPROP ASSIGNMENT-TYPE-ERROR	T :ERROR-REPORTER)
(DEFPROP ARGUMENT-TYPE-ERROR	T :ERROR-REPORTER)
(DEFPROP THE-TYPE-ERROR		T :ERROR-REPORTER)
))

#!C
; From file P1DEFS.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1DEFS.#"


(DEFSUBST VALIDATE-TYPES-P ()
  ;; Should code be generated to perform run-time checks to make sure that 
  ;; the data is consistent with the program's type declarations?
  ;;  5/03/89 DNG - Original.
  (> (- (OPT-SAFETY OPTIMIZE-SWITCH)
	(OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))
     1))
))

#!C
; From file TYPEOPT.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; TYPEOPT.#"


(DEFUN RECORD-SPECIAL-VAR-TYPE (TYPE VAR-NAMES)
  ;; Called by PROCLAIM to record the type of a special variable for use by EXPR-TYPE-P.
  ;;  8/27/86 DNG - Original.
  ;; 10/11/86 DNG - Use CANONICALIZE-TYPE-FOR-COMPILER .
  ;; 10/15/86 DNG - NIL is not a valid type for a variable.
  ;;  4/28/89 DNG - Show original type in error message.
  ;;  5/03/89 DNG - Save the original type in the DECLARED-TYPE property.
  (LET ((CANON (CANONICALIZE-TYPE-FOR-COMPILER TYPE 'PROCLAIM)))
    (UNLESS (OR (EQ CANON 'UNKNOWN)
		(EQ CANON 'NIL))
      (DOLIST (NAME VAR-NAMES)
	(IF (SYMBOLP NAME)
	    (IF UNDO-DECLARATIONS-FLAG
		(SETF (GETDECL NAME 'VARIABLE-TYPE) CANON
		      (GETDECL NAME 'DECLARED-TYPE) TYPE)
	      (PROGN (SETF (GET-FOR-TARGET NAME 'VARIABLE-TYPE) CANON)
		     (IF (AND (EQUAL TYPE CANON)
			      (EQ TARGET-PROCESSOR HOST-PROCESSOR))
			 (REMPROP NAME 'DECLARED-TYPE)
		       (SETF (GET-FOR-TARGET NAME 'DECLARED-TYPE) TYPE) )))
	  (WARN 'RECORD-SPECIAL-VAR-TYPE ':IMPOSSIBLE
		"Invalid variable name in (PROCLAIM '(TYPE ~S ~S))" TYPE NAME) ))
      )))

))

#!C
; From file P1HAND.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1HAND.#"


(DEFUN P1SETQ-1 (PAIRS)
  ;;  7/18/85 - Don't check for DEFCONSTANT until after calling P1SETVAR
  ;;		to allow shadowing by a local variable of the same name.
  ;;  8/04/88 DNG - Call P1 with P1VALUE bound to 'SINGLE-VALUE instead of using P1V.
  ;;  5/04/89 DNG - Add option for run-time checking of the value against the 
  ;;		declared type of the variable.

    (COND ((NULL PAIRS) NIL)
	  ((NULL (CDR PAIRS))
	   (WARN 'BAD-SETQ ':IMPOSSIBLE
		 "SETQ appears with an odd number of arguments; the last one is ~S."
		 (CAR (LAST PAIRS)))
	   NIL)
	  ((NULL (CAR PAIRS))
	   ;; Check for this here because P1SETVAR allows NIL but reports
	   ;; an error on other constants.
	   (WARN 'NIL-OR-T-SET ':IMPOSSIBLE
		 "~S being SETQ'd; this will be ignored." (CAR PAIRS))
	   (P1V (CADR PAIRS))		;Just to get warnings on it.
	   (P1SETQ-1 (CDDR PAIRS)))
	  (T (LET* (( VALEXP (LET ((P1VALUE 'SINGLE-VALUE)) (P1 (CADR PAIRS)) ))
		    ( VAR (P1SETVAR (CAR PAIRS)) ))
	       ;; process source before destination to allow propagation of
	       ;;  old value of destination variable.
	       (IF (NULL VAR) ; Error was reported by P1SETVAR
		   (P1SETQ-1 (CDDR PAIRS))
		 (PROGN
		   (DEBUG-ASSERT (NEQ (CAR PAIRS) '.VALUE.)) ; EXPR-TYPE-P assumes this won't be altered.
		   (WHEN (VALIDATE-TYPES-P)
		     (LET ((TYPE (IF (SYMBOLP VAR)
				     (OR (GETDECL VAR 'DECLARED-TYPE 'NIL)
					 (GETDECL VAR 'VARIABLE-TYPE 'T))
				   (IF (EQ (CAR-SAFE VAR) 'LOCAL-REF)
				       (VAR-DECLARED-TYPE (SECOND VAR))
				     'T))))
		       (UNLESS (EQ TYPE 'T)
			 (SETQ VALEXP (P1V `(LET-FOR-LAMBDA ((.VALUE. ,(MARK-P1-DONE VALEXP)))
					      (DECLARE (OPTIMIZE (SAFETY 0) (SPACE 2) (SPEED 1)))
					      (IF (TYPEP .VALUE. ',TYPE)
						  .VALUE.
						(ASSIGNMENT-TYPE-ERROR .VALUE. ',(FIRST PAIRS) ',TYPE))
					      ))))))
		   (CONS VAR (CONS VALEXP (P1SETQ-1 (CDDR PAIRS))))))))))

))

#!C
; From file P1FUNS.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1FUNS.#"


(DEFUN P1-ARG-FIXUP (BODY OLD-VARS)
  ;; This function is called by PASS1 to generate any code needed to
  ;; assign default values to optional arguments or bind special arguments.
  ;; [This function is new for Explorer release 3 -- previously, these things
  ;; were handled by the A.D.L. and the Special Variable Bit-Map.]
  ;; If a function has any optional arguments, the microcode will push the
  ;; number of optionals supplied on the stack before executing the first
  ;; instruction.  The code generated below tests that value to determine
  ;; which arguments need to be defaulted.  Note that since the new code is
  ;; being pushed onto the front of the function body, the code is being
  ;; generated in reverse order from its execution order.
  ;;
  ;; 12/10/85 DNG - Original version.
  ;;  6/10/86 DNG - Use new argument OLD-VARS.
  ;;  9/19/86 DNG - Use MARK-P1-DONE instead of P1-ALREADY-DONE.
  ;;  5/03/89 DNG - Add use of VALIDATE-TYPES-P and ARGUMENT-TYPE-ERROR.
  
  (LET (( OPTIONAL-ARG-COUNT 0 )
	( DEPENDENCY NIL )
	( DEFAULT-VALUES NIL )
	( STOP (CAR OLD-VARS) )
	( VALIDATE-TYPES-P (VALIDATE-TYPES-P) ))
    
    ;;	 First, scan the argument variables to collect some information.
    
    (DOLIST ( V VARS ) ; scan args from last to first
      (WHEN (EQ V STOP) (RETURN))
      (WHEN (AND (EQ (VAR-TYPE V) 'FEF-SPECIAL) ; a special variable
		 DEFAULT-VALUES
		 (NOT DEPENDENCY)
		 (VARS-USED (CONS 'PROGN DEFAULT-VALUES)
			    (LIST (VAR-NAME V))) )
	;; The special variable may be accessed by one of the default values.
	(SETQ DEPENDENCY T) )
      (WHEN (EQ (VAR-KIND V) 'FEF-ARG-OPT) ; an optional argument
	(INCF OPTIONAL-ARG-COUNT)
	(LET (( INIT (VAR-INIT V) ))
	  (UNLESS (AND (MEMBER (CAR INIT) '(FEF-INI-NONE FEF-INI-NIL) :TEST #'EQ) ; defaults to NIL
		       (NULL (CDDR INIT)) ; no supplied flag
		     )
	    (PUSH (VAR-INIT-FORM V) DEFAULT-VALUES) ) ) )
      (WHEN VALIDATE-TYPES-P
	(LET ((TYPE (VAR-DECLARED-TYPE V)))
	  (UNLESS (EQ TYPE 'T)
	    ;; Generate code to check that the value is consistent with the type declaration.
	    (PUSH `(OR (TYPEP ,(VAR-NAME V) ',TYPE)
		       (ARGUMENT-TYPE-ERROR ,(VAR-NAME V) ',(VAR-NAME V) ',TYPE))
		  BODY))))
      ) ; end of DOLIST
    (IF (OR (NULL (CDR DEFAULT-VALUES))	; no more than one test needed
	    DEPENDENCY)	; special binding must be done in particular order
	
	;;     generate a series of IFs
	
	(LET (( COUNT OPTIONAL-ARG-COUNT )
	      ( NUMBER-SUPPLIED '(%POP) )) ; last use pops the count
	  (DOLIST ( V VARS )
	    (WHEN (EQ V STOP) (RETURN))
	    (WHEN (AND (EQ (VAR-TYPE V) 'FEF-SPECIAL)
		       (NEQ (VAR-KIND V) 'FEF-ARG-AUX)) ; not a supplied flag
	      ;; This vars table entry is used for the original argument;
	      ;; another entry is made by the LET* for the special variable.
	      (SETF (VAR-TYPE V) 'FEF-LOCAL)
	      (LET (( NAME (VAR-NAME V) ))
		(SETQ BODY
		      `((LET* ( &SPECIAL ( ,NAME ,NAME ))
			  . ,BODY)) ) ) )
	    (WHEN (EQ (VAR-KIND V) 'FEF-ARG-OPT)
	      (DECF COUNT)
	      (LET* (( INIT (VAR-INIT V) )
		     ( DEFAULT (IF (MEMBER (CAR INIT) '(FEF-INI-NONE FEF-INI-NIL) :TEST #'EQ) 
				   NIL
				 `(SETQ ,(VAR-LAP-ADDRESS V) ,(SECOND INIT)) ) )
		     ( FLAG (AND (CDDR INIT)
				 `(SETQ ,(VAR-LAP-ADDRESS (CDDR INIT)) 'T)) ) )
		(WHEN (OR DEFAULT FLAG)
		  (PUSH `(IF (> ,NUMBER-SUPPLIED ,COUNT)
			     ;; Argument supplied - set flag variable
			     ,(MARK-P1-DONE FLAG)
			   ;; Else, assign default value
			   ,(MARK-P1-DONE DEFAULT) )
			BODY)
		  (WHEN (AND FLAG (SYMBOLP (SECOND FLAG)) )
		    ;; Bind special variable supplied flag
		    (SETQ BODY `((LET ((,(SECOND FLAG) NIL)) . ,BODY))) )
		  (SETQ NUMBER-SUPPLIED '(%DUP (%POP))) ; duplicate top of stack
		  ) ) ) ) )
      
      ;;     else, use a DISPATCH instruction
      
      (LET (( TEM NIL ) ; the body of the %DISPATCH form
	    ( ANY-INITS NIL )
	    ( COUNT OPTIONAL-ARG-COUNT )
	    ( SPECIAL-ARGS NIL ) ; list of names of special variable arguments
	    ( SUPPLIED-FLAGS NIL ))
	(DOLIST ( V VARS )
	  (WHEN (EQ V STOP) (RETURN))
	  (WHEN (EQ (VAR-TYPE V) 'FEF-SPECIAL)
	    (PUSH (VAR-NAME V) SPECIAL-ARGS)
	    ;; This vars table entry is used for the original argument;
	    ;; another entry is made below for the special variable.
	    (SETF (VAR-TYPE V) 'FEF-LOCAL) )
	  (WHEN (EQ (VAR-KIND V) 'FEF-ARG-OPT)
	    (PUSH COUNT TEM)
	    (DECF COUNT)
	    (LET (( INIT (VAR-INIT V) ))
	      (UNLESS (NULL (CDDR INIT))
		(LET (( ADDRESS (VAR-LAP-ADDRESS (CDDR INIT)) ))
		  (PUSH `(SETQ ,ADDRESS 'T)
			SUPPLIED-FLAGS)
		  (PUSH `(SETQ ,ADDRESS 'NIL)
			TEM) )
		(SETQ ANY-INITS T) )
	      (UNLESS (MEMBER (CAR INIT) '(FEF-INI-NONE FEF-INI-NIL) :TEST #'EQ) 
		(PUSH `(SETQ ,(VAR-LAP-ADDRESS V) ,(SECOND INIT))
		      TEM)
		(SETQ ANY-INITS T) ) )
	    ) )
	(UNLESS (NULL SPECIAL-ARGS)
	  ;; Bind special variables to their corresponding arguments.
	  (LET (( BINDING-LIST NIL ))
	    (DOLIST ( X SPECIAL-ARGS )
	      (PUSH (LIST X X)
		    BINDING-LIST) )
	    (SETQ BODY
		  `((LET* ( &SPECIAL . ,BINDING-LIST )
		      . ,BODY)) ) ) )
	(WHEN ANY-INITS
	  (PUSH (MARK-P1-DONE
		  `(%DISPATCH (%POP) ; dispatch selector = number of optionals supplied
			      ,OPTIONAL-ARG-COUNT  ; maximum selector value
			      NIL	   ; default action is to do nothing
			      0 . ,TEM) )  ; list of values and actions
		BODY)
	  (DOLIST ( X SUPPLIED-FLAGS ) ; initialize all supplied flags to T
	    (PUSH (MARK-P1-DONE X) BODY) ) ) )
      
      ) )
  
  ;;   Finally, return the augmented function body for processing by P1.
  
  BODY )

))

#!C
; From file P1FUNS.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1FUNS.#"


(DEFUN VAR-COMPUTE-INIT (HOME PARALLEL)
  (DECLARE (OPTIMIZE (SPEED 2)) (INLINE ADRREFP P1V))
  ;; 12/07/85 - Simplified for release 3 -- no more ADL.
  ;;  1/06/86 - Fix binding of special variable to (UNDEFINED-VALUE).
  ;;  6/02/86 - Report error on &REST arg with default value.
  ;;  7/02/86 - Allow BREAKOFF-FUNCTIONs to be value-propagated.
  ;;  7/30/86 - Fix to always call P1 for initial value so EXPRESSION-SIZE is incremented.
  ;;  2/04/87 DNG - Check for discrepency between declared type and initial value.
  ;; 11/11/87 DNG - Fix SPR 6881 by not propagating lexical variables altered in closures.
  ;;  8/04/88 DNG - Call P1 with P1VALUE bound to 'SINGLE-VALUE instead of 
  ;;		using P1V.  Remove obsolete VM1 code.
  ;;  4/22/89 DNG - When in Scheme mode, it is not safe to propagate FUNCTION 
  ;;		forms since they could really be global Scheme variables.
  ;;  4/28/89 DNG - Use new functions MAYBE-PROPAGATE and VAR-DECLARED-TYPE .
  ;;  5/03/89 DNG - Add option for run-time type checking.
  (LET* ( INIT-TYPE
	 ( INIT-DATA NIL )
	 ( NAME (VAR-NAME HOME) )
	 ( KIND (VAR-KIND HOME) )
	 ( TYPE (VAR-TYPE HOME) )
	 ( INIT-SPECS (VAR-INIT HOME) )
	 ( INIT-FORM (CAR INIT-SPECS) )
	 ( SPECIFIED-FLAG-NAME (CADR INIT-SPECS) ) )
    (DECLARE (TYPE SYMBOL NAME KIND TYPE))
	(COND ((OR (EQ KIND 'FEF-ARG-REQ)
		   (EQ KIND 'FEF-ARG-REST))
	       (UNLESS (NULL INIT-FORM)
		 (WARN 'BAD-ARGUMENT-LIST ':IMPOSSIBLE
		       "The ~A argument ~S was given a default value."
		       (IF (EQ KIND 'FEF-ARG-REQ) "required" "&REST")
		       NAME) )
	       (SETQ INIT-TYPE 'FEF-INI-NONE) )
	      ((NULL INIT-FORM)
	       (SETQ INIT-TYPE (IF (EQ KIND 'FEF-ARG-OPT)
				   'FEF-INI-NIL
				 'FEF-INI-COMP-C)))
	      ((OR (EQUAL INIT-FORM '(UNDEFINED-VALUE))
		   #+compiler:debug	   ; temporary while COMPILER2 package is used.
		   (EQUAL INIT-FORM '(COMPILER:UNDEFINED-VALUE)) )
	       (IF (EQ TYPE 'FEF-LOCAL)
		   (SETQ INIT-TYPE 'FEF-INI-NONE)
		 (SETQ INIT-FORM NIL
		       INIT-TYPE 'FEF-INI-COMP-C) ) )
	      (T (UNLESS (EQ PARALLEL 'DONT-P1)	   ; unless P1 was already applied
		   (LET ((TLEVEL NIL))
		     (SETQ INIT-FORM (LET ((P1VALUE 'SINGLE-VALUE))
				       (P1 INIT-FORM)))) )
		 (IF (AND (EQUAL INIT-FORM '(QUOTE NIL))
			  (EQ KIND 'FEF-ARG-OPT))
		     (SETQ INIT-TYPE 'FEF-INI-NIL)
		   (SETQ INIT-TYPE 'FEF-INI-COMP-C) )
		 (SETQ INIT-DATA INIT-FORM) ) )
    (UNLESS (EQ KIND 'FEF-ARG-OPT)
      ;; If something not an optional arg was given a specified-flag,
      ;; discard that flag now.  There has already been an error message.
      (SETQ SPECIFIED-FLAG-NAME NIL) )
    (WHEN (AND (EQ INIT-TYPE 'FEF-INI-COMP-C)
	       (VALIDATE-TYPES-P))
      (LET ((TYPE (VAR-DECLARED-TYPE HOME)))
	(UNLESS (EQ TYPE 'T)
	  ;; Generate code to check that the initial value conforms to the type declaration.
	  (SETQ INIT-DATA
		(P1V `(LET-FOR-LAMBDA ((.VALUE. ,(MARK-P1-DONE INIT-DATA)))
			(DECLARE (OPTIMIZE (SAFETY 0) (SPACE 2) (SPEED 1)))
			(IF (TYPEP .VALUE. ',TYPE)
			    .VALUE.
			  (ASSIGNMENT-TYPE-ERROR .VALUE. ',NAME ',TYPE)))))
	  (SETQ INIT-FORM INIT-DATA)
	  )))
    (SETF (VAR-INIT HOME)
	  (LIST* INIT-TYPE INIT-DATA
		 (AND SPECIFIED-FLAG-NAME
		      (DOLIST (V ALLVARS)
			(AND (EQ (VAR-NAME V) SPECIFIED-FLAG-NAME)
			     (MEMBER 'FEF-ARG-SPECIFIED-FLAG (VAR-MISC V))
			     (RETURN V))))))
    (WHEN (AND (EQ KIND 'FEF-ARG-INTERNAL-AUX)
	       (EQ TYPE 'FEF-LOCAL)
	       (OR (< (OPT-SAFETY OPTIMIZE-SWITCH) 2)
		   (EQ NAME '.VALUE.)) ; used in type checking
	       (EQ INIT-FORM INIT-DATA))
      (MAYBE-PROPAGATE HOME))
    (UNLESS (EQ KIND 'FEF-ARG-REQ)
      (BLOCK CHECK-DECLARATION
	(LET ((DECLARED-TYPE (VAR-DATA-TYPE HOME)))
	  (DECLARE (NOTINLINE VAR-DECLARED-TYPE))
	  (IF (OR (EQ DECLARED-TYPE 'T)
		  (NOT (TYPE-SPECIFIER-P DECLARED-TYPE *COMPILE-FILE-ENVIRONMENT*)))
	      (RETURN-FROM CHECK-DECLARATION)
	    (IF (OR (NULL INIT-FORM) (QUOTEP INIT-FORM))
		;; Note that TYPEP can only be used with the canonicalized type (not the 
		;; original source type) because it doesn't look in the compile-time environment.
		(IF (TYPEP (SECOND INIT-FORM) DECLARED-TYPE)
		    (RETURN-FROM CHECK-DECLARATION)
		  (WARN 'SI:DISJOINT-TYPEP ':IMPOSSIBLE
			"(DECLARE (TYPE ~S ~S) is inconsistent with its initial value of ~S."
			(VAR-DECLARED-TYPE HOME) NAME (SECOND INIT-FORM)) )
	      (LET ((INIT-TYPE (TYPE-OF-EXPRESSION INIT-FORM)))
		(IF (AND (NEQ INIT-TYPE 'T)
			 (SI:DISJOINT-TYPEP INIT-TYPE DECLARED-TYPE NIL *COMPILE-FILE-ENVIRONMENT*))
		    (WARN 'SI:DISJOINT-TYPEP ':IMPOSSIBLE
			  "~S is declared to be of type ~S but its initial value is a ~S."
			  NAME (VAR-DECLARED-TYPE HOME) INIT-TYPE)
		  (RETURN-FROM CHECK-DECLARATION)
		  ))))
	  (REMF (VAR-DECLARATIONS HOME) 'TYPE) ; discard the bad declaration
	  (SETF (VAR-DATA-TYPE HOME) 'T)
	  )))
    (IF (NULL INIT-FORM)
	NAME
      (LIST NAME INIT-FORM))))
))

#!C
; From file P2HAND.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P2HAND.#"


(DEFUN (:PROPERTY SI:STORE-KEYARGS P2) (ARGL DEST)
  ;;  5/04/89 DNG - Original, added to use aux-op %STORE-KEY-WORD-ARGS.
  ;; Note that this optimization must be done in pass 2 because 
  ;; EXTEND-LOCAL-VARIABLES could cause the STORE-KEYARGS to be moved to an 
  ;; internal function after pass 1 has finished.
  (IF (LET ((TM (FIRST ARGL))) ; the plist of actual keys and values
	;; Is it the rest arg of the current FEF?
	(AND (EQ (CAR-SAFE TM) 'LOCAL-REF)
	     (EQ (VAR-KIND (SETQ TM (SECOND TM))) 'FEF-ARG-REST)
	     (EQ (VAR-COMPILAND TM) *CURRENT-COMPILAND*)
	     #| -- on second thought, don't need this check because this has been in the microcode since 3.2.
	     ;; For release 6, don't use this if generating an object file that might be 
	     ;; loaded on an earlier release.
	     (OR #.(> (TIME:GET-UNIVERSAL-TIME) (TIME:PARSE-UNIVERSAL-TIME "1/1/90"))
		 QC-FILE-LOAD-FLAG FILE-IN-COLD-LOAD
		 (ASSOC (PACKAGE-NAME *PACKAGE*) SYS::INITIAL-PACKAGES :TEST #'EQUAL)
		 (> (OPT-SPEED OPTIMIZE-SWITCH) (OPT-SAFETY OPTIMIZE-SWITCH)))
              |#
	     ))
      ;; Can use the microcoded version.
      ;; rest arg is implicit
      (P2F `(%STORE-KEY-WORD-ARGS . ,(CDR ARGL)) DEST)
    ;; Else use Lisp version.
    (P2ARGC NIL ARGL NIL DEST 'SI:STORE-KEYARGS)))
))

#!C
; From file P1FUNS.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1FUNS.#"


(DEFUN MAYBE-PROPAGATE (HOME)
  ;; The argument should be a FEF-LOCAL FEF-ARG-INTERNAL-AUX variable.
  ;; If appropriate, enable propagation of the initial value and return true, else returns NIL.
  ;;  5/03/89 DNG - Original version of this function separated from VAR-COMPUTE-INIT .
  (LET ((INIT-DATA (VAR-INIT-FORM HOME)))
    (WHEN (OR (NULL INIT-DATA)
	      (AND (CONSP INIT-DATA)
		   (OR (MEMBER (FIRST INIT-DATA)
			       '(QUOTE BREAKOFF-FUNCTION) :TEST #'EQ)
		       (AND (EQ (FIRST INIT-DATA) 'FUNCTION)
			    (NOT (COMPILING-SCHEME-P)))
		       (AND (EQ (FIRST INIT-DATA) 'LOCAL-REF)
			    (LET ((V (SECOND INIT-DATA)))
			      ;; Need to make sure that the variable can't be altered
			      ;; by a lexical closure.  [SPR 6881]  This is over-kill,
			      ;; but is necessary because the current bookkeeping
			      ;; doesn't recognize that an arbitrary function call could
			      ;; end up invoking some lexical closure.
			      (AND (NOT (MEMBER 'FEF-ARG-ALTERED-IN-LEXICAL-CLOSURES ; from BREAKOFF
						(VAR-MISC V)))
				   (EQ (VAR-COMPILAND V) *CURRENT-COMPILAND*))))
		       )))
      ;; Record this variable as eligible to have references to it replaced 
      ;;  by the variable's initial value. 
      (SETQ PROPAGATE-VAR-SET (LOGIOR PROPAGATE-VAR-SET (CDDR (VAR-LAP-ADDRESS HOME))))
      (WHEN (EQ (FIRST INIT-DATA) 'LOCAL-REF)
	(SETQ SUBST-VAR-SET (LOGIOR SUBST-VAR-SET (CDDR INIT-DATA))) )
      T)))
))

#!C
; From file P1HAND.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1HAND.#"


(DEFUN MAP-VARIABLES-IN-SET (FUNCTION CHECK-SET VAR-LIST)
  ;;  5/3/89 DNG - Original.
  (UNLESS (ZEROP CHECK-SET)
    (DOLIST (V VAR-LIST (debug-assert nil nil "Didn't find variables in set #o~O" check-set))
      (WHEN (EQ (VAR-TYPE V) 'FEF-LOCAL)
	(LET ((ADDR (VAR-LAP-ADDRESS V)))
	  (WHEN (EQ (CAR-SAFE ADDR) 'LOCAL-REF)
	    (LET ((BIT (CDDR ADDR)))
	      (WHEN (LOGTEST BIT CHECK-SET)
		;; Found one of the variables in the set.
		(FUNCALL FUNCTION V BIT)
		(SETQ CHECK-SET (LOGDIF CHECK-SET BIT))
		(WHEN (ZEROP CHECK-SET)
		  ;; Found everything we were looking for.
		  (RETURN)))))))))
  (VALUES))
))