;;; -*- Mode:Common-Lisp; Package:Compiler; Base:10; Fonts:(CPTFONT CPTFONTB HL12BI); Patch-file:T -*-

Ï2;;; Ï*      Ï2Explorer compiler changes for running Scheme on release 3, 4, or 5.
;;;Ï*	Ï2 These patches are not applicable to release 6 or later.Ï*
;;;
;;; The changes made to existing functions for Scheme are in boldface.

;;; Copyright (C) 1988, Texas Instruments Incorporated. All rights reserved.

;;  3/22/88 DNG - Fix to not propagate a local variable whose initial value is 
;;		a global Scheme variable.
;;  4/13/88 DNG - Moved EXPORT to file PCS.
;;  8/11/88 DNG - Add warning for incompatibility with Explorer release 6.
;;  4/22/89 DNG - New file "OLD-COMPILER" separated from "COMPILER".

(multiple-value-bind (major minor)
    (si:get-system-version :compiler)
  (unless (and major (>= major 3))
    (error Ï2"This file requires Explorer release 3 or later."Ï*))
  (when (eql major 3)
    (unless (>= minor 42) ; Scheme requires Compiler patches 3.37 and 3.42
      (load-patches :compiler :noselective))
    )
  (when (>= major 6)
    ;; Because some of these patches change functions that will be changed again for CLOS ...
    (cerror "Try to load it anyway."
	    "This version of Scheme won't work on release ~S.
In fact, loading it is likely to break the Common Lisp compiler.
You should get the version of Scheme from the PUBLIC directory for release ~S."
	    major major))
  )

Ï1(DEFSUBST COMPILING-SCHEME-P ()
  (EQ COMPILING-COMMON-LISP ':SCHEME))Ï*

(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]
Ï1  ;;  9/28/87 - Modified for Scheme.
  ;; 10/02/87 - Tail Recursion Elimination is always enabled in Scheme mode.
  ;;Ï*		Ï1Don't add special variable to FREEVARS when value is not being used.Ï*
  Ï1;; 10/14/87 - Fixed bug in 9/28 change.
  ;; 11/14/87 - Add support for SCHEME:DEFINE-INTEGRABLEÏ* Ï1.
  ;;Ï*		Ï1Permit 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 
  ;;Ï*		Ï1function position.  Inline expansion of FUNCALL of a breakoff
  ;;Ï*		Ï1function.  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]
  Ï1;; 12/16/88 - Fix to not optimize (FUNCALL 'symbol ...) when it has the same 
  ;;Ï*		Ï1name as a local function.Ï*
  (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 2)))
  (LET (FORM TM NEW-SIZE NEW-FORM INDECL HANDLER)
    (IF (ATOM ORIGINAL-FORM)
	(SETQ FORM ORIGINAL-FORM)
      Ï1(IF (AND (COMPILING-SCHEME-P)Ï*
		 Ï1(TYPECASE (CAR ORIGINAL-FORM)Ï*
		    Ï1( SYMBOL (IF (LOOKUP-VAR (CAR ORIGINAL-FORM) VARS)Ï*
				   Ï1(NOT (ASSOC (CAR ORIGINAL-FORM) LOCAL-FUNCTIONS :TEST #'EQ))Ï*
				 Ï1(NOT (OR (FBOUNDP (CAR ORIGINAL-FORM))Ï*
					    Ï1(EQ (GET (CAR ORIGINAL-FORM) 'INTEGRABLE '|<Undefined>|)Ï*
						 Ï1'|<Undefined>|))))Ï* )
		    Ï1( CONS (NOT (MEMBER (CAAR ORIGINAL-FORM) SI:FUNCTION-START-SYMBOLS :TEST #'EQ)))Ï*
		    Ï1( T T)))Ï*
	Ï1   (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))) ) ) ))
	   Ï1(WHEN (AND (NOT (EQ FORM ORIGINAL-FORM))Ï*
		        Ï1(CONSP FORM)Ï*
			Ï1(NOT (SYMBOLP (CAR FORM)))Ï*
			Ï1(COMPILING-SCHEME-P))Ï*
	      Ï1(SETQ FORM (CONS 'FUNCALL FORM)))Ï*
	   )Ï1 )Ï* )
    (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))
		    Ï1(ANDÏ* (KEYWORDP FORM) Ï1(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 (SECOND (VAR-INIT 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)))
	       Ï1((AND (COMPILING-SCHEME-P)Ï*
		Ï1      (OR (FBOUNDP FORM)Ï*
			Ï1   (UNLESS (EQ (SETQ TM (GET FORM 'INTEGRABLE '|<Undefined>|))Ï*
					Ï1 '|<Undefined>|)Ï*
			Ï1      (PUSHNEW FORM MACROS-EXPANDED :TEST #'EQ)Ï*
			Ï1      (RETURN-FROM P1 (P1 TM DONT-OPTIMIZE)))Ï*
			Ï1    (WHEN (EQ (SYMBOL-PACKAGE FORM) *KEYWORD-PACKAGE*)Ï*
			Ï1      (RETURN-FROM P1 (LIST 'QUOTE FORM)))Ï*
			Ï1   (NOT (SPECIALP FORM T))))Ï*
		 Ï1(COND ((AND (EQ FORM 'SCHEME:T)Ï* Ï1SCHEME:PCS-INTEGRATE-T-AND-NIL)Ï*
			Ï1 '(QUOTE T))Ï*
		Ï1        ((AND (EQ FORM 'SCHEME:NIL)Ï* Ï1SCHEME:PCS-INTEGRATE-T-AND-NIL)Ï*
			Ï1  '(QUOTE NIL))Ï*
			Ï1(T (UNLESS (LOGTEST SPECIAL-VAR-BIT USED-VAR-SET)Ï*
			Ï1      (SETF USED-VAR-SET (LOGIOR USED-VAR-SET SPECIAL-VAR-BIT)))Ï*
			Ï1    `(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) ) ) ) )
		(LIST 'QUOTE TM))
	       (T Ï1(IF P1VALUEÏ*
		      Ï1(PROGNÏ* (MAKESPECIAL FORM)
			     (UNLESS (LOGTEST SPECIAL-VAR-BIT USED-VAR-SET)
			       (SETF USED-VAR-SET (LOGIOR USED-VAR-SET SPECIAL-VAR-BIT)))Ï1)Ï*
		    Ï1(LET ((FREEVARS FREEVARS)) Ï*
		Ï1      (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)) ))
	    #-Elroy ; PROG is a macro in release 3
	    ((MEMBER (CAR FORM) '(PROG PROG*) :TEST #'EQ)
	     (P1PROG 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)
	     Ï1(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)))
			   Ï1(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)))))
		     Ï1((AND (QUOTEP F)Ï*
			    Ï1(FUNCTIONP (SECOND F) NIL)Ï*
			    Ï1(SYMBOLP (SETQ TM (FUNCTION-NAME (SECOND F))))Ï*
			    Ï1(FBOUNDP TM)Ï*
			    Ï1(EQ (SYMBOL-FUNCTION TM) (SECOND F))Ï*
			    Ï1(NOT DONT-OPTIMIZE)Ï*
			    Ï1(EXTERNAL-SYMBOL-P TM))Ï*
		       Ï1;; ('#<DTP-FUNCTION fn ...> a b)  ==> (fn a b)Ï*
		       Ï1;; This idiom is used by some Scheme macros to ensure access to the Ï*
		       Ï1;; global definition.Ï*
		       Ï1(SETQ EXPRESSION-SIZE NEW-SIZE)Ï*
		Ï1      (SETQ FORM (PRE-OPTIMIZE (CONS TM (CDDR FORM))Ï*
						Ï1  T (EQ (SETQ INDECL (GET TM 'INLINE)) 'NOTINLINE)))Ï*
		Ï1       (FUNCALL (GET (CAR FORM) 'P1 #'P1EVARGS) FORM)Ï*
		       Ï1)Ï*
		     (T (SETQ EXPRESSION-SIZE NEW-SIZE)
			Ï1(WHEN (AND (MEMBER (CAR-SAFE F) '(BREAKOFF-FUNCTION LEXICAL-CLOSURE))Ï*
				     Ï1(EQ (SECOND F) (FIRST (COMPILAND-CHILDREN *CURRENT-COMPILAND*)))Ï*
				     Ï1(EQ TM (REST (COMPILAND-CHILDREN *CURRENT-COMPILAND*))))Ï*
			Ï1   ;; Encourage PROCEDURE-INTEGRATION.Ï*
			   Ï1(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
		     Ï1(ORÏ* (EQL (OPT-SAFETY OPTIMIZE-SWITCH) 0) ; user permits optimizing
			 Ï1(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
				  #-Elroy compiler:QINTCMP ; temporary
				  #+Elroy 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)
    ))

(DEFUN P2-DESTINATION (FORM)
 ;; 12/26/84 DNG - New function created -- similar to P2-SOURCE, but the
 ;;                form is a variable which will be altered by the instruction.
 ;;  3/29/85 DNG - Add call to SELF-REF-POINTER.
 ;;  9/13/85 DNG - Remove mapping table checking; allow IVAR destination
 ;;                address for release 3.
 ;; 12/22/86 DNG - Fix for LEXICAL-REF re-allocated by EXTEND-LOCAL-VARIABLES.
Ï1 ;;  9/29/87 DNG - For Scheme, allow symbol function cell to be used as a destination.Ï*
  (COND ((ATOM FORM)
	 (IF (NULL FORM)
	     (BARF FORM "Bad destination variable in pass 2" 'BARF)
	   `(SPECIAL ,FORM)))
	((EQ (CAR FORM) 'LOCAL-REF)
	 (LET ((A (VAR-LAP-ADDRESS (SECOND FORM))))
	   (IF (EQ (CAR A) 'LEXICAL-REF) ; variable re-allocated by EXTEND-LOCAL-VARIABLES 
	       (P2-SOURCE A 'D-STORE)
	     A)))
	((AND (EQ (CAR FORM) 'SELF-REF)	   ; flavor instance variable
	      (COMPILING-FOR-V2)
	      IVAR-ADDRESS-ENABLE
	      (<= (OPT-SAFETY OPTIMIZE-SWITCH)
		  (OPT-SPEED OPTIMIZE-SWITCH))
	      (NOT (AND QC-FILE-IN-PROGRESS
			(NOT QC-FILE-LOAD-FLAG)))
	      (LET* ((SRP (SI:FLAVOR-VAR-SELF-REF-INDEX (CDR FORM)))
		     (INDEX (LDB %%SELF-REF-INDEX SRP)))
		(AND (NOT (LDB-TEST %%SELF-REF-MAP-LEADER-FLAG SRP))
		     (< INDEX 32)
		     (IF (LDB-TEST %%SELF-REF-RELOCATE-FLAG SRP)
			 (IF (< INDEX 24)
			     `(SELF-MAP ,INDEX)
			   NIL)
		       `(SELF-UNMAPPED ,INDEX))))))
	((EQ (CAR FORM) 'SELF-REF)
	 `(QUOTE-VECTOR ,FORM))
	Ï1((EQ (CAR FORM) 'FUNCTION) ; this is used only by SCHEME:SET!Ï*
	Ï1 `(QUOTE-VECTOR ,FORM))Ï*
	(T (BARF FORM "Bad destination variable in pass 2" 'BARF)) ))

(DEFUN FUNCTION-REFERENCED (WHAT BY)
  ;; Collect functions referenced
  ;;  3/14/86 DNG - Don't use FUNCTION-P when cross-compiling without defaulting.
  Ï1;; 10/02/87 DNG - Updated to give more meaningful function names when compiling Scheme.Ï*
  (UNLESS (AND (OR *DEFAULT-DEFS-FROM-HOST*
		   (EQ TARGET-PROCESSOR HOST-PROCESSOR))
	       (FUNCTION-P WHAT))		;defined in QCP1
    (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)
	  (ENTRY (ASSOC WHAT FUNCTIONS-REFERENCED :TEST #'EQUAL)))
Ï1      ;; maybe the following changes to BY should be done somewhere higher up instead?Ï*
      Ï1(WHEN (OR (NULL BY)Ï*
		  Ï1(AND (CONSP BY)Ï*
		        Ï1(EQ (FIRST BY) ':INTERNAL)Ï*
			Ï1(LISTP (SECOND BY))))Ï*
	 Ï1(SETQ BY (COMPILAND-FUNCTION-NAME *CURRENT-COMPILAND*)))Ï*
      Ï1(WHEN (AND (CONSP BY)Ï*
		   Ï1(EQ (FIRST BY) ':INTERNAL)Ï*
		   Ï1(SYMBOLP (SECOND BY))Ï*
		   Ï1(SYMBOLP (THIRD BY))Ï*
		   Ï1(OR (NULL (SECOND BY))Ï*
		        Ï1(NULL (SYMBOL-PACKAGE (SECOND BY)))))Ï*
	 Ï1;; Replace (:INTERNAL #:G0000 FOO) with FOO since the rest is not useful.Ï*
	 Ï1(SETQ BY (THIRD BY)))Ï*
      (SETQ BY (COPY-TREE BY))	;Could be (:METHOD ...)
      (IF ENTRY
	  (RPLACD ENTRY (CONS BY (CDR ENTRY)))
	(PUSH (LIST (COPY-TREE WHAT) BY) FUNCTIONS-REFERENCED)))))

;Turn an internal lambda containing &AUX variables
;into one containing a LET* and having no &AUX variables.
(DEFUN P1AUX ( LAMBDA AGAIN-TAG )
  ;; AGAIN-TAG, if not NIL, is a tag to be inserted for Tail Recursion Elim.
  ;;  5/31/86 DNG - Modify to not copy the arglist unless necessary.
  ;;  6/18/86 DNG - Don't duplicate the declarations when there aren't any aux vars.
  ;;  8/27/86 DNG - Dummy declaration (.ARG.).
  (LET (STANDARDIZED AUXVARS AUXLIST NONAUXLIST DECLS BODY
	(AUXDECLS NIL))
    (SETQ STANDARDIZED (SI:LAMBDA-EXP-ARGS-AND-BODY LAMBDA))
    (SETQ NONAUXLIST (CAR STANDARDIZED))
    (SETQ AUXLIST (MEMBER '&AUX NONAUXLIST))
    (IF (NULL AUXLIST)
	(WHEN (NULL AGAIN-TAG) (RETURN-FROM P1AUX LAMBDA))
      (SETQ AUXVARS (CDR AUXLIST)
	    NONAUXLIST (LDIFF NONAUXLIST AUXLIST)))
    (DO ((VARLIST NONAUXLIST (CDR VARLIST))
	 SPECIAL-FLAG)
	((NULL VARLIST)
	 (IF SPECIAL-FLAG
	     (PUSH '&SPECIAL AUXVARS)))
      (COND ((EQ (CAR VARLIST) '&SPECIAL)
	     (SETQ SPECIAL-FLAG T))
	    ((EQ (CAR VARLIST) '&LOCAL)
	     (SETQ SPECIAL-FLAG NIL))))
    (SETQ BODY (CDR STANDARDIZED))
    ;; Take all DECLAREs off the body and put them on DECLS.
    (SETF (VALUES BODY DECLS)
	  (EXTRACT-DECLARATIONS-RECORD-MACROS BODY))
    (WHEN DECLS
      ;; The following second copy of the declarations which accompanies the
      ;; binding of the &AUX vars is only for P1SBIND.  The dummy declaration
      ;; .AUX. tells PROCESS-PERVASIVE-DECLARATIONS to ignore it.  The dummy
      ;; declaration .ARG. tells PROCESS-BINDING-DECLARATIONS to not worry
      ;; about references to variables that have not been defined yet.
      (WHEN AUXVARS
	(IF (NULL NONAUXLIST)
	    (SETQ AUXDECLS `((DECLARE . ,DECLS))
		  DECLS NIL)
	  (PROGN
	    (SETQ AUXDECLS `((DECLARE (.AUX.) . ,DECLS)))
	    (PUSH '(.ARG.) DECLS))))
      (SETQ DECLS `((DECLARE . ,DECLS))))
    `(LAMBDA ,NONAUXLIST ,@DECLS 
       ,(IF AGAIN-TAG	   ; need to insert a TAGBODY
	    Ï1(IF (ANDÏ* (CONSP (FIRST BODY))
		     (EQ (FIRST (FIRST BODY)) 'BLOCK)
		     (NULL (REST BODY)) )
		`(BLOCK ,(SECOND (FIRST BODY))
		   (TAGBODY ,AGAIN-TAG
		       (RETURN-FROM ,(SECOND (FIRST BODY))
			 (LET* ,AUXVARS
			   ,@AUXDECLS
			   . ,(CDDR (FIRST BODY)))
			 )))
	      Ï1`(BLOCK ,AGAIN-TAGÏ*
		  Ï1(TAGBODY ,AGAIN-TAGÏ*
		      Ï1(RETURN-FROM ,AGAIN-TAGÏ*
			 Ï1(LET* ,AUXVARSÏ*
			    Ï1,@AUXDECLSÏ*
			    Ï1. ,BODY))))Ï* )
	  `(LET* ,AUXVARS ,@AUXDECLS . ,BODY)
	  ))
    ))

(DEFUN SUPERSEDED (form)
  "This function issues compiler warnings about otherwise valid functions which 
have been superseded by new Common Lisp functions.  Warnings are issued if
in Common Lisp mode and *WARN-OF-SUPERSEDED-FUNCTIONS-P* is true.

This function expects the function symbol [i.e., (first FORM)] to have a
property named SUPERSEDED which is one of the following:
  * A symbol which names the replacement function.
  * A string which describes what to use instead.
  * A function which receives the form as its argument and optionally
    returns a string.
This property is usually established by the MAKE-SUPERSEDED macro.
If this property is not on the function name, then no warning is issued."

  ;; 10/07/86 DNG - Don't say "by Common Lisp" unless new symbol in LISP package.
  ;; 12/08/86 DNG - Don't give warning in same file where function is defined.
  ;;  1/21/87 DNG - Don't give warnings in Zetalisp mode.
  ;; 10/18/87 DNG - Don't give warnings in Scheme mode.
  
  (declare (values ignore))
  (when (and COMPILING-COMMON-LISP
	     Ï1(not (compiling-scheme-p))Ï*
	     *WARN-OF-SUPERSEDED-FUNCTIONS-P*
	     OBSOLETE-FUNCTION-WARNING-SWITCH
	     (not (and (get-opcodes (first form)) ; macro-instruction
		       (or SI:FILE-IN-COLD-LOAD
			   (eq *package* KERNEL-PACKAGE))))
	     ;; The following test is to enable files like "KERNEL;ARRAYS" and
	     ;; "KERNEL;STRINGS" to use old functions internally.
	     (not (and FDEFINE-FILE-PATHNAME
		       (eq (si:get-source-file-name (first form) 'defun)
			   FDEFINE-FILE-PATHNAME)))
	     )
    (let* (( function (first form) )
	   ( replacement (get function 'superseded) ))
      (cond 
	((symbolp replacement)
	 (if (and (fboundp replacement)
		  (fboundp function)
		  (or (equal (function-name (symbol-function function))
			     (function-name (symbol-function replacement)))
		      (let ((opcodes (get-opcodes function) ))
			(and opcodes (equal opcodes (get-opcodes replacement))) )
		      ) )
	     (warn 'SUPERSEDED :OBSOLETE
		   "~S is an old Zetalisp name for the Common Lisp function ~S."
		   function replacement )
	   (warn 'SUPERSEDED :OBSOLETE
		 (if (eq (symbol-package replacement) si:pkg-lisp-package)
		     "Function ~S has been superseded by Common Lisp; use ~S instead."
		   "Function ~S is obsolete; use ~S instead.")
		 function replacement ) ) )
	((stringp replacement)
	 (warn 'SUPERSEDED :OBSOLETE
	       "Function ~S has been superseded by Common Lisp;~%  ~A."
	       function
	       replacement) )
	((functionp replacement)
	 ;; then this message must be calculated based upon FORM
	 (let (( line-2 (funcall replacement form) ))
	   (when (stringp line-2)
	     ;; then we did find something to print, so prepend first line and issue warning
	     (warn 'SUPERSEDED :OBSOLETE
		   "Function ~S (or at least this usage if it) ~
                  has been superseded by Common Lisp;~%  ~A."
		   function
		   line-2))) )
	)  ; end cond
      ))   ;when
  NIL
  )

(DEFUN COMPILE-STREAM (INPUT-STREAM GENERIC-PATHNAME FASD-FLAG PROCESS-FN
		       QC-FILE-LOAD-FLAG QC-FILE-IN-CORE-FLAG PACKAGE-SPEC
		       &OPTIONAL (FILE-LOCAL-DECLARATIONS NIL)
		       IGNORE ; used to be READ-THEN-PROCESS-FLAG
		       COMPILING-WHOLE-FILE-P OPERATION-TYPE)
  "This function does all the \"outer loop\" of the compiler, for file and editor compilation.
Expressions to be compiled are read from INPUT-STREAM.
The caller is responsible for handling any file attributes.
GENERIC-PATHNAME is the file to record information for and use the attributes of.
 It may be NIL if compiling to core.
FASD-FLAG is NIL if not making an object file.
PROCESS-FN is called on each form.
QC-FILE-LOAD-FLAG, QC-FILE-IN-CORE-FLAG, and PACKAGE-SPEC are options.
FILE-LOCAL-DECLARATIONS is normally initialized to NIL,
but you can optionally pass in an initializations for it.
COMPILING-WHOLE-FILE-P should be T if you are processing all of the file."
  ;;  2/23/85 - Make sure :MODE is :ZETALISP or :COMMON-LISP, not just :LISP .
  ;;  2/27/85 - Record version number of the "Compiler" sub-system in the object file.
  ;;  2/28/85 - Test for starting new whack moved from here to QC-FILE-COMMON. [SPR 804]
  ;;		Record outside value of OPTIMIZE switches in the object file.
  ;;  1/31/86 - Push pathname onto COLD-LOAD-FILES if it has COLD-LOAD attribute.
  ;;  4/24/86 - Set *LAST-ADDRESS-READ*.
  ;;  4/25/86 - Fix to use GLOBAL:READ instead of CLI:READ.
  ;;  6/18/86 - Modify to work when SI:GET-SYSTEM-VERSION is not defined.
  ;;  6/30/86 - Record the system name in the object file if different from "SYSTEM".
  ;;  8/08/86 - Use macro WITH-COMPILE-DRIVER-BINDINGS.
  ;;  9/11/86 - Warn when in Zetalisp mode but not using the ZLC package.
  ;;  9/26/86 - Check QC-FILE-CHECK-INDENTATION at each read instead of only at the
  ;;		beginning so that it can be changed within the file.
  ;;		When compiling in memory, read into a write-protected area. [SPR 405]
  ;; 10/08/86 - Suppress "end of data" messages in Eval Buffer. [SPR 1041]
  ;;  2/07/87 - Remove use of write-protected area for reading -- it was causing
  ;;		more problems than it was solving.
  ;;  3/20/87 - Fix to not warn about not using ZLC package when GLOBAL is being used instead.
  ;;  7/22/87 - Read in SOURCE-CODE-AREA in QC-FILE as well as Compile Buffer;
  ;;		eliminate use of *LAST-ADDRESS-READ*.
Ï1  ;; 11/07/87 - Fix Zetalisp warning to not be activated in Scheme mode.
  ;; 12/19/87 - Warn if in Scheme mode without using the Scheme package.
  ;; 12/22/87 - Fix to expand top-level symbol defined by SCHEME:DEFINE-INTEGRABLE.Ï*
  ;;  4/08/88 DNG - Re-instate test for starting a new whack here as well as 
  ;;		in QC-FILE-COMMON in order to preferentially break between
  ;;		top-level forms. [SPR 7234]

 (record-individual-time 'compile-stream
  (LET ((*PACKAGE* *PACKAGE*)
	(*READ-BASE* *READ-BASE*) (*PRINT-BASE* *PRINT-BASE*)
	(OPTIMIZE-SWITCH OPTIMIZE-SWITCH)
	FILE-SPECIAL-LIST FILE-UNSPECIAL-LIST
	( FILE-CONSTANTS-LIST NIL )
	( *BARF-DEFAULTS* NIL )
	FDEFINE-FILE-PATHNAME)
  (FILE-OPERATION-WITH-WARNINGS (GENERIC-PATHNAME
				 (OR OPERATION-TYPE ':COMPILE)
				 COMPILING-WHOLE-FILE-P)
   (COMPILER-WARNINGS-CONTEXT-BIND
     ;; Override the package if required.  It has been bound in any case.
     (AND PACKAGE-SPEC (SETQ *PACKAGE* (FIND-PACKAGE PACKAGE-SPEC)))
     ;; Override the generic pathname
     (SETQ FDEFINE-FILE-PATHNAME
	   (LET ((PATHNAME (AND (MEMBER ':PATHNAME (SEND INPUT-STREAM :WHICH-OPERATIONS) :TEST #'EQ)
				(SEND INPUT-STREAM :PATHNAME))))
	     (AND PATHNAME (SEND PATHNAME :GENERIC-PATHNAME))))
     (WHEN (AND (NOT (NULL FDEFINE-FILE-PATHNAME))
		SI:FILE-IN-COLD-LOAD
		(NOT (MEMBER FDEFINE-FILE-PATHNAME COLD-LOAD-FILES :TEST #'EQ)))
       (LET (( DEFAULT-CONS-AREA BACKGROUND-CONS-AREA ))
	 ;; Let function CHECK-COLD know that this file has the :COLD-LOAD attribute.
	 (PUSH FDEFINE-FILE-PATHNAME COLD-LOAD-FILES) ) )
     ;; Having bound the variables, process the file.
     (LET ((QC-FILE-IN-PROGRESS T)
	   (UNDO-DECLARATIONS-FLAG (NOT QC-FILE-LOAD-FLAG))
	   (LOCAL-DECLARATIONS NIL)
	   (OPEN-CODE-MAP-SWITCH OPEN-CODE-MAP-SWITCH)
	   (RUN-IN-MACLISP-SWITCH RUN-IN-MACLISP-SWITCH)
	   (OBSOLETE-FUNCTION-WARNING-SWITCH OBSOLETE-FUNCTION-WARNING-SWITCH)
	   (ALL-SPECIAL-SWITCH ALL-SPECIAL-SWITCH)
	   (SOURCE-FILE-UNIQUE-ID)
	   (FASD-PACKAGE NIL))
       ;; Process any Common Lisp declaration specifiers found in
       ;; the FILE-LOCAL-DECLARATIONS list.  The CATCH is used to
       ;; suppress warnings from PROCLAIM about unrecognized declarations
       ;; since FILE-LOCAL-DECLARATIONS list can be used for other things too.
       (LET (( WARN-CATCHER 'FILE-LOCAL-DECLARATIONS ))
	 (DOLIST ( DECL FILE-LOCAL-DECLARATIONS )
	   (CATCH WARN-CATCHER
	     (PROCLAIM DECL) ) ) )

       (WHEN FASD-FLAG
	 ;; Copy all suitable file properties into the fasl file
	 ;; Suitable means those that are lambda-bound when you read in a file.
	 (LET ((PLIST (COPY-LIST (SEND GENERIC-PATHNAME :PLIST))))
	   ;; Remove unsuitable properties
	   (DO ((L (LOCF PLIST)))
	       ((NULL (CDR L)))
	     (IF (NOT (NULL (GET (CADR L) 'FS:FILE-ATTRIBUTE-BINDINGS)))
		 (SETQ L (CDDR L))
	       (RPLACD L (CDDDR L))))
	   ;; Make sure the package property is really the package compiled in
	   ;; Must load object file into same package compiled in
	   ;; On the other hand, if we did not override it
	   ;; and the attribute list has a list for the package, write that list.
	   (UNLESS (AND (NOT (ATOM (GETF PLIST :PACKAGE)))
			(STRING-EQUAL (PACKAGE-NAME *PACKAGE*)
				      (CAR (GETF PLIST ':PACKAGE))))
	     (SETF (GETF PLIST ':PACKAGE)
		   (INTERN (PACKAGE-NAME *PACKAGE*) PKG-KEYWORD-PACKAGE)))
	   ;; Make sure :MODE is :ZETALISP or :COMMON-LISP, not just :LISP .
	   (SETF (GETF PLIST ':MODE) (LISP-MODE))
	   (COND ((AND (COMPILING-FOR-V2)
		      Ï1(ZETALISP-ON-P)Ï*)
	          (COND #+Elroy
		   ((LET ((L (PACKAGE-USE-LIST *PACKAGE*)))
		      (NOT (OR (MEMBER ZETALISP-PACKAGE L :TEST #'EQ) ; uses ZLC
			       (MEMBER SI:PKG-GLOBAL-PACKAGE L :TEST #'EQ) ; uses GLOBAL
			       (EQ (FIND-SYMBOL "MEM") 'GLOBAL:MEM) ; gets the right symbols some other way
			       )))
		    (WARN ':ZETALISP ':IMPLAUSIBLE
			  "Warning: this file is in Zetalisp mode but package ~A doesn't use the ZLC package."
			  (PACKAGE-NAME *PACKAGE*)))
		   #+compiler:debug	   ; %%% temporary 6/18/86 %%%
		   ((OR (EQ *PACKAGE* KERNEL-PACKAGE)
			SI:FILE-IN-COLD-LOAD)
		    (WARN ':ZETALISP ':IMPLAUSIBLE
			  "Warning: this kernel file is still in Zetalisp."))
		   ;;%%% Later add test here to do automatic MAKE-SYSTEM of the
		   ;;%%% Zetalisp compatibility subsystem if not already loaded.
		   ))
		Ï1 ((si:SCHEME-ON-P)Ï*
		Ï1  (UNLESS (OR (MEMBER SI:SCHEME-PACKAGE (PACKAGE-USE-LIST *PACKAGE*) :TEST #'EQ) ; uses SCHEMEÏ*
			Ï1      (EQ (FIND-SYMBOL "DEFINE") 'SCHEME:DEFINE)) ; gets the right symbols some other wayÏ*
		Ï1    (WARN 'SCHEME-ON-P ':IMPLAUSIBLEÏ*
			Ï1  "Warning: this file is in Scheme mode but package ~A doesn't use the Scheme package."Ï*
			Ï1  (PACKAGE-NAME *PACKAGE*))))Ï*
		Ï1  ((COMMON-LISP-ON-P)Ï*
		    Ï1(UNLESS (OR (MEMBER *LISP-PACKAGE* (PACKAGE-USE-LIST *PACKAGE*) :TEST #'EQ) ; uses LISPÏ*
				  Ï1(EQ (FIND-SYMBOL "DEFUN") 'DEFUN)) ; gets the right symbols some other wayÏ*
		       Ï1(WARN 'COMMON-LISP-ON-P ':IMPLAUSIBLEÏ*
			      Ï1"Warning: this file is in Common Lisp mode but package ~A doesn't use the Lisp package."Ï*
			      Ï1(PACKAGE-NAME *PACKAGE*))))Ï*
		    )
	   (AND INPUT-STREAM
		(MEMBER ':TRUENAME (SEND INPUT-STREAM :WHICH-OPERATIONS) :TEST #'EQ)
		(SETQ SOURCE-FILE-UNIQUE-ID (SEND INPUT-STREAM :TRUENAME))
		(SETF (GETF PLIST ':QFASL-SOURCE-FILE-UNIQUE-ID)
		      SOURCE-FILE-UNIQUE-ID) )
	   ;; If a file is being compiled across directories, remember where the
	   ;; source really came from.
	   (AND FDEFINE-FILE-PATHNAME FASD-STREAM
		(LET ((OUTFILE (AND (MEMBER ':PATHNAME
					    (SEND FASD-STREAM :WHICH-OPERATIONS)
					    :TEST #'EQ)
				    (SEND FASD-STREAM :PATHNAME))))
		  (WHEN OUTFILE
		    (SETQ OUTFILE (SEND OUTFILE :GENERIC-PATHNAME))
		    (AND (NEQ OUTFILE FDEFINE-FILE-PATHNAME)
			 (SETF (GETF PLIST ':SOURCE-FILE-GENERIC-PATHNAME)
			       FDEFINE-FILE-PATHNAME)))))
	   (MULTIPLE-VALUE-BIND (MAJOR MINOR)
	       (AND (FBOUNDP 'SI:GET-SYSTEM-VERSION)
		    (SI:GET-SYSTEM-VERSION))
	     (SETF (GETF PLIST ':COMPILE-DATA)
		   (LIST USER-ID
			 SI:LOCAL-PRETTY-HOST-NAME
			 (AND (FBOUNDP 'TIME:GET-UNIVERSAL-TIME)
			      (TIME:GET-UNIVERSAL-TIME))
			 MAJOR MINOR
			 (LET (( PROPS NIL ))
			   (SETF (GETF PROPS 'OPTIMIZE-SWITCH)
				 OPTIMIZE-SWITCH)
			   (WHEN (FBOUNDP 'SI:GET-SYSTEM-VERSION)
			     (MULTIPLE-VALUE-BIND ( V1 V2 )
				 (SI:GET-SYSTEM-VERSION
				   (IF (EQ 'VERSION 'COMPILER:VERSION)
				       'COMPILER
				     'COMPILER2))
			       (UNLESS (NULL V1)
				 (SETF (GETF PROPS 'VERSION)
				       (LIST V1 V2) )))
			     (UNLESS (STRING-EQUAL SI:*SYSTEM-NAME* "SYSTEM")
			       (SETF (GETF PROPS 'SI:*SYSTEM-NAME*)
				     SI:*SYSTEM-NAME*)) )
			   (UNLESS (COMPILING-FOR-EXPLORER-P)
			     (SETF (GETF PROPS 'NEW-DESTINATIONS) T) )
			   PROPS))))
	   ;; First thing in QFASL file must be property list
	   ;; These properties wind up on the GENERIC-PATHNAME.
	   (COND #+MIT
		 (QC-FILE-REL-FORMAT
		  (QFASL-REL#:DUMP-FILE-PROPERTY-LIST
		    GENERIC-PATHNAME
		    PLIST))
		 (T
		  (FASD-FILE-PROPERTY-LIST PLIST)))))
       (QC-PROCESS-INITIALIZE)
       (WHEN (NULL (SYMBOL-VALUE 'SOURCE-CODE-AREA))
	 (MAKE-AREA :NAME 'SOURCE-CODE-AREA :REPRESENTATION :LIST :GC :DYNAMIC))
       (WITH-COMPILE-DRIVER-BINDINGS 
        (DO ((EOF (CONS NIL NIL))
	     (FORM))
	    (NIL)
	 ;; Detect EOF by peeking ahead, and also get an error now
	 ;; if the stream is wedged.  We really want to get an error
	 ;; in that case, not make a warning.
	 (LET ((CH (SEND INPUT-STREAM :TYI)))
	   (OR CH (RETURN))
	   (SEND INPUT-STREAM :UNTYI CH))
	 (setq si:premature-warnings
	       (append si:premature-warnings si:premature-warnings-this-object))
	 (let ((si:premature-warnings nil))
	   (LET ((#-Elroy READ-AREA
		  #+Elroy DEFAULT-CONS-AREA
		  (IF (OR QC-FILE-LOAD-FLAG ; Compile Buffer
			  (NOT (SI:AREA-TEMPORARY-P QCOMPILE-TEMPORARY-AREA)))	; TGC on
		      SOURCE-CODE-AREA
		    QCOMPILE-TEMPORARY-AREA))
		 (WARN-ON-ERRORS-STREAM INPUT-STREAM)
		 (QC-FILE-READ-IN-PROGRESS FASD-FLAG)	   ;looked at by XR-#,-MACRO
		 #+Elroy
		 (SI:*MAXIMUM-READ-BUFFER-SIZE* 256)
		 ;; Include the following after everything has been EXPORTed that should be.
		 ;;#+Elroy
		 ;;(SI:*RESTRICT-INTERNAL-SYMBOLS* T)
		 )
	     (WARN-ON-ERRORS ('READ-ERROR "Error in reading")
	       (LET-IF TARGET-FEATURES ((*FEATURES* TARGET-FEATURES))
		 (record-individual-time 'read
		   (SETQ FORM
			 (IF QC-FILE-CHECK-INDENTATION
			     (READ-CHECK-INDENTATION INPUT-STREAM EOF)
			   (READ INPUT-STREAM NIL EOF)))
		   ))) )
	   (setq si:premature-warnings-this-object si:premature-warnings))
	 (WHEN (EQ FORM EOF) (RETURN))
	 Ï1(LOOP WHILE (AND (SYMBOLP FORM)Ï*
			     Ï1(SI:SCHEME-ON-P))Ï*
	        Ï1DO (LET ((L (GET FORM 'INTEGRABLE '|<Undefined>|)))Ï*
		      Ï1(IF (EQ L '|<Undefined>|)Ï*
			   Ï1(RETURN)Ï*
			 Ï1(PROGN (PUSHNEW FORM MACROS-EXPANDED :TEST #'EQ)Ï*
				 Ï1(SETQ FORM L)))))Ï*
	 ;; Start a new whack if FASD-TABLE is getting too big.  A smaller threshold 
	 ;; is used here than in QC-FILE-COMMON because it is safer to break here
	 ;; (less likely to have gensym references spanning the boundary).  [SPR 7234]
	 (WHEN (AND FASD-FLAG
		    (>= (FASD-TABLE-LENGTH) (- QC-FILE-WHACK-THRESHOLD 1000)))
	   (FASD-END-WHACK) )
	 (IF (AND (ATOM FORM) FASD-FLAG)
	     (WARN 'ATOM-AT-TOP-LEVEL ':IMPLAUSIBLE
		   "The atom ~S appeared at top level; this will do nothing at FASLOAD time."
		   FORM)
	   (FUNCALL PROCESS-FN FORM))
	 ) ; end of DO loop
       ;; Copy MACROS-EXPANDED to QC-FILE-MACROS-EXPANDED when appropriate.
       (MACROS-EXPANDED-DEBUG-INFO MACROS-EXPANDED)
     ))) ; end of COMPILER-WARNINGS-CONTEXT-BIND
   (WHEN (EQ OPERATION-TYPE ':EVAL)
     ;; When evaluating a Zmacs buffer, OBJECT-OPERATION-WITH-WARNINGS is not used,
     ;; so "end of data" messages are not meaningful, so suppress them.  [SPR 1041]
     (SETQ si:PREMATURE-WARNINGS NIL))
   ))))

(DEFUN EXPR-SXHASH (FUNCTION-SPEC)
  "Return the SXHASH of the interpreted definition of FUNCTION-SPEC.
If FUNCTION-SPEC's definition is compiled, the interpreted definition
or its SXHASH may be remembered in the debugging info.
If neither is remembered, the value is NIL."
Ï1  ;; 11/14/87 DNG - Add check for INTEGRABLE property for support of SCHEME:DEFINE-INTEGRABLE.Ï*
  (FUNCTION-EXPR-SXHASH Ï1(ORÏ* (DECLARED-DEFINITION FUNCTION-SPEC)
			     Ï1(AND (SYMBOLP FUNCTION-SPEC)Ï*
				Ï1  (GET FUNCTION-SPEC 'INTEGRABLE))Ï*)))
  
(DEFUN P1SBIND (X KIND PARALLEL IGNORE-NIL-P THIS-FRAME-DECLARATIONS)
  ;;  7/18/85 - Add check for binding of a DEFCONSTANT; previously done in VAR-MAKE-HOME. [SPR 194]
  ;;  9/14/85 - Use EQ instead of STRING-EQUAL to test for IGNORE.
  ;;  1/09/86 - Allow "variable appears twice" message to be suppressed by INHIBIT-STYLE-WARNINGS-SWITCH.
  ;;  3/07/86 - Don't set LOCAL-DECLARATIONS from redundant &SPECIAL flag.
Ï1  ;; 11/21/87 - In Scheme mode, permit variables names beginning with ":" or "&".Ï*
  (LET (TM EVALCODE VARN MYVARS MISC-TYPES
	SPECIFIED-FLAGS (SPECIALNESS NIL) ALREADY-REST-ARG)
    ;; First look at the var specs and make homes, pushing them on MYVARS (reversed).
    (PROG ()
	  (SETQ EVALCODE 'FEF-QT-DONTCARE)
       A  (COND ((NULL X) (RETURN))
		((SETQ TM (ASSOC (CAR X)
				'((&OPTIONAL . FEF-ARG-OPT)
				  (&REST . FEF-ARG-REST) (&AUX . FEF-ARG-AUX))
				:TEST #'EQ))
		 (COND ((OR (EQ KIND 'FEF-ARG-AUX)
			    (EQ KIND 'FEF-ARG-INTERNAL-AUX))
			(WARN 'BAD-BINDING-LIST ':IMPOSSIBLE
			      "A lambda-list keyword (~S) appears in an internal binding list."
			      (CAR X)))
		       (T (SETQ KIND (CDR TM))))
		 (GO B))
		((SETQ TM (ASSOC (CAR X) '((&EVAL . FEF-QT-EVAL)
					   (&QUOTE . FEF-QT-QT)
					   (&QUOTE-DONTCARE . FEF-QT-DONTCARE))
				 :TEST #'EQ))
		 (SETQ EVALCODE (CDR TM))
		 (GO B))
		((SETQ TM (ASSOC (CAR X) '((&FUNCTIONAL . FEF-FUNCTIONAL-ARG)) :TEST #'EQ))
		 (PUSH (CDR TM) MISC-TYPES)
		 (GO B))
		((EQ (CAR X) '&SPECIAL)
		 (SETQ SPECIALNESS T)
		 (GO B))
		((EQ (CAR X) '&LOCAL)
		 (SETQ SPECIALNESS NIL)
		 (GO B))
		((MEMBER (CAR X) LAMBDA-LIST-KEYWORDS :TEST #'EQ)
		 (GO B)))
	  ;; LAMBDA-list keywords have jumped to B.
	  ;; Now (CAR X) should be a variable or (var init).
	  (SETQ VARN (COND ((ATOM (CAR X)) (CAR X)) (T (CAAR X))))
	  (UNLESS (SYMBOLP VARN)
	    (WARN 'VARIABLE-NOT-SYMBOL ':IMPOSSIBLE
		  "~S appears in a list of variables to be bound." VARN)
	    (GO B))
	  (WHEN Ï1(ANDÏ* (KEYWORDP VARN) ; this check added 8/13/84 by D.N.G.
		      Ï1(NOT (COMPILING-SCHEME-P)))Ï*
	    (WARN 'VARIABLE-NOT-SYMBOL ':IMPOSSIBLE
		  "The keyword ~S appears in a list of variables to be bound.
Keywords are constants and so cannot be used as names of variables." VARN)
	    (GO B))
	  (WHEN (AND (OR (GET-FOR-TARGET VARN 'SYSTEM-CONSTANT)
			 (ASSOC VARN FILE-CONSTANTS-LIST :TEST #'EQ))
		     (NOT (EQ VARN 'NIL)) ; permitted in MULTIPLE-VALUE-BIND
		     (EQ (FIND-TYPE VARN THIS-FRAME-DECLARATIONS)
			 'FEF-SPECIAL) )
	    (WARN 'SYSTEM-CONSTANT-BOUND ':IMPLAUSIBLE
		  "Attempt to bind the constant ~S; the new binding will be local.
If that is what you want, this message can be suppressed by (DECLARE (UNSPECIAL ~S))."
		  VARN VARN)
	    (PUSH `(UNSPECIAL ,VARN) THIS-FRAME-DECLARATIONS) )
	  (WHEN (AND (NOT (OR (EQ VARN 'LISP:IGNORE)
			      (STRING-EQUAL VARN "IGNORED")
			      (NULL VARN)))
		     ;; Does this variable appear again later?
		     ;; An exception is made in that a function argument can be repeated
		     ;; after an &AUX.
		     (DOLIST (X1 (CDR X))
		       (COND ((EQ X1 '&AUX) (RETURN NIL))
			     ((OR (EQ X1 VARN)
				  (AND (NOT (ATOM X1)) (EQ (CAR X1) VARN)))
			      (RETURN T))))
		     (OR PARALLEL
			 (NOT INHIBIT-STYLE-WARNINGS-SWITCH)) )
	    (WARN 'BAD-BINDING-LIST ':IMPLAUSIBLE
		  "The variable ~S appears twice in one binding list."
		  VARN) )
	  (WHEN Ï1(ANDÏ* (CHAR= (CHAR (SYMBOL-NAME VARN) 0) #\&)
		      Ï1(NOT (COMPILING-SCHEME-P)))Ï*
	    (WARN 'MISSPELLED-KEYWORD ':IMPLAUSIBLE
		  "~S is probably a misspelled keyword." VARN))
	  (WHEN ALREADY-REST-ARG
	    (WARN 'BAD-LAMBDA-LIST ':IMPOSSIBLE
		  "Argument ~S comes after the &REST argument." VARN))
	  (WHEN (EQ KIND 'FEF-ARG-REST)
	    (SETQ ALREADY-REST-ARG T))
	  (COND ((AND IGNORE-NIL-P (NULL VARN))
		 (LET ((P1VALUE NIL))
		   (P1 (CADAR X))))    ;Out of order, but works in these simple cases
		((OR (NULL VARN) (EQ VARN T))
		 (WARN 'NIL-OR-T-SET ':IMPOSSIBLE "There is an attempt to bind ~S." VARN))
		(T
		 ;; Make the variable's home.
		 (IF SPECIALNESS
		     (LET ((DECL (LIST 'SPECIAL
				       (COND ((SYMBOLP (CAR X)) (CAR X))
					     ((SYMBOLP (CAAR X)) (CAAR X))
					     (T (CADAAR X))))))
		       (UNLESS (SPECIALP (SECOND DECL))
			 ;; If already special anyway, don't put it on LOCAL-DECLARATIONS
			 ;; to avoid warning from FIND-TYPE on a later binding.
			 (PUSH DECL LOCAL-DECLARATIONS) )
		       (PUSH DECL THIS-FRAME-DECLARATIONS)))
		 (PUSH (P1BINDVAR (CAR X) KIND EVALCODE MISC-TYPES
				  THIS-FRAME-DECLARATIONS)
		       MYVARS)))
	  (SETQ MISC-TYPES NIL)
       B
	  (SETQ X (CDR X))
	  (GO A))
															       
    ;; Arguments should go on ALLVARS now, so all args precede all boundvars.
    (OR (EQ KIND 'FEF-ARG-INTERNAL-AUX)
	(EQ KIND 'FEF-ARG-AUX)
	(SETQ ALLVARS (APPEND SPECIFIED-FLAGS MYVARS ALLVARS)))
    (MAPC #'VAR-COMPUTE-INIT SPECIFIED-FLAGS (CIRCULAR-LIST NIL))

    (PROCESS-BINDING-DECLARATIONS MYVARS THIS-FRAME-DECLARATIONS)

    ;; Now do pass 1 on the initializations for the variables.
    (DO ((ACCUM)
	 (VS (REVERSE MYVARS) (CDR VS)))
	((NULL VS)
	 ;; If parallel binding, put all var homes on VARS
	 ;; after all the inits are thru.
	 (COND (PARALLEL
		(UNLESS (ZEROP ALTERED-VAR-SET)
		  ;; Prevent propagation of new variables whose initial
		  ;; values are local variables which were changed as
		  ;; a side effect of a parallel binding.
		  (LET ( LAPAD INIT )
		    (DOLIST ( V MYVARS )
		      (WHEN (ZEROP PROPAGATE-VAR-SET) (RETURN))
		      (WHEN (AND (CONSP (SETQ INIT (SECOND (VAR-INIT V))))
				 (EQ (CAR INIT) 'LOCAL-REF)
				 (LOGTEST (CDDR INIT) ALTERED-VAR-SET)
				 (CONSP (SETQ LAPAD (VAR-LAP-ADDRESS V)))
				 (EQ (CAR LAPAD) 'LOCAL-REF))
			(SETQ PROPAGATE-VAR-SET
			      (LOGDIF PROPAGATE-VAR-SET
				      (CDDR LAPAD)))
			)) ) )
		(SETQ VARS (APPEND MYVARS VARS))
		(COND ((OR (EQ KIND 'FEF-ARG-INTERNAL-AUX)
			   (EQ KIND 'FEF-ARG-AUX))
		       (MAPC #'VAR-CONSIDER-OVERLAP MYVARS)
		       (SETQ ALLVARS (APPEND MYVARS ALLVARS))))))
	 (NREVERSE ACCUM))
      (PUSH (VAR-COMPUTE-INIT (CAR VS) PARALLEL) ACCUM)
      ;; For sequential binding, put each var on VARS
      ;; after its own init.
      (OR PARALLEL
	  (PROGN (COND ((OR (EQ KIND 'FEF-ARG-INTERNAL-AUX)
			    (EQ KIND 'FEF-ARG-AUX))
			(VAR-CONSIDER-OVERLAP (CAR VS))
			(PUSH (CAR VS) ALLVARS)))
		 (PUSH (CAR VS) VARS)
		 (LET ((TEM (CDDR (VAR-INIT (CAR VS)))))
		   (AND TEM (PUSH TEM VARS))))))))

(DEFUN VAR-MAKE-HOME (NAME TYPE KIND INIT-SPECS EVAL-TYPE MISC-TYPES &AUX HOME)
  ;;  7/18/85 - Moved check for binding of DEFCONSTANT from here to P1SBIND so
  ;;		that the binding can be discarded.  [SPR 194]
  ;; 12/07/85 - For release 3, special arguments are temporarily given addresses
  ;;		as arguments instead of special variables.
  ;;  1/31/86 - Added call to CHECK-FOR-OBSOLETE-VARIABLE.
  ;;  6/25/86 - Fixed to not do special binding for (LET ((x x)) (DECLARE (UNSPECIAL x))).
Ï1  ;; 11/21/87 - Permit keywords as variable names in Scheme mode.Ï*
    #+compiler:debug
    (UNLESS (MEMBER KIND '(FEF-ARG-REQ FEF-ARG-OPT FEF-ARG-REST FEF-ARG-AUX
			   FEF-ARG-INTERNAL-AUX FEF-ARG-KEY) :TEST #'EQ)
      (BARF KIND 'BAD-KIND 'BARF))
    (WHEN Ï1(ANDÏ* (EQ (SYMBOL-PACKAGE NAME) SI:PKG-KEYWORD-PACKAGE)
	        Ï1(NOT (COMPILING-SCHEME-P)))Ï*
	(WARN 'KEYWORD-BOUND ':IMPOSSIBLE
	      "Binding the keyword symbol ~S." NAME))
    (WHEN (AND (MEMBER NAME (CDDR SELF-FLAVOR-DECLARATION) :TEST #'EQ) 
	       (EQ TYPE 'FEF-LOCAL))
	(WARN 'INSTANCE-VARIABLE-BOUND ':IMPLAUSIBLE
	      "Rebinding the instance variable ~S.  The new binding will be local."
	      NAME))
    (UNLESS (COMPILING-FOR-V2)
      ;; Rest args interfere with fast arg option except when there are no specials.
      ;; We need to look at this to
      ;;  decide how to process all the AUX variables and can't tell when processing
      ;;  the first one whether the next will be special.
      ;;  In any case, being wrong about this should not be able to produce
      ;;  incorrect code.
      (COND ((EQ KIND 'FEF-ARG-REST)
	     (SETQ FAST-ARGS-POSSIBLE NIL)))
      (COND ((MEMBER KIND '(FEF-ARG-REQ FEF-ARG-OPT) :TEST #'EQ)
	     (AND INIT-SPECS (SETQ FAST-ARGS-POSSIBLE NIL)))) )
    ;; Detect vars bound to themselves which fail to be special.
    (WHEN (AND (EQ NAME (CAR INIT-SPECS))
	       (NOT (LOOKUP-VAR NAME VARS))
	       ;; If variable is globaly special but this binding has not already been
	       ;; made special, then there must have been an UNSPECIAL declaration which
	       ;; needs to be observed.
	       (NOT (OR (GET NAME 'SPECIAL)
			(MEMBER NAME FILE-SPECIAL-LIST :TEST #'EQ))) )
      (MSPL2 NAME)
      (SETQ TYPE 'FEF-SPECIAL))
    (WHEN (EQ TYPE 'FEF-SPECIAL)
      (CHECK-FOR-OBSOLETE-VARIABLE NAME) )
    ;; Cons up the variable descriptor.
    ;; Note that INIT-SPECS is not the final value that will go in the INIT slot.
    (SETQ HOME (MAKE-VAR NAME NAME KIND KIND TYPE TYPE
			 USE-COUNT NIL
			 INIT INIT-SPECS EVAL EVAL-TYPE MISC MISC-TYPES))
    (SETF (VAR-LAP-ADDRESS HOME)
	  ;; Not the real lap address,
	  ;; but something for P1 to use for the value of the variable
	  (IF (AND (EQ TYPE 'FEF-SPECIAL)
		   (OR (NOT (COMPILING-FOR-V2))
		       (MEMBER KIND '(FEF-ARG-AUX FEF-ARG-INTERNAL-AUX FEF-ARG-KEY) :TEST #'EQ)))
	      NAME
	      (PROG1 `(LOCAL-REF ,HOME . ,VAR-BIT)
		     (debug-assert (or (> var-bit propagate-var-set) ;normal case
				       (= 0 var-bit propagate-var-set) ; within EXTEND-LOCAL-VARIABLES
				       ))
		     (SETQ VAR-BIT (ASH VAR-BIT 1))) ) )
    HOME)

(DEFSUBST INVULNERABLE-EXPRESSION-P (FORM)
  ;; Given a form that has been processed by P1, return true if the expression's
  ;; value cannot be altered by the side-effects of other expressions.  This
  ;; assumes that global function definitions will be altered only at top level,
  ;; not in the middle of an expression that uses the function.
  ;;  9/18/86 - Original.
Ï1  ;;  3/22/88 DNG - FUNCTION is not invulnerable in Scheme mode.Ï*
  (AND (CONSP FORM)
       Ï1(ORÏ* (MEMBER (FIRST FORM)
	       Ï1'(QUOTE BREAKOFF-FUNCTION LEXICAL-CLOSURE)Ï*
	       :TEST #'EQ)
	    Ï1(AND (EQ (FIRST FORM) 'FUNCTION)Ï*
		  Ï1(NOT (COMPILING-SCHEME-P)))Ï*)))

(DEFUN FIX-FUNCALL-EVALUATION-ORDER (FORM OLD-ALLVARS)
  ;; Given a FUNCALL or APPLY form, make sure things get done in the right order
  ;; if there are any interactions between the function and argument forms.
  ;; This is because in VM2 the function is pushed on the stack after the
  ;; arguments, which violates the usual left-to-right order.
  ;;  9/18/86 DNG - Original.
  ;;  9/19/86 DNG - Use MARK-P1-DONE instead of P1-ALREADY-DONE.
  ;;  9/23/86 DNG - Avoid generating CALL-N PDL-POP.
  ;;  9/24/86 DNG - Bind *OVERLAP-CANDIDATES* to prevent the temporary variable
  ;;		that holds the function to be called from overlapping a variable
  ;;		used in one of the argument calculations.
  ;; 10/11/86 DNG - Assume that *STANDARD-INPUT* and *STANDARD-OUTPUT* won't be
  ;;		modified by the arguments.
  ;; 10/15/86 DNG - Prevent optimization of the constructed LET.
  ;;  1/16/87 DNG - Remove suppression of CALL-N PDL-POP.
Ï1  ;; 12/12/87 DNG - Evaluate function last in Scheme mode.
 (IF (COMPILING-SCHEME-P)
      ;; Scheme does not require left-to-right evaluation order, and in fact, 
      ;; PC Scheme actually evaluates the function after the arguments.
      FORMÏ*
  (LET ((FUNCTION (SECOND FORM)))
    (IF (EQ (CAR-SAFE FUNCTION) 'PROGN)
	;;  (FUNCALL (PROGN a b f) x y) ==> (PROGN a b (FUNCALL f x y))
	(CONS 'PROGN
	      (LOOP FOR X ON (REST FUNCTION)
		    COLLECTING (IF (REST X)
				   (FIRST X)
				 (POST-OPTIMIZE
				   (FIX-FUNCALL-EVALUATION-ORDER 
				     (LIST* (FIRST FORM)
					    (FIRST X)
					    (CDDR FORM))
				      OLD-ALLVARS)))))
      (IF (OR (NOT (COMPILING-FOR-V2))
	      (INVULNERABLE-EXPRESSION-P FUNCTION)
	      ;; some common special cases which are unlikely to be SETQd by an argument:
	      (MEMBER FUNCTION '(SELF *STANDARD-INPUT* *STANDARD-OUTPUT*
				      *TERMINAL-IO* *QUERY-IO*) :TEST #'EQ)
	      (DOLIST (ARG (CDDR FORM) T)
		(UNLESS (INDEPENDENT-EXPRESSIONS-P ARG FUNCTION)
		  (RETURN NIL))))
	  FORM ; ok as is
	;; (FUNCALL (f1 x) (f2 y)) ==> (LET ((g (f1 x)))
	;;				 (FUNCALL g (f2 y)))
	(LET ((TEMP (GENSYM))
	      (*OVERLAP-CANDIDATES* OLD-ALLVARS))
	  (P1 `(LET ((,TEMP ,(MARK-P1-DONE FUNCTION)))
		 (HACK-FUNCALL ,TEMP ,(MARK-P1-DONE FORM)))
	      T) ; don't let LET-OPT undo it
     ))))Ï1)Ï*)

(DEFUN P2ARGC (FUNCTION-VALUE ARGL lexpr-funcall
	       DEST FUNCTION-SPEC &OPTIONAL MAPPING-TABLE)
  "Generate code to call a function."
  ;; 10/10/84 DNG - Fixed to generate correct code for an arglist of the
  ;;                form (&QUOTE x &REST y) with one actual argument.
  ;;  7/22/85 DNG - Modified for Explorer release 3 instruction set.
  ;;  7/29/85 DNG - Eliminated unused variable RESTART-PC.
  ;;  8/24/85 DNG - Implemented use of D-TAIL.
  ;;  9/17/85 DNG - Don't use D-TAIL when within CATCH or when SPEED is not
  ;;                more important than SAFETY.
  ;;  9/23/85 DNG - Use new variable SIMPLE-CALL-MAX-ARG.
  ;;  10/2/85 CLM - Modified for Explorer release 3 complex calls using a
  ;;                call-info-word.
  ;; 10/15/85 CLM - Modified for Explorer release 3 lexpr-funcalls using a
  ;;                call-info-word.
  ;; 11/07/85 CLM - Modified for Rel.3 to prevent creating/using an adi-list.
  ;; 11/11/85 DNG - Fix code generated for a FUNCALL-WITH-MAPPING-TABLE[-INTERNAL]
  ;;                that has no other arguments.
  ;;  2/06/86 DNG - Eliminate use of MEMQL function for simplicity.
  ;;  2/10/86 CLM - Fix to emit the call-info-word before evaluating FCTN-ADDR.
  ;;  2/11/86 CLM - No longer push an entry onto CALL-BLOCK-PDL-LEVELS for a call-
  ;;                block nor increment the pdllvl for a call-block.
  ;;  2/11/86 CLM - Fix for lexpr-funcalls so that the call-info-word
  ;;                won't be pushed twice.
  ;;  2/12/86 CLM - Fix for the last fix which was causing the call-info word to
  ;;                be pushed at the wrong time for lexpr-funcalls -- again!
  ;;  2/17/86 CLM - Add code to handle complex calls with self-mapping-table.
  ;;  3/31/86 DNG - Fix for &QUOTE &REST arg on VM2 -- no more FEXPR-CALL.
  ;;  5/23/86 CLM - Fix for lexpr-funcalls with self-mapping-table, set the bit 
  ;;                in the call-info-word.
  ;;  6/11/86 CLM - Fix to set up the call-info-word correctly for funcalls with
  ;;                self-mapping-table.
  ;;  8/09/86 DNG - Set a flag in the debug-info when D-TAIL is used.
  ;;  8/28/86 CLM - Changed way in which &QUOTE'd args are handled.  Quoting is now
  ;;                done in pass1 (P1ARGC).  The old DESC arg is now a flag to
  ;;                indicate the form is a lexpr-funcall requiring special handling.
  ;;  9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET.
  ;;  9/25/86 DNG - Fix so that when a CALL-N PDL-POP is generated, the function is
  ;;		computed after the number of args is pushed instead of before.
  ;; 12/08/86 DNG - Don't use D-TAIL when one of the arguments might be the
  ;;		&REST arg of the current function.
  ;;  2/28/87 CLM - Fix to increment pdllvl after pushing arguments.
Ï1  ;; 12/12/87 DNG - Use D-TAIL in Scheme mode regardless of OPTIMIZE values.Ï*
  (LET (IDEST CALLI FCTN-ADDR
	(TDEST DEST) (LDEST DEST)	   ;MAY GET CHANGED TO D-PDL BELOW
	ADI-LIST
	(MVTARGET M-V-TARGET)
	(CALL-BLOCK-PDL-LEVELS CALL-BLOCK-PDL-LEVELS)
	(CALL-INFO-WORD 0)
	(nargs (length argl)))
    ;; Whatever our caller wants in the way of multiple values,
    ;; we will do it for him.  Say so.
    (SETQ M-V-TARGET NIL)
    (SETQ IDEST (IF GENERATING-MICRO-COMPILER-INPUT-P
		    'D-NEXT
		  'D-PDL))
    ;;change made 11/11/85
    (SETQ CALLI (IF (AND (NULL ARGL)
			 (NULL MAPPING-TABLE))
		    'CALL0
		  'CALL))
;;TDEST IS DESTINATION ACTUALLY TO BE COMPILED INTO CALL INSTRUCTION.
;;LDEST IS "LOGICAL" DESTINATION.  THIS IS USUALLY THE SAME EXCEPT
;;IN CASE OF MULTIPLE-VALUES.  THEN TDEST IS ASSEMBLED D-IGNORE
;;(IT IS ACTUALLY IGNORED BY THE MICRO-CODE, BUT DOING
;;THIS CONFUSES THE MICRO-COMPILER LEAST), WHILE LDEST IS D-PDL,
;;REFLECTING THE FACT THE VALUES ACTUALLY SHOW UP ON THE PDL.
    ;;changed by CLM 11/07/85, adi-list has become obsolete.
    (UNLESS (COMPILING-FOR-V2)
      (COND
	((NULL MVTARGET))
	((EQ MVTARGET 'MULTIPLE-VALUE-LIST)
	 (SETQ ADI-LIST (CONS MVTARGET (CONS nil ADI-LIST)))
	 (SETQ TDEST 'D-IGNORE
	       LDEST 'D-PDL))
	((EQ MVTARGET 'THROW)
	 (SETQ ADI-LIST `(MULTIPLE-VALUE (QUOTE-VECTOR (QUOTE NIL)) ,@ADI-LIST)
	       TDEST 'D-PDL
	       LDEST 'D-PDL))
	((EQ MVTARGET 'RETURN)
	 (SETQ ADI-LIST `(MULTIPLE-VALUE (QUOTE-VECTOR 'T) ,@ADI-LIST)
	       TDEST 'D-PDL
	       LDEST 'D-PDL))
	((NUMBERP MVTARGET)
	 ;; MVTARGET IS A NUMBER => IT IS NUMBER OF VALUES,
	 ;; JUST LEAVE THEM ON THE STACK.
	 (SETQ ADI-LIST `(MULTIPLE-VALUE (QUOTE-VECTOR ',MVTARGET) ,@ADI-LIST)
	       TDEST 'D-IGNORE
	       LDEST 'D-PDL)))
      ;; Use of FEXPR-CALL turned on 11/16/82.
      ;; 8/22/86 turned off
      #|(LET ((TM (CADAR (LAST DESC))))
	(WHEN (AND (MEMBER 'FEF-ARG-REST TM :TEST #'EQ)
		   (MEMBER 'FEF-QT-QT TM :TEST #'EQ))
	  (SETQ CALLI 'CALL)
	  (SETQ ADI-LIST (CONS 'FEXPR-CALL (CONS NIL ADI-LIST)))))|#
      )
    (SETQ FCTN-ADDR
	  (IF (NULL FUNCTION-VALUE)
	      `(QUOTE-VECTOR (FUNCTION ,FUNCTION-SPEC))
	    FUNCTION-VALUE))
    (UNLESS (AND (COMPILING-FOR-V2)
		 (NOT GENERATING-MICRO-COMPILER-INPUT-P))
      (WHEN (NULL FUNCTION-SPEC)
	(SETQ FCTN-ADDR (P2-SOURCE FCTN-ADDR 'D-PDL)))
      (IF (NULL ADI-LIST)
	  (OUTI (LIST CALLI TDEST FCTN-ADDR))
	(OUTI1 (LIST 'ADI-CALL CALLI TDEST FCTN-ADDR ADI-LIST))))
    (UNLESS (NULL ADI-LIST)
      (MKPDLLVL (+ PDLLVL (LENGTH ADI-LIST))))
    ;;Similar incrementing of the pdllvl in *CATCH was causing
    ;;problems - if there is an unexpected exit from the form,
    ;;this causes too many pops.. take it out for now. 
    (UNLESS (COMPILING-FOR-V2)
      (COND ((NULL MVTARGET))
	    ((EQ MVTARGET 'MULTIPLE-VALUE-LIST)
	     (INCPDLLVL))
	    ((NUMBERP MVTARGET)
	     (MKPDLLVL (+ PDLLVL MVTARGET)))))
    ;;this no longer needed - a call block not generated here
    (UNLESS (COMPILING-FOR-V2)
      (PUSH PDLLVL CALL-BLOCK-PDL-LEVELS)
      (MKPDLLVL (+ 4 PDLLVL)))
    (WHEN (AND (COMPILING-FOR-V2)
	       (OR MAPPING-TABLE
		   LEXPR-FUNCALL 
		   MVTARGET))
      (SETQ CALL-INFO-WORD
	    (DPB NARGS
		 (SYMEVAL-FOR-TARGET 'SI:%%CALL-INFO-NUMBER-OF-ARGUMENTS)
		 CALL-INFO-WORD)) )
    (WHEN (AND (COMPILING-FOR-V2)
	       LEXPR-FUNCALL)
      (SETQ CALL-INFO-WORD
	    (DPB 1 (SYMEVAL-FOR-TARGET 'SI:%%CALL-INFO-LEXPR-FUNCALL-FLAG)
		 CALL-INFO-WORD)))
    ;;process args
    (DO ((ARGS ARGL (CDR ARGS)))
	((NULL ARGS))
      (WHEN (AND (NULL (CDR ARGS))
		 (OR (NOT (COMPILING-FOR-V2))
		     GENERATING-MICRO-COMPILER-INPUT-P)
		 (NULL MAPPING-TABLE))
	(SETQ IDEST 'D-LAST))
      (IF (AND LEXPR-FUNCALL
	       (NULL (CDR ARGS)))
	  (PROGN
	    (P2 (CAR ARGS) 'D-PDL)
	    (UNLESS (COMPILING-FOR-V2)
	      (OUTI1 (LIST 'MISC IDEST '%SPREAD))))
	  (PROGN
	    (P2 (CAR ARGS) IDEST)
	    (WHEN (EQ IDEST 'D-PDL)
	      (INCPDLLVL))) ) )
    ;;02/17/86 CLM
    ;;v2 no longer requires %set-s-m-t
    (UNLESS (COMPILING-FOR-V2)
      (WHEN MAPPING-TABLE
	(P2PUSH MAPPING-TABLE)
	(OUTM '(MISC D-LAST %SET-SELF-MAPPING-TABLE))))
    (WHEN (AND (COMPILING-FOR-V2)
	       (NOT GENERATING-MICRO-COMPILER-INPUT-P))
      ;; After all args pushed, do the CALL instruction.
      (WHEN (AND (EQ TDEST 'D-RETURN)
		 (NOT (EQ KEEP-CURRENT-FRAME T))
		 (NOT WITHIN-CATCH)
		 Ï1(ORÏ* (> (OPT-SPEED OPTIMIZE-SWITCH)
			(OPT-SAFETY OPTIMIZE-SWITCH))
		     Ï1(COMPILING-SCHEME-P))Ï*
		 ;; temporarily avoid using COMPLEX-CALL-TO-TAIL-REC because of microcode bug -- DNG 3/26/87
		 (not (or mapping-table lexpr-funcall))
		 (NOT (AND (SYMBOLP FUNCTION-SPEC)
			   (OR (GET FUNCTION-SPEC :ERROR-REPORTER)
			       (EQ FUNCTION-SPEC 'WARN))))
		 (OR (NOT KEEP-CURRENT-FRAME)
		     (AND (EQ KEEP-CURRENT-FRAME 'REST-ARG) ; set in PASS2
			  ;; If the current function has a &REST arg, have to
			  ;; keep the frame if any of the arguments might be
			  ;; a local variable which points to the rest arg.
			  (EVERY #'(LAMBDA(X)
				     (OR (ATOM X)
					 (MEMBER (CAR X)
						 '(QUOTE SELF-REF LEXICAL-REF FUNCTION BREAKOFF-FUNCTION)
						 :TEST #'EQ)))
				 (THE LIST ARGL))))
		 )
	(SETQ TDEST 'D-TAIL)
	;; Set flag in the debug info because there will be difficulties if
	;; this function is used in a dynamic closure.
	(SETF (GETF (SI:DBIS-PLIST (COMPILAND-DEBUG-INFO *CURRENT-COMPILAND*))
		    'USES-CALLDEST-TAIL-REC)
	      T))
      ;;add the self-mapping-table bit to the call info word	      
      (WHEN MAPPING-TABLE
	(SETQ CALL-INFO-WORD
	      (DPB 1
		   (SYMEVAL-FOR-TARGET 'SI:%%CALL-INFO-SELF-MAP-TABLE-PROVIDED)
		   CALL-INFO-WORD))
	(P2PUSH MAPPING-TABLE) )
      ;;if test changed by CLM 10/31/85 from (null adi-list)
      ;;since adi-list no longer used in rel.3
      (IF (NULL MVTARGET)
	  (IF (OR MAPPING-TABLE
		  lexpr-funcall)
	      (PROGN
		(P2PUSH-CONSTANT CALL-INFO-WORD)
		(IF (NULL FUNCTION-SPEC)
		    (P2PUSH FCTN-ADDR)
		  (OUTI1 (LIST 'MOVE 'D-PDL FCTN-ADDR)))   ;push the fctn
		(OUTI1 (LIST 'AUX 'COMPLEX-CALL TDEST)))   ;emit aux op
	    (IF (<= NARGS (SYMEVAL-FOR-TARGET 'SIMPLE-CALL-MAX-ARG))
		(PROGN
		  (WHEN (NULL FUNCTION-SPEC)
		    (SETQ FCTN-ADDR (P2-SOURCE FCTN-ADDR 'D-PDL)))
		  (OUTI (LIST 'CALL TDEST FCTN-ADDR NARGS)))
	      (PROGN
		(P2PUSH-CONSTANT NARGS)
		(WHEN (NULL FUNCTION-SPEC)
		  (SETQ FCTN-ADDR (P2-SOURCE FCTN-ADDR 'D-PDL)))
		(OUTI (LIST 'CALL-N TDEST FCTN-ADDR)))))
	  ;;added by CLM 10/2/85  
	  (PROGN
	    ;;build call-info-word
	    (COND
	      ((EQ MVTARGET 'MULTIPLE-VALUE-LIST)
	       (SETQ CALL-INFO-WORD
		     (DPB (SYMEVAL-FOR-TARGET 'SI:%MULTIPLE-VALUE-LIST-RETURN)
			  (SYMEVAL-FOR-TARGET 'SI:%%CALL-INFO-RETURN-TYPE)
			  CALL-INFO-WORD)))	   ;ignore number of results field
	      ((EQ MVTARGET 'THROW)
	       (SETQ CALL-INFO-WORD
		     (DPB (SYMEVAL-FOR-TARGET 'SI:%RETURN-ALL-VALUES-WITH-COUNT-ON-STACK)
			  (SYMEVAL-FOR-TARGET 'SI:%%CALL-INFO-RETURN-TYPE)
			  CALL-INFO-WORD)))	   ;the number of values to return
					   ;should be on the stack
	      ((MEMBER MVTARGET '(RETURN RETURN-CATCH) :TEST #'EQ)
	       (SETQ CALL-INFO-WORD
		     (DPB (SYMEVAL-FOR-TARGET 'SI:%RETURN-ALL-VALUES-WITH-COUNT-ON-STACK)
			  (SYMEVAL-FOR-TARGET 'SI:%%CALL-INFO-RETURN-TYPE)
			  CALL-INFO-WORD)))	   ;the number of values to return
					   ;determined later
	      ((NUMBERP MVTARGET)
	       (SETQ CALL-INFO-WORD
		     (DPB (SYMEVAL-FOR-TARGET 'SI:%NORMAL-RETURN)
			  (SYMEVAL-FOR-TARGET 'SI:%%CALL-INFO-RETURN-TYPE)
			  CALL-INFO-WORD))
	       (SETQ CALL-INFO-WORD
		     (DPB MVTARGET
			  (SYMEVAL-FOR-TARGET 'SI:%%CALL-INFO-NUMBER-OF-RESULTS)
			  CALL-INFO-WORD))))
	    
	    (P2PUSH-CONSTANT CALL-INFO-WORD)	   ;push the call info word
	    (IF (NULL FUNCTION-SPEC)
		(P2PUSH FCTN-ADDR)
		(OUTI1 (LIST 'MOVE 'D-PDL FCTN-ADDR)))	   ;instruction to push the function
	    (OUTI1 (LIST 'AUX 'COMPLEX-CALL TDEST)) ) ))
    (COND ((NULL MVTARGET))
	  ((EQ MVTARGET 'MULTIPLE-VALUE-LIST))
	  ((EQ MVTARGET 'GLOBAL:THROW) (RETURN-FROM P2ARGC NIL))
	  ((MEMBER MVTARGET '(RETURN RETURN-CATCH) :TEST #'EQ) (RETURN-FROM P2ARGC NIL))
	  ((NUMBERP MVTARGET) (RETURN-FROM P2ARGC NIL)))
    (UNLESS (EQ LDEST DEST)	   ;INTERESTED IN WHERE VALUE IS, NOT WHAT WAS
      (MOVE-RESULT-FROM-PDL DEST))   ;ASSEMBLED INTO CALL
    (WHEN (EQ DEST 'D-RETURN)
      (TAKE-DELAYED-TRANSFER))
    ))

(DEFUN COMPILE-TOP-LEVEL-FORM ( FORM LAP-MODE EVAL-FN
			       &OPTIONAL (PROCESSING-MODE 'MACRO-COMPILE))
  ;;  7/30/86 DNG - Original.
  ;;  8/14/86 DNG
  ;;  8/15/86 DNG - Fully compile the form if it has more than one local variable.
  ;;  8/23/86 DNG - New optional argument PROCESSING-MODE.
  ;;  9/05/86 DNG - Shortcut for SETQ.
  ;; 10/01/86 DNG - COMPILAND-BREAKOFF-COUNT replaced by COMPILAND-CHILDREN.
  ;; 10/03/86 DNG - Modify local variable count to not include deleted variables.
  ;; 10/11/86 DNG - Don't leave random forms to be evaluated in write-protected area.
  ;;  1/16/87 DNG - When QC-FILE-IN-CORE-FLAG check COMPILED-FUNCTION-P and
  ;;		FEF-FLAVOR-NAME before skipping compilation.
  ;;  1/21/87 DNG - Call COMPILATION-DEFINE for top-level dummy functions.
  ;;  5/05/87 DNG - Fix SPR 4544 and 4508.
  ;;  6/17/87 DNG - Don't create gensym function names in temporary area.  [SPR 5063]
Ï1  ;; 12/12/87 DNG - Modified to handle Scheme mode.Ï*
  (DECLARE (UNSPECIAL LAP-MODE))
  (COND ((OR (ATOM FORM)
	     (MEMBER (FIRST FORM) '( QUOTE DEFPROP REMPROP SPECIAL ) :TEST #'EQ)
	     (AND (OR (MEMBER (FIRST FORM) '(SI:DEFVAR-1 SI:DEFCONST-1) :TEST #'EQ)
		      (AND (EQ (FIRST FORM) 'SETQ) (NULL (CDDDR FORM))))
		  (CONSTANTP (THIRD FORM))))
	 ;; shortcut to save time for some common trivial forms
	 (FUNCALL EVAL-FN (ENABLE-WRITE FORM)))
	((AND (EQ (FIRST FORM) 'FDEFINE)
	      (QUOTEP (SECOND FORM))
	      (EQ (CAR-SAFE (THIRD FORM)) 'FUNCTION)
	      (MEMBER (CAR-SAFE (SECOND (THIRD FORM)))
		      '(GLOBAL:LAMBDA CLI:LAMBDA GLOBAL:SUBST CLI:SUBST
			GLOBAL:NAMED-LAMBDA NAMED-LAMBDA
			GLOBAL:NAMED-SUBST NAMED-SUBST MACRO)
		      :TEST #'EQ)
	      (OR (EQ (FOURTH FORM) T)
		  (AND (CONSTANTP (FOURTH FORM))
		       (EVAL (FOURTH FORM))))
	      (NOT (FIFTH FORM)))
	 ;; Special shortcut for (FDEFINE 'name #'(LAMBDA ...) T)
	 ;; which is what most function-defining macros expand into.
	 (LET ((NAME (SECOND (SECOND FORM))) DEF)
	   (IF (AND QC-FILE-IN-CORE-FLAG
		    (SETQ DEF (SI:FDEFINITION-SAFE NAME T))
		    (OR (COMPILED-FUNCTION-P DEF)
			(AND (CONSP DEF) (EQ (CAR DEF) 'MACRO) (COMPILED-FUNCTION-P (CDR DEF))))
		    (NULL (SI:FEF-FLAVOR-NAME DEF)) ; no SELF-MAP addressing used
		    )
	       ;; Just dump the current definition.
	       (FUNCALL EVAL-FN `(FDEFINE ,(SECOND FORM) ',DEF . ,(CDDDR FORM)))
	     ;; Else compile the function.
	     (record-individual-time 'qc-translate-function
	       (QC-TRANSLATE-FUNCTION NAME (SECOND (THIRD FORM)) PROCESSING-MODE LAP-MODE)))
	   NAME))
	(T
	 ;; arbitrary form -- run it through pass 1 of the compiler to check
	 ;; for errors, expand macros, optimize, and collect information for
	 ;; deciding how it should be handled.
	 (LET ( RESULT IFORM NLOCAL )
	   (record-individual-time 'compile-top-level-form
	     (IF (NULL *CURRENT-COMPILAND*)
		 (SETQ *CURRENT-COMPILAND* (MAKE-COMPILAND))
	       (FILL (THE COMPILAND *CURRENT-COMPILAND*) NIL))
	     (LET ((CC *CURRENT-COMPILAND*))
	       (DECLARE (TYPE COMPILAND CC))
	       (SETF (COMPILAND-DEFINITION CC) Ï1(IF (SI:SCHEME-ON-P)Ï*
						Ï1   `(LAMBDA () (SI:WITH-SCHEME-SEMANTICSÏ*
								   Ï1(INHIBIT-STYLE-WARNINGS ,FORM)))Ï*
						 `(LAMBDA () (INHIBIT-STYLE-WARNINGS ,FORM))Ï1)Ï*
		     (COMPILAND-DECLARATIONS CC) LOCAL-DECLARATIONS
		     (COMPILAND-OPTIMIZE CC) OPTIMIZE-SWITCH
		     (COMPILAND-CHILDREN CC) NIL
		     (COMPILAND-NESTING-LEVEL CC) 0)
	       (SETQ RESULT (QC-TRANSLATE-FUNCTION NIL CC
						   PROCESSING-MODE
						   LAP-MODE NIL T))))
	   (IF (AND (NOT (NULL RESULT))
		    (OR (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES RESULT)
			(> (COMPILAND-EXPRESSION-SIZE RESULT) 30.)
			(> (SETQ NLOCAL (COUNT 'FEF-ARG-INTERNAL-AUX
					       (THE LIST (COMPILAND-ALLVARS RESULT))
					       :KEY #'VAR-KIND :TEST #'EQ))
			   1)
			(AND (COMPILAND-CHILDREN RESULT)
			     (NEQ LAP-MODE 'COMPILE-TO-CORE)
			     (OR SI:FILE-IN-COLD-LOAD ; Genasys can't handle anonymous FEFs [SPR 4508]
				 (DOLIST (CHILD (COMPILAND-CHILDREN RESULT) NIL)
				   (UNLESS (NULL (COMPILAND-CHILDREN CHILD))
				     ;; QLAPP can't properly handle nested functions in
				     ;; QFASL-NO-FDEFINE mode. [SPR 4544]
				     (RETURN T)))))
			(AND (NULL (SETQ IFORM
					 (AND (= NLOCAL 0)
					      (CATCH 'NO
						(PREPARE-COMPILED-FORM-FOR-EVALUATION
						  (COMPILAND-EXP2 RESULT)) ))))
			     (NOT (NULL (COMPILAND-CHILDREN RESULT))))))
	       ;; Finish compiling the dummy function and then call it.
	       (LET (( NAME (LET ( #+LispM (SI:*GENSYM-PREFIX* "F")
				  (DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))
			      (GENSYM) )))
		 (SETF (COMPILAND-FUNCTION-SPEC RESULT) NAME)
		 (WHEN (NULL (COMPILAND-FUNCTION-NAME RESULT))
		   (SETF (COMPILAND-FUNCTION-NAME RESULT) NAME))
		 (UNLESS (EQ LAP-MODE 'COMPILE-TO-CORE)
		   (COMPILATION-DEFINE NAME))
		 (record-individual-time 'qc-translate-function
		   (QC-TRANSLATE-FUNCTION NAME RESULT PROCESSING-MODE LAP-MODE))
		 (SETF (COMPILAND-FUNCTION-SPEC RESULT) NIL) ; for TOP-LEVEL-DUMMY-FUNCTION-P 
		 (FUNCALL EVAL-FN `(,NAME)))
	     (IF (NULL IFORM)
		 ;; Evaluate the source form.
		 (PROGN
		   #+compiler:debug
		   (when (and compiler-verbose
			      (string-equal user-id "GRAY"))
		     (let ((*print-length* 8) (*print-level* 3))
		       (format t "~%[eval original form: ~S" form)))
		   (FUNCALL EVAL-FN
			    (IF (AND SI:FILE-IN-COLD-LOAD
				     (NOT (EQ LAP-MODE 'COMPILE-TO-CORE)))
				(LET ((*EVALHOOK* #'EVAL-FOR-TARGET))
				  (MACROEXPAND-ALL FORM))
			      (ENABLE-WRITE FORM))))
	       ;; Evaluate the partially compiled form.
	       (FUNCALL EVAL-FN IFORM) ))
	   ))))

(DEFÏ1VARÏ* TEST-MEMBER-ALIST
   '((EQ . MEMQ) (EQUAL . SI:MEMBER-EQUAL)
     (EQL . MEMBER-EQL) (EQUALP . MEMBER-EQUALP)
     Ï1(SCHEME:EQV? . SCHEME:MEMV)Ï*)
   "Alist of test functions and functions which can be used to check whether any member
of a list satisfies the test. Eg (EQ . MEMQ)")

Ï1;; This is not altered; just needs to be recompiled with INVULNERABLE-EXPRESSION-P change.Ï*
(DEFUN INDEPENDENT-EXPRESSIONS-P (FORM1 FORM2)
  ;; Are FORM1 and FORM2 independent expressions?  That, is, can they
  ;; be evaluated in either order without changing the results?
  ;;  8/19/85 - Original version.
  ;;  4/21/86 - FUNCTION form can't interact with anything else.
  ;;  9/18/86 - Use new function INVULNERABLE-EXPRESSION-P .
  ;; 10/18/86 - (%POP) can't be interchanged with anything.
  (COND ((INVULNERABLE-EXPRESSION-P FORM1)
	 (OR (ATOM FORM2)
	     (NOT (MEMBER (FIRST FORM2) STACK-MANIPULATORS :TEST #'EQ))))
	((INVULNERABLE-EXPRESSION-P FORM2)
	 (OR (ATOM FORM1)
	     (NOT (MEMBER (FIRST FORM1) STACK-MANIPULATORS :TEST #'EQ))))
	((AND SIDE-EFFECT-ENABLE
	      (EQ (CAR-SAFE FORM1) 'THE-EXPR)
	      (EQ (CAR-SAFE FORM2) 'THE-EXPR))
	 (AND (ZEROP (LOGAND (EXPR-USED FORM1) (EXPR-ALTERED FORM2)))
	      (ZEROP (LOGAND (EXPR-USED FORM2) (EXPR-ALTERED FORM1)))))
	(T (AND (NO-SIDE-EFFECTS-P FORM1)
		(NO-SIDE-EFFECTS-P FORM2)))))

(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.
Ï1  ;;  3/22/88 DNG - When in Scheme mode, it is not safe to propagate FUNCTION 
  ;;Ï*		Ï1forms since they could really be global Scheme variables.Ï*
  (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))
    (IF (COMPILING-FOR-V2)
	;; Explorer release 3
	(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 (P1V 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) ) )
      ;; Else compiling for Explorer release 1 or 2.
      (PROGN
	(COND ((NULL INIT-FORM))
	      ;; The following commented out so P1 will update EXPRESSION-SIZE.
	 #|   ((AND (NOT (ATOM INIT-FORM))
		    (EQ (CAR INIT-FORM) 'QUOTE)))
	      ((OR (NUMBERP INIT-FORM)
		   (STRINGP INIT-FORM)
		   (EQ INIT-FORM T) )
	       (SETQ INIT-FORM `',INIT-FORM))  |#
	      ((OR (EQUAL INIT-FORM '(UNDEFINED-VALUE))
		   #+compiler:debug	   ; temporary while COMPILER2 package is used.
		   (EQUAL INIT-FORM '(COMPILER:UNDEFINED-VALUE)))
	       ;;This is simplest thing that works.
	       ;; More hair is not needed for the ways these are usually generated by SETF.
	       (SETQ TLFUNINIT T))
	      (T
	       ;; Init is not NIL, constant or self => must P1 it, and maybe set TLFUNINIT.
	       (UNLESS (EQ PARALLEL 'DONT-P1)	   ; unless P1 was already applied
		 (LET ((TLEVEL NIL))
		   (SETQ INIT-FORM (P1V INIT-FORM))) )
	       (COND ((EQUAL INIT-FORM '(QUOTE NIL))
		      (SETQ INIT-FORM NIL))
		     ((NOT (ADRREFP INIT-FORM))
		      (SETQ TLFUNINIT T)))))
	;; Now that we have processed the init form, determine the ADL initialization field.
	;; First, must we, or would we rather, use code to initialize the variable?
	;; Note: specified-flags MUST be initted at entry time regardless of anything else.
	(COND ((AND (NOT (MEMBER 'FEF-ARG-SPECIFIED-FLAG (VAR-MISC HOME)))
		    (OR (MEMBER KIND '(FEF-ARG-INTERNAL-AUX FEF-ARG-KEY) :TEST #'EQ)
			TLFUNINIT
			;; Don't spoil the fast arg option with nontrivial inits for aux's.
			(AND (EQ KIND 'FEF-ARG-AUX)
			     FAST-ARGS-POSSIBLE
			     (NOT (NULL INIT-FORM)))
			(COND (PARALLEL (NEQ TYPE 'FEF-LOCAL)))))
	       (SETQ INIT-TYPE 'FEF-INI-COMP-C)
	       (SETQ INIT-DATA INIT-FORM)  ; for value propagation
	       ;; Note: if we are initting by code, there is no advantage
	       ;; in binding at function entry, and doing so would
	       ;; make lap stupidly turn off the fast arg option!
	       (WHEN (EQ KIND 'FEF-ARG-AUX)
		 (SETF (VAR-KIND HOME) (SETQ KIND 'FEF-ARG-INTERNAL-AUX)))
	       (SETQ TLFUNINIT T)))
	;; If we aren't forced already not to use an init, figure out
	;; what type of init to use if there's no init-form: either "none" or "nil".
	(WHEN (NULL INIT-TYPE)
	  (SETQ INIT-TYPE
		(COND ((OR (EQ KIND 'FEF-ARG-OPT)
			   (AND (EQ KIND 'FEF-ARG-AUX)
				(EQ TYPE 'FEF-SPECIAL)))
		       'FEF-INI-NIL)
		      (T 'FEF-INI-NONE))))
	;; Then, if there is an init form, gobble it.
	(COND ((AND INIT-FORM
		    (NEQ INIT-TYPE 'FEF-INI-COMP-C))
	       (COND ((NOT (MEMBER KIND '(FEF-ARG-OPT FEF-ARG-AUX FEF-ARG-INTERNAL-AUX FEF-ARG-KEY)
				   :TEST #'EQ))
		      (WARN 'BAD-ARGUMENT-LIST ':IMPOSSIBLE
			    "The mandatory argument ~S was given a default value."
			    NAME))
		     ;; There's a hack for binding a special var to itself.
		     ((AND (EQ NAME INIT-FORM)
			   (NEQ TYPE 'FEF-LOCAL))
		      (SETQ INIT-TYPE 'FEF-INI-SELF))
		     ((ATOM INIT-FORM)
		      (SETQ INIT-TYPE 'FEF-INI-C-PNTR)
		      (SETQ INIT-DATA (LIST 'LOCATIVE-TO-S-V-CELL INIT-FORM)))
		     ((EQ (CAR INIT-FORM) 'LOCAL-REF)
		      (SETQ INIT-TYPE 'FEF-INI-EFF-ADR)	   ;Initted to value of local var
		      (SETQ INIT-DATA (LIST 'FIXE INIT-FORM)))
		     ((MEMBER (CAR INIT-FORM) '(QUOTE FUNCTION BREAKOFF-FUNCTION SELF-REF) :TEST #'EQ) 
		      (SETQ INIT-TYPE 'FEF-INI-PNTR)
		      (SETQ INIT-DATA INIT-FORM))
		     (T (BARF INIT-FORM "init-form calculation confused" 'BARF)))))
	(WHEN (AND (EQ KIND 'FEF-ARG-OPT)
		   (OR TLFUNINIT SPECIFIED-FLAG-NAME))
	  ;; Once an opt arg gets an alternate starting address,
	  ;; all following args must be similar or else FEF-INI-COMP-C.
	  (SETQ TLFUNINIT T)
	  (SETQ INIT-TYPE 'FEF-INI-OPT-SA)
	  (SETQ INIT-DATA (GENSYM)) )
	) )				   ; end of not compiling for VM2
    (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) )
    (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)
	       (< (OPT-SAFETY OPTIMIZE-SWITCH) 2)
	       (EQ INIT-FORM INIT-DATA)
	       (OR (NULL INIT-FORM)
		   (AND (CONSP INIT-DATA)
			(OR (MEMBER (FIRST INIT-DATA)
				    Ï1'(QUOTE BREAKOFF-FUNCTION)Ï* :TEST #'EQ)
			    Ï1(AND (EQ (FIRST INIT-DATA) 'FUNCTION)Ï*
				  Ï1(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))) )
      )
    (UNLESS (EQ KIND 'FEF-ARG-REQ)
      (BLOCK CHECK-DECLARATION
	(LET ((DECLARED-TYPE (GETF (VAR-DECLARATIONS HOME) 'TYPE 'UNKNOWN)))
	  (IF (OR (EQ DECLARED-TYPE 'UNKNOWN)
		  (NOT (SI:TYPE-SPECIFIER-P DECLARED-TYPE)))
	      (RETURN-FROM CHECK-DECLARATION)
	    (IF (OR (NULL INIT-FORM) (QUOTEP INIT-FORM))
		(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."
			DECLARED-TYPE 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))
		    (WARN 'SI:DISJOINT-TYPEP ':IMPOSSIBLE
			  "~S is declared to be of type ~S but its initial value is a ~S."
			  NAME DECLARED-TYPE INIT-TYPE)
		  (RETURN-FROM CHECK-DECLARATION)
		  ))))
	  (REMF (VAR-DECLARATIONS HOME) 'TYPE) ; discard the bad declaration
	  )))
    (IF (NULL INIT-FORM)
	NAME
      (LIST NAME INIT-FORM))))		   ; end of VAR-COMPUTE-INIT 

(DEFUN ENSURE-VALUE-USED (FORM)
  ;; Style checker for destructive functions that should be used for their returned value.
  ;; 11/30/87 DNG - Original.
  ;; 12/12/87 DNG
  ;;  3/28/88 DNG - Add check for SETF-EXPAND property.
  (UNLESS P1VALUE ; value being used
    (LET ((ARG (IF (CDDR FORM) (THIRD FORM) (SECOND FORM))))
      (IF (OR (SYMBOLP ARG)
	      (AND (CONSP ARG) (SYMBOLP (FIRST ARG))
		   (GETL (FIRST ARG) '(SI:SETF-METHOD SI:LOCF-METHOD SI::SETF-EXPAND))))
	  (WARN 'ENSURE-VALUE-USED ':IMPLAUSIBLE
		"Not using the value returned by ~S;
Should do: (~A ~S ~S)."
		(FIRST FORM)
		(IF (COMPILING-SCHEME-P) 'SCHEME:SET! 'SETF)
		ARG FORM)
	(WARN 'ENSURE-VALUE-USED ':IMPLAUSIBLE
	      "Not using the value returned by ~S." FORM)))))