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

;;; Reason: Fix compilation of MAKE-INSTANCE methods for classes with :DEFAULT-INITARGS 
;;; values of T or NIL.  [SPR 10132]

;;;                           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 149149, M/S 2151             
;;;   AUSTIN, TEXAS 78714
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Patch file for COMPILER version 6.6
;;; Written 06/23/89 17:09:09 by GRAY,
;;; while running on Kelvin from band LOD2
;;; With Inconsistent SYSTEM 6.9, VIRTUAL-MEMORY 6.1, EH 6.3, MAKE-SYSTEM 6.0, MICRONET 6.0,
;;;  LOCAL-FILE 6.0, BASIC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.1,
;;;  NETWORK-NAMESPACE 6.0, DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.2, MAC-PATHNAME 6.0,
;;;  NETWORK-PATHNAME 6.0, Inconsistent COMPILER 6.5, TV 6.11, DATALINK 6.0, CHAOSNET 6.0,
;;;  GC 6.3, MEMORY-AUX 6.0, NVRAM 6.1, SYSLOG 6.1, STREAMER-TAPE 6.0, UCL 6.0, INPUT-EDITOR 6.0,
;;;  METER 6.0, ZWEI 6.3, Inconsistent DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.0,
;;;  DATALINK-DISPLAYS 6.0, FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.1, MAC-PRINTER-TYPES 6.1,
;;;  PRINTER-TYPES 6.0, IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.0,
;;;  TELNET 6.0, VT100 6.0, NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.2, Inconsistent TI-CLOS 6.9,
;;;  CLEH 6.4, IP 3.46, Experimental BUG 11.10, Experimental CLX 6.1, CLUE 6.5, X11M 6.1,
;;;  Experimental DOCUMENTER 619.0, Experimental GENASYS 3.0,  microcode 429, Band Name: 6.0 SLE 6/5 + u429 6/8

;;; BUG REPORT NUMBER:  10132
;;;
;;; PROBLEM:  
;;;	Incorrect code is compiled for a MAKE-INSTANCE method for a class
;;;	using the :DEFAULT-INITARGS option with a default value of NIL.
;;;	The init arg is given a default value of (QUOTE NIL) instead of
;;;	NIL.  For example:
;;;      
;;;	  (defclass cxy () (x)
;;;	    (:default-initargs :b nil))
;;;	  (defmethod initialize-instance :after ((object cxy) &key b)
;;;	    (setf (slot-value object 'x) b))
;;;	  (slot-value (make-instance 'cxy) 'x) => (QUOTE NIL) ; should be NIL
;;; 
;;; DIAGNOSIS:
;;;	This turns out to be a bug in function COMPILER:P1 -- the
;;;	optimization for FUNCALLing a constant function doesn't correctly
;;;	handle the possibility of new function call form optimizing to a
;;;	special form.  A simpler example of the problem can be seen by
;;;	compiling this:
;;;	  (defun fw () (funcall '#.#'false))
;;;
;;; SOLUTION:  
;;;	Fix P1 to check to see if the new form has optimized into a
;;;	special form; if so, then call P1 on it instead of just processing
;;;	the arguments.
;;;
;;; DEPENDENCIES:  [none]
;;;
;;; CODEREAD:  C.L.M.

#!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 (ORIGINAL-FORM &OPTIONAL DONT-OPTIMIZE)
  "Pass 1 compilation of a single Lisp form."
  ;; 12/27/84 - Improve EXPRESSION-SIZE update.
  ;; 12/28/84 - Don't increment use count of ignored variable.
  ;; 12/29/84 - Do increment use count of propagated variable.
  ;;  1/19/85 - NOTINLINE declaration forces call instead of 
  ;;		machine instruction and prevents DEFSUBST expansion.
  ;;  1/23/85 - Add check for cold load files.
  ;;  1/24/85 - Add use of P1-WITH-ANNOTATION.
  ;;  2/20/85 - Suppress constant folding on dead code.
  ;;  8/27/85 - Suprress T.R.E. on function defined by Misc-op.
  ;;  2/21/86 - Enable first arg of FUNCALL to be ephemeral closure.
  ;;  5/07/86 - Do NIL ==> (QUOTE NIL) without consing.
  ;;  6/16/86 - Check for higher level lexical variable before DEFCONSTANT to
  ;;		allow local shadowing with UNSPECIAL declaration. [SPR 2413]
  ;;  6/20/86 - Call EXPAND-LAMBDA directly instead of using P1LAMBDA.
  ;;  6/25/86 - Fix to handle (FUNCALL '#<DTP-FUNCTION ...> ...).
  ;;  7/02/86 - Change handling of non-local lexical variables.
  ;;  7/10/86 - Set SPECIAL-VAR-BIT in USED-VAR-SET on reference to free
  ;;		special variable; provide for inline expansion of local functions.
  ;;  7/17/86 - Allow inline expansion of local functions.
  ;;  7/25/86 - More changes for non-local variables.
  ;;  8/28/86 - Call to p1argc no longer passes result of getargdesc - just pass form
  ;;  9/09/86 - Increment use count of propagated BREAKOFF-FUNCTION.
  ;;  9/15/86 - Call MAYBE-INTEGRATE after POST-OPTIMIZE instead of before.
  ;;  9/16/86 - Record side-effects for arbitrary function calls.
  ;;  9/18/86 - Use FIX-FUNCALL-EVALUATION-ORDER on FUNCALL forms.
  ;;  9/20/86 - Add special handling for COMPILER-LET.
  ;;  9/24/86 - Pass saved ALLVARS as second arg to FIX-FUNCALL-EVALUATION-ORDER .
  ;; 10/18/86 - Permit tail recursion elimination of local functions.
  ;; 11/14/86 - Don't count BLOCK-FOR-PROG in EXPRESSION-SIZE.
  ;;  7/07/87 - Special handling for constants evaluated at load time. [SPR 4918]
  ;;  9/28/87 - Modified for Scheme. [Not included in this file until 3/15/89.]
  ;; 10/02/87 - Tail Recursion Elimination is always enabled in Scheme mode.
  ;;		Don't add special variable to FREEVARS when value is not being used.
  ;; 10/14/87 - Fixed bug in 9/28 change.
  ;; 11/14/87 - Add support for SCHEME:DEFINE-INTEGRABLE .
  ;;		Permit a FEF object to appear as the CAR of a form.
  ;; 11/21/87 - Permit keywords to be used as variable names in Scheme mode.
  ;; 12/19/87 - Fix use of symbol defined by SCHEME:DEFINE-INTEGRABLE in 
  ;;		function position.  Inline expansion of FUNCALL of a breakoff
  ;;		function.  Modified to facilitate tail recursion elimination on LETREC functions.
  ;;  1/09/88 - Add use of SCHEME:PCS-INTEGRATE-T-AND-NIL.
  ;;  2/10/88 - Add inherited vars argument to TAIL-RECURSION-ELIMINATION. [SPR 7113]
  ;; 12/16/88 - Fix to not optimize (FUNCALL 'symbol ...) when it has the same 
  ;;		name as a local function.
  ;;  4/22/89 - Update and uncomment the support for PCS-INTEGRATE-T-AND-NIL.
  ;;  4/25/89 - Add setting of COMPILAND-CONSTANTS-EXPANDED for SPR 6501.
  ;;  6/23/89 DNG - Fix optimization of (FUNCALL '#<DTP-FUNCTION > ...) so 
  ;;		that it correctly handles the possibility of the new call optimizing
  ;;		into a special form, such as QUOTE.  [SPR 10132]
  (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 2)))
  (LET (FORM TM NEW-SIZE NEW-FORM INDECL HANDLER)
    (IF (ATOM ORIGINAL-FORM)
	(SETQ FORM ORIGINAL-FORM)
      (IF (AND (COMPILING-SCHEME-P)
	       (TYPECASE (CAR ORIGINAL-FORM)
		 ( SYMBOL (IF (LOOKUP-VAR (CAR ORIGINAL-FORM) VARS)
			      (NOT (ASSOC (CAR ORIGINAL-FORM) LOCAL-FUNCTIONS :TEST #'EQ))
			    (NOT (OR (FBOUNDP (CAR ORIGINAL-FORM))
				     (EQ (GET (CAR ORIGINAL-FORM) 'INTEGRABLE '|<Undefined>|)
					 '|<Undefined>|)))) )
		 ( CONS (NOT (MEMBER (CAAR ORIGINAL-FORM) SI:FUNCTION-START-SYMBOLS :TEST #'EQ)))
		 ( T T)))
	  (SETQ FORM (CONS 'FUNCALL ORIGINAL-FORM))
	(PROGN
	  (WHEN (ATOM (CAR ORIGINAL-FORM))
	    (SETQ INDECL (INLINE-DECL (CAR ORIGINAL-FORM))) )
	  (SETQ FORM (PRE-OPTIMIZE ORIGINAL-FORM T
				   (OR DONT-OPTIMIZE
				       (AND (EQ INDECL 'NOTINLINE)
					    (NULL (GETL (CAR ORIGINAL-FORM)
							'(P1 P2))) ) ) ))
	  (WHEN (AND (NOT (EQ FORM ORIGINAL-FORM))
		     (CONSP FORM)
		     (NOT (SYMBOLP (CAR FORM)))
		     (COMPILING-SCHEME-P))
	    (SETQ FORM (CONS 'FUNCALL FORM)))
	  ) ) )
    (SETQ NEW-SIZE (+ EXPRESSION-SIZE 1-IF-LIVE-CODE))
    (COND
      ((ATOM FORM)
       (SETQ EXPRESSION-SIZE NEW-SIZE)
       (RETURN-FROM P1
	 (COND ((EQ FORM 'NIL) '(QUOTE NIL)) ; avoid consing for this common special case
	       ((EQ FORM 'T)   '(QUOTE T))
	       ((OR (NOT (SYMBOLP FORM))
		    (AND (KEYWORDP FORM) (NOT (COMPILING-SCHEME-P))))
		(LIST 'QUOTE FORM))	  ; constant other than a DEFCONSTANT
	       ((SETQ TM (LOOKUP-VAR FORM VARS)) ; found in table of local variables
		(IF (AND (NOT P1VALUE) (NOT DONT-OPTIMIZE))
		    ;; The value is not being used, so the reference is
		    ;; expected to be deleted by later optimizations.
		    ;; Don't increment the variable's use count and just
		    ;; return a dummy placeholder.
		    (PROGN (WHEN (NULL (VAR-USE-COUNT TM))
			     (SETF (VAR-USE-COUNT TM) 0))
			   '(QUOTE |<unused_var>|))
		  (PROGN ; a genuine variable reference
		    (SETQ NEW-FORM (VAR-LAP-ADDRESS TM))
		    (IF (AND (CONSP NEW-FORM)
			     (EQ (CAR NEW-FORM) 'LOCAL-REF))
			(IF (AND (LOGTEST (CDDR NEW-FORM) PROPAGATE-VAR-SET)
				 PROPAGATE-ENABLE )
			    (PROGN (SETQ NEW-FORM (VAR-INIT-FORM TM))
				   (COND ((NULL NEW-FORM)
					  (SETQ NEW-FORM '(QUOTE NIL)))
					 ((ATOM NEW-FORM))
					 ((EQ (CAR NEW-FORM) 'LOCAL-REF)
					  (VAR-INCREMENT-USE-COUNT (SECOND NEW-FORM))
					  (SETQ USED-VAR-SET
						(LOGIOR USED-VAR-SET (CDDR NEW-FORM))))
					 ((EQ (CAR NEW-FORM) 'BREAKOFF-FUNCTION)
					  (INCF (COMPILAND-USE-COUNT (SECOND NEW-FORM))))
					 (T (DEBUG-ASSERT (NO-SIDE-EFFECTS-P NEW-FORM))))
				   (WHEN (NULL (VAR-USE-COUNT TM))
				     (SETF (VAR-USE-COUNT TM) 0))
				   (RETURN-FROM P1 NEW-FORM))
			  (PROGN
			    (UNLESS (OR (NULL *VAR-LEVEL-COUNTS*)
					(ZEROP 1-IF-LIVE-CODE))
			      (LET (( VC (VAR-COMPILAND TM) ))
				(UNLESS (EQ VC *CURRENT-COMPILAND*)
				  (INCF (NTH (COMPILAND-NESTING-LEVEL VC)
					     *VAR-LEVEL-COUNTS*)
					(LOOP-WEIGHTED-INCREMENT *LOOP-LEVEL*)
				    ))))
			    (SETQ USED-VAR-SET (LOGIOR USED-VAR-SET (CDDR NEW-FORM)))
			    ))
		      (WHEN (SYMBOLP NEW-FORM)
			(WHEN (OR (EQ (VAR-KIND TM) 'FEF-ARG-FREE)
				  (NEQ (VAR-COMPILAND TM) *CURRENT-COMPILAND*))
			  (UNLESS (ZEROP 1-IF-LIVE-CODE)
			    (PUSHNEW NEW-FORM FREEVARS :TEST 'EQ) ) )
			(UNLESS (LOGTEST SPECIAL-VAR-BIT USED-VAR-SET)
			  (SETF USED-VAR-SET (LOGIOR USED-VAR-SET SPECIAL-VAR-BIT)))))
		    (VAR-INCREMENT-USE-COUNT TM)
		    NEW-FORM) ))
	       ((AND SELF-FLAVOR-DECLARATION
		     (TRY-REF-SELF FORM)))
	       ((AND (COMPILING-SCHEME-P)
		     (OR (FBOUNDP FORM)
			 (UNLESS (EQ (SETQ TM (GET FORM 'INTEGRABLE '|<Undefined>|))
				     '|<Undefined>|)
			   (PUSHNEW FORM MACROS-EXPANDED :TEST #'EQ)
			   (RETURN-FROM P1 (P1 TM DONT-OPTIMIZE)))
			 (WHEN (EQ (SYMBOL-PACKAGE FORM) *KEYWORD-PACKAGE*)
			   (RETURN-FROM P1 (LIST 'QUOTE FORM)))
			 (NOT (SPECIALP FORM T))))
		(LOCALLY ;; The values of the these are assigned when the Scheme system is loaded.
		  (declare (special PCS-INTEGRATE-T-AND-NIL SCHEME-T SCHEME-NIL))
		  (COND ((AND (EQ FORM SCHEME-T) PCS-INTEGRATE-T-AND-NIL)
			 '(QUOTE T))
			((AND (EQ FORM SCHEME-NIL) PCS-INTEGRATE-T-AND-NIL)
			 '(QUOTE NIL))
			(T (UNLESS (LOGTEST SPECIAL-VAR-BIT USED-VAR-SET)
			     (SETF USED-VAR-SET (LOGIOR USED-VAR-SET SPECIAL-VAR-BIT)))
			   `(FUNCTION ,FORM)))))
	       ((BLOCK CONSTANT?
		  (AND (< (OPT-SAFETY OPTIMIZE-SWITCH) 2)
		       (NOT DONT-OPTIMIZE)
		       (LET ( CONST )
			 (COND ((SETQ CONST (ASSOC FORM FILE-CONSTANTS-LIST :TEST #'EQ))
				(SETQ TM (CDR CONST)) )
			       ((AND (SETQ CONST (GET-FOR-TARGET FORM 'SYSTEM-CONSTANT))
				     (NOT (EQ CONST 'COMPILER:QC-PROCESS-INITIALIZE))
				     ;; DEFCONSTANT, not a machine-dependent constant
				     (BOUNDP-FOR-TARGET FORM))
				(SETQ TM (SYMEVAL-FOR-TARGET FORM)) )
			       (T (RETURN-FROM CONSTANT? NIL)) )
			 (OR (NUMBERP TM)
			     (SYMBOLP TM)
			     (CHARACTERP TM) ) ) ) )
		(SETF (GETF (COMPILAND-CONSTANTS-EXPANDED *CURRENT-COMPILAND*) FORM) TM)
		(LIST 'QUOTE TM))
	       (T (IF P1VALUE
		      (PROGN (MAKESPECIAL FORM)
			     (UNLESS (LOGTEST SPECIAL-VAR-BIT USED-VAR-SET)
			       (SETF USED-VAR-SET (LOGIOR USED-VAR-SET SPECIAL-VAR-BIT))))
		    (LET ((FREEVARS FREEVARS)) 
		      (MAKESPECIAL FORM)))
		  FORM))))
      ((EQ (CAR FORM) 'QUOTE)
       (SETQ EXPRESSION-SIZE NEW-SIZE)
       (RETURN-FROM P1 (IF (AND QC-FILE-IN-PROGRESS
				(NOT QC-FILE-LOAD-FLAG)
				(CONSP (SECOND FORM))
				(LOAD-TIME-EVAL-P (SECOND FORM) 0) )
			   `(QUOTE-LOAD-TIME-EVAL ,FORM) ; hide the value from optimization
			 FORM)))
      ;; Certain constructs must be checked for here
      ;; so we can call P1 recursively without setting TLEVEL to NIL.
      ((NOT (ATOM (CAR FORM)))
       (LET ((FCTN (CAR FORM)))
	 (UNLESS (SYMBOLP (CAR FCTN))
	   (WARN 'BAD-FUNCTION-CALLED ':IMPOSSIBLE
		 "There appears to be a call to a function whose CAR is ~S."
		 (CAR FCTN)))
	 (COND ((MEMBER (CAR FCTN)
			'(GLOBAL:LAMBDA GLOBAL:NAMED-LAMBDA CLI:LAMBDA NAMED-LAMBDA)
			:TEST #'EQ)
		;;added extra arg to expand lambda to indicate that args not processed
		(RETURN-FROM P1
		  (P1 (EXPAND-LAMBDA FCTN (CDR FORM) NIL nil)) ))
	       (T ;; Old Maclisp evaluated functions.
		(WARN 'EXPRESSION-AS-FUNCTION ':VERY-OBSOLETE
		      "The expression ~S is used as a function; use FUNCALL."
		      (CAR FORM))
		(RETURN-FROM P1 (P1 `(FUNCALL . ,FORM)))))))
      ((NOT (SYMBOLP (CAR FORM)))
       (WARN 'BAD-FUNCTION-CALLED ':IMPOSSIBLE
	     "~S is used as a function to be called." (CAR FORM))
       (RETURN-FROM P1 (P1 (CONS 'PROGN (CDR FORM)))))
      )
    (SETQ NEW-FORM
	  (COND
	    ((SETQ TM (ASSOC (CAR FORM) LOCAL-FUNCTIONS :TEST #'EQ))
	     ;; local function defined by FLET or LABELS
	     (SETQ NEW-FORM (P1EVARGS FORM))
	     (SETQ EXPRESSION-SIZE NEW-SIZE)
	     (OR (AND (EQ (COMPILAND-DEFINITION *CURRENT-COMPILAND*)
			  (THIRD TM)) ; function is calling itself
		      (CONSP P1VALUE)
		      (LET ((X (ASSOC (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*)
				      P1VALUE :TEST #'EQ)))
			(AND X ; this is a tail recursive call
			     (MEMBER X TRE-OK :TEST #'EQ) ; no special bindings in effect
			     (<= (OPT-SAFETY OPTIMIZE-SWITCH) (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))
			     (SECOND X) ; loop-back tag provided
			     (NOT DONT-OPTIMIZE)
			     (TAIL-RECURSION-ELIMINATION
			       NEW-FORM (SECOND X) (THIRD X) (FIFTH X)) )))
		 `(FUNCALL ,(REF-LOCAL-FUNCTION-VAR (SECOND TM))
			   . ,(CDR NEW-FORM)) ))
	    ((MEMBER (CAR FORM) '(LET LET*) :TEST #'EQ)
	     (P1-WITH-ANNOTATION FORM #'P1LET 'UNKNOWN DONT-OPTIMIZE))
	    ((EQ (CAR FORM) 'BLOCK)
	     (P1-WITH-ANNOTATION FORM #'P1BLOCK 'UNKNOWN DONT-OPTIMIZE))
	    ((EQ (CAR FORM) 'TAGBODY)
	     (P1-WITH-ANNOTATION FORM #'P1TAGBODY 'NULL DONT-OPTIMIZE))
	    ((EQ (CAR FORM) '%POP) FORM )	;P2 specially checks for this
	    ((EQ (CAR FORM) 'COMPILER-LET)
	     ;; handled specially here so that the result will not be re-optimized
	     ;; after the bindings are un-done.
	     (RETURN-FROM P1
	       (SI:EVAL1 `(COMPILER-LET ,(SECOND FORM)
			    (P1 '(PROGN . ,(CDDR FORM))) ))))
	    ((SETQ TLEVEL NIL))
	    ((EQ (CAR FORM) 'COND)
	     (P1-WITH-ANNOTATION FORM #'P1COND 'UNKNOWN DONT-OPTIMIZE))
	    ;; Check for functions with special P1 handlers.
	    ((AND (SETQ HANDLER (GET (CAR FORM) 'P1))
		  (OR (NEQ INDECL 'NOTINLINE)
		      (NOT (MEMBER HANDLER '(P1SIMPLE P1-DOWNWARD-FUNARG
					     P1-DOWNWARD-FUNARG-DESTRUCTIVE) :TEST #'EQ))) )
	     (UNLESS (MEMBER (CAR FORM)
			     '( PROGN IGNORE P1-HAS-BEEN-DONE RETURN-FROM %BLOCK-BODY
			        #+compiler:debug P1-ALREADY-DONE ; this one is obsolete 9/19/86
				COMPILER-LET BLOCK-FOR-PROG
				)
			     :TEST #'EQ)
	       (SETQ EXPRESSION-SIZE NEW-SIZE) )
	     (FUNCALL HANDLER FORM))
	    ((AND ALLOW-VARIABLES-IN-FUNCTION-POSITION-SWITCH
		  (LOOKUP-VAR (CAR FORM) VARS)
		  (NULL (FUNCTION-P (CAR FORM))))
	     (WARN 'EXPRESSION-AS-FUNCTION ':VERY-OBSOLETE
		   "The variable ~S is used in function position; use FUNCALL."
		   (CAR FORM))
	     (RETURN-FROM P1 (P1 (CONS 'FUNCALL FORM))))
	    ((EQ (CAR FORM) 'FUNCALL)
	     (SETQ TM (COMPILAND-CHILDREN *CURRENT-COMPILAND*))
	     (LET (( F (LET (( P1VALUE 'DOWNWARD-ONLY ))
			 (P1 (SECOND FORM)) )))
	       (COND ((AND (CONSP F)
			   (MEMBER (FIRST F) '(QUOTE FUNCTION) :TEST #'EQ)
			   (NOT DONT-OPTIMIZE)
			   (OR (SYMBOLP (SECOND F))
			       (CONSP (SECOND F)))
			   (NOT (ASSOC (SECOND F) LOCAL-FUNCTIONS :TEST #'EQUAL)) ; 12/16/88
			   (FUNCTIONP (SECOND F)) )
		      ;; (FUNCALL #'f a b) ==> (f a b)
		      ;; (FUNCALL #'(LAMBDA ...) a b) ==> ((LAMBDA ...) a b)
		      (RETURN-FROM P1 (P1 (CONS (SECOND F) (CDDR FORM)))))
		     ((AND (QUOTEP F)
			   (FUNCTIONP (SECOND F) NIL)
			   (SYMBOLP (SETQ TM (FUNCTION-NAME (SECOND F))))
			   (FBOUNDP TM)
			   (EQ (SYMBOL-FUNCTION TM) (SECOND F))
			   (NOT DONT-OPTIMIZE)
			   (EXTERNAL-SYMBOL-P TM))
		      ;; ('#<DTP-FUNCTION fn ...> a b)  ==> (fn a b)
		      ;; This idiom is used by some Scheme macros to ensure access to the 
		      ;; global definition.
		      (SETQ EXPRESSION-SIZE NEW-SIZE)
		      (SETQ FORM (PRE-OPTIMIZE (CONS TM (CDDR FORM))
					       T (EQ (SETQ INDECL (GET TM 'INLINE)) 'NOTINLINE)))
		      (COND ((ATOM FORM) FORM)
			    ((SPECIAL-FORM-P (CAR FORM))
			     (RETURN-FROM P1 (P1 FORM)))
			    (T (FUNCALL (SETQ HANDLER (GET (CAR FORM) 'P1 'P1ARGC)) FORM)))
		      )
		     (T (SETQ EXPRESSION-SIZE NEW-SIZE)
			(WHEN (AND (MEMBER (CAR-SAFE F) '(BREAKOFF-FUNCTION LEXICAL-CLOSURE))
				   (EQ (SECOND F) (FIRST (COMPILAND-CHILDREN *CURRENT-COMPILAND*)))
				   (EQ TM (REST (COMPILAND-CHILDREN *CURRENT-COMPILAND*))))
			  ;; Encourage PROCEDURE-INTEGRATION.
			  (SETF (GETF (COMPILAND-PLIST (SECOND F)) 'USED-ONLY-ONCE) T))
			(PROG1 (LET ((SAVE-ALLVARS ALLVARS))
				 (FIX-FUNCALL-EVALUATION-ORDER
				   (CONS 'FUNCALL (P1EVARGS (CONS F (CDDR FORM))))
				   SAVE-ALLVARS))
			       (ARBITRARY-SIDE-EFFECTS))) )) )
	    ( T	  ; general function
	     (SETQ EXPRESSION-SIZE NEW-SIZE)
	     (UNLESS (NULL (CDR FORM))
	       (SETQ FORM (P1ARGC FORM ) ))
	     (COND
	       ((AND (CONSP P1VALUE)  ; still has initial value from QCOMPILE1
		     (SETQ TM (ASSOC (CAR FORM) P1VALUE :TEST #'EQ))
						; this is a tail recursive call
		     (OR (EQL (OPT-SAFETY OPTIMIZE-SWITCH) 0) ; user permits optimizing
			 (COMPILING-SCHEME-P))	; Scheme users expect this to happen.
		     (MEMBER TM TRE-OK :TEST #'EQ)	 ; no special bindings in effect
		     TRE-ENABLE 
		     (NOT DONT-OPTIMIZE)
		     (NOT (GETL (CAR FORM)
				'(P2 OPCODE))) ; not expanded by pass 2
		     (TAIL-RECURSION-ELIMINATION
		       FORM (SECOND TM) (THIRD TM) (FIFTH TM) ) ))
	       ((AND (SETQ TM (ASSOC (CAR FORM) INLINE-EXPANSIONS :TEST #'EQ))
		     (NEQ (FIRST TM) (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*)) )
		;; 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) ); the CATCH is in function PROCEDURE-INTEGRATION
	       ((AND (EQ INDECL 'NOTINLINE)
		     (EQ (CAR ORIGINAL-FORM) (CAR FORM)) )
		(SETQ DONT-OPTIMIZE INDECL)
		(ARBITRARY-SIDE-EFFECTS)
		(IF (AND (GET (CAR FORM) 'P2)
			 (FUNCTIONP (CAR FORM)) )
		    `(FUNCALL (FUNCTION ,(CAR FORM)) . ,(CDR FORM))
		  FORM) )
	       (T (SETQ HANDLER 'P1ARGC)
		  FORM) )
	    )))
    ;; Apply post-optimizations
    (UNLESS (OR DONT-OPTIMIZE
		;; Don't optimize dead code -- not only to avoid
		;; wasting time, but because constant folding could
		;; get an argument type error which would be irrelevant.
		(ZEROP 1-IF-LIVE-CODE))
      (SETQ TM (POST-OPTIMIZE NEW-FORM))
      (WHEN (AND (MEMBER HANDLER '(P1ARGC P1-DOWNWARD-FUNARG P1-DOWNWARD-FUNARG-DESTRUCTIVE) :TEST #'EQ)
		 (OR (EQ TM NEW-FORM)
		     (NOT (TRIVIAL-FORM-P TM))))
	;; possibility of inline expansion of the called function
	(SETQ FORM (IF (OR (EQ (CAR ORIGINAL-FORM) (CAR TM))
			   (EQ INDECL 'INLINE))
		       (MAYBE-INTEGRATE (CAR TM) (CDR TM) NIL INDECL)
		     (MAYBE-INTEGRATE (CAR TM) (CDR TM)) ))
	(UNLESS (NULL FORM)
	  (SETQ TM (POST-OPTIMIZE FORM))
	  (SETQ HANDLER NIL)))
      (WHEN (NEQ NEW-FORM TM)
	(SETQ HANDLER NIL) ; don't update var sets below
	(SETQ NEW-FORM TM)
	(WHEN (TRIVIAL-FORM-P NEW-FORM)
	  ;; optimized down to just a constant or variable --
	  ;; count its size as only 1
	  (SETQ EXPRESSION-SIZE NEW-SIZE)
      ) ) )
    (WHEN (AND INLINE-EXPANSIONS
	       (> EXPRESSION-SIZE EXPRESSION-SIZE-LIMIT) )
      ;; inline expansion of function call has become too big 
      ;;  to be desirable -- abort back to CATCH in
      ;;  function PROCEDURE-INTEGRATION
      (THROW (SECOND (FIRST INLINE-EXPANSIONS)) 'SIZE) )
    (WHEN (EQ HANDLER 'P1ARGC)
      (BLOCK USE-SPECIAL
	(UNLESS (LOGTEST SPECIAL-VAR-BIT USED-VAR-SET)
	  (WHEN (FUNCTION-WITHOUT-SIDE-EFFECTS-P (FIRST NEW-FORM))
	    (RETURN-FROM USE-SPECIAL))
	  (SETF USED-VAR-SET (LOGIOR USED-VAR-SET GLOBAL-SIDE-EFFECTS)))
	(UNLESS (OR (LOGTEST DATA-ALTERATION-BIT ALTERED-VAR-SET)
		    (FUNCTION-WITHOUT-SIDE-EFFECTS-P (FIRST NEW-FORM)))
	  (SETF ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET GLOBAL-SIDE-EFFECTS)))))
    (WHEN (AND SI:FILE-IN-COLD-LOAD ; Current file has attribute COLD-LOAD:T
	       (CONSP NEW-FORM)
	       (NOT (ZEROP 1-IF-LIVE-CODE))
	       (NOT (AND (SYMBOLP (FIRST NEW-FORM))
			 (GETL (FIRST NEW-FORM) '(P2 OPCODE)))) )
      (CHECK-COLD (FIRST NEW-FORM)) )
    (RETURN-FROM P1 NEW-FORM)
    ))

))