;;;;  -*- Mode:Common-Lisp; Package:Compiler; Base:10. -*-
;;;
;;;                           RESTRICTED RIGHTS LEGEND
;;;
;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1984-1989 Texas Instruments Incorporated. All rights reserved.
;;; Copyright (C) 1980 Massachusetts Institute of Technology


;;;;   *-----------------------------------------------------------*
;;;;   |           --  TI Explorer Lisp Compiler  --               |
;;;;   |  This file contains the pass 2 driver and utility	   |
;;;;   |  functions.						   |
;;;;   *-----------------------------------------------------------*

;;; Revision history:
;;; Feb. 1984 - Version 98 from MIT via LMI.
;;; July '84 through 4/30/85 - TI modifications for Explorer release 1.0.
;;; 06/26/85 - Minor modifications to improve speed of compilation.
;;; 07/10/85 - For release 3, file QCP2 split into P2DEFS, P2FUNS, and P2HAND.
;;; 12/07/85 -
;;;   ...
;;;  8/08/86 - Changes to handling of non-local lexical variables and breakoff-functions.
;;; 12/08/86 DNG - Don't use D-TAIL-REC from function with a &REST arg.
;;; 12/18/86 DNG - Fix P2 to decrement PDLLVL on a %POP when debug printout removed.
;;; 12/22/86 DNG - Fix P2-DESTINATION for LEXICAL-REF re-allocated by EXTEND-LOCAL-VARIABLES.
;;;  2/04/87 DNG - Modify P2MISC for efficiency.
;;;  2/13/87 DNG - Use COMPILAND-INITIAL-ENVIRONMENT-VARS in PASS2.
;;;  3/23/87 DNG - Fix to not use D-TAIL-REC call from frame having a locative to a local var.
;;;  3/25/87 DNG - Fix to not use D-TAIL-REC call from function used in a dynamic closure.
;;;------------------ The following done for Explorer release 5.0 ------
;;;  8/04/88 DNG - Added DEF and doc string for %POP.
;;;------------------ The following done for Explorer release 6.0 ------
;;;  3/15/89 DNG - Update P2ARGC for CLOS.

(DEFUN PASS2 (LAMBDA-LIST EXPRESSION &OPTIONAL OLD-VARS)
  ;; This is the top-level routine of pass 2.  It is called by QCOMPILE2.
  ;;  8/24/85 DNG - Original version separated from QCOMPILE0.
  ;; 12/07/85 DNG - For release 3, don't call P2SBIND.
  ;;  1/09/86 DNG - New variable ENVIRONMENT-DESCRIPTOR-LIST.
  ;;  1/18/86 DNG - Revise layout of ENVIRONMENT-DESCRIPTOR-LIST.
  ;;  2/21/86 DNG - Invert sense of arg/loc bit in env.desc. list.
  ;;  2/24/86 DNG - Use %LOGDPB	instead of DPB in constructing env.desc. list.
  ;;  5/08/86 DNG - Don't use D-TAIL-REC from a flavor method because of the
  ;;		special variable bindings for SELF and SELF-MAPPING-TABLE.
  ;;  5/19/86 DNG - Move binding of LEXICAL-CLOSURE-COUNT to include the call
  ;;		to P2SBIND. [SPR 2236]
  ;;  6/10/86 DNG - New argument OLD-VARS passed thru to P2SBIND -- needed in case
  ;;		the call to PROCESS-PERVASIVE-DECLARATIONS from QCOMPILE0 created
  ;;		any special variables.
  ;;  7/08/86 DNG - Update to use new COMPILAND structure.
  ;;  7/14/86 DNG - Add support for LEX-B addressing.
  ;;  9/10/86 DNG - Set value flag in ENVIRONMENT-DESCRIPTOR-LIST for unaltered variables.
  ;; 10/16/86 DNG - Reserve space in lexical environment for phantom variables.
  ;; 12/08/86 DNG - Set KEEP-CURRENT-FRAME when there is a &REST arg.
  ;;  1/15/87 DNG - Don't set SI:%%LEXENV-DESC-VALUE bit for BREAKOFF-FUNCTIONs.
  ;;  2/13/87 DNG - Use COMPILAND-INITIAL-ENVIRONMENT-VARS instead of checking initial value.
  ;;  3/23/87 DNG - Set KEEP-CURRENT-FRAME true when there is a locative to a local variable.
  ;;  3/25/87 DNG - Set KEEP-CURRENT-FRAME for functions used in a dynamic closure.
  ;;  4/05/89 DNG - Don't need to bind CLOSURE-DISCONNECT-OFFSETS anymore.
  ;;  4/27/89 DNG - Warn if the lexical environment is longer than can be addressed.
  (LET ((PDLLVL 0)			   ;RUNTINE LOCAL PDLLVL
	(DROPTHRU T)			   ;CAN DROP IN IF FALSE, FLUSH STUFF TILL TAG OR
	(MAXPDLLVL 0)			   ;DEEPEST LVL REACHED BY LOCAL PDL
	(TAGOUT NIL)
	(WITHIN-CATCH NIL)
	CALL-BLOCK-PDL-LEVELS
	;; Can't use D-TAIL-REC when there is an implicit binding of the special
	;;  variables SELF and/or SELF-MAPPING-TABLE.
	(KEEP-CURRENT-FRAME
	  (LET ((FSPEC (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*)))
	    (OR (COMPILAND-SELF-MAP-NEEDED *CURRENT-COMPILAND*)
		(EQ (CAR-SAFE FSPEC) ':METHOD)
		;; following flag set in (:PROPERTY VARIABLE-LOCATION P1) or P1CLOSURE
		(GETF (COMPILAND-PLIST *CURRENT-COMPILAND*) 'KEEP-CURRENT-FRAME)
		(AND (NOT (EQ (CAR-SAFE FSPEC) ':INTERNAL))
		     (VALIDATE-FUNCTION-SPEC FSPEC)
		     (FUNCTION-SPEC-GET FSPEC 'USED-IN-DYNAMIC-CLOSURE)) ; set in P1CLOSURE
		(AND (MEMBER 'FEF-ARG-REST VARS :KEY #'VAR-KIND :TEST #'EQ)
		     'REST-ARG))))
	(ENVIRONMENT-DESCRIPTOR-LIST NIL))
    (WHEN (COMPILING-FOR-V2)
      (SETQ ENVIRONMENT-DESCRIPTOR-LIST
	    (CONS (+ (LENGTH (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES *CURRENT-COMPILAND*))
		     (LENGTH (GETF (COMPILAND-PLIST *CURRENT-COMPILAND*) 'PHANTOM-VARS)))
		  (LOOP FOR HOME IN (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES *CURRENT-COMPILAND*)
			COLLECT
			(LET* ((ADDR (VAR-LAP-ADDRESS HOME))
			       (CODE (SECOND ADDR)))
			  (COND ((EQ (FIRST ADDR) 'ARG)
				 (SETQ CODE
				       (%LOGDPB 1 (SYMEVAL-FOR-TARGET 'SI:%%LEXENV-DESC-ARG) CODE)))
				#+compiler:debug
				((NEQ (FIRST ADDR) 'LOCBLOCK)
				 (BARF ADDR 'VARIABLES-USED-IN-LEXICAL-CLOSURES 'BARF)))
			  (WHEN (AND (MEMBER 'FEF-ARG-NOT-ALTERED (VAR-MISC HOME))
				     (MEMBER HOME (COMPILAND-INITIAL-ENVIRONMENT-VARS *CURRENT-COMPILAND*)
					     :TEST #'EQ) )
			    ;; For a variable which is initialized before the first lexical closure
			    ;; is created and is never altered after that, its value can be copied
			    ;; out to the environment without needing to use indirection.
			    (SETQ CODE (%LOGDPB 1 (SYMEVAL-FOR-TARGET 'SI:%%LEXENV-DESC-VALUE) CODE)))
			  CODE))))
      (WHEN (> (CAR ENVIRONMENT-DESCRIPTOR-LIST) '#.(EXPT 2 (BYTE-SIZE %%CONTEXT-DESC-SLOT)))
	(WARN 'ENVIRONMENT-DESCRIPTOR-LIST ':IMPLEMENTATION-LIMIT
	      "Too many variables in the lexical environment."))
      )
    (OUTF 'PROGSA)
    (LET ((LEXICAL-CLOSURE-COUNT 0))
      (IF (COMPILING-FOR-V2)
	  (PROGN
	    (WHEN (SECOND *LEXICAL-REGISTER-LEVELS*)
	      (OUTI `(LOCATE-LEXICAL-ENVIRONMENT ,(SECOND *LEXICAL-REGISTER-LEVELS*)))
	      (OUTI `(POP 0 (LOCBLOCK ,(SYMEVAL-FOR-TARGET 'SI:LEX-ENV-B-REG)))))
	    (WHEN (AND (FIXNUMP (FIRST *LEXICAL-REGISTER-LEVELS*))
		       (> (FIRST *LEXICAL-REGISTER-LEVELS*) 0))
	      (OUTI `(LOCATE-LEXICAL-ENVIRONMENT ,(FIRST *LEXICAL-REGISTER-LEVELS*)))
	      (OUTI `(POP 0 (LOCBLOCK ,(SYMEVAL-FOR-TARGET 'SI:LEX-ENV-A-REG)))))
	    ;; In release 3, if a function takes optional arguments, the micro-code
	    ;; pushes the number of optionals supplied on the stack before
	    ;; executing the first instruction.  The PDLLVL is initialized to 1
	    ;; here to avoid getting a warning message from P2 when the count is
	    ;; popped off for the %DISPATCH.
	    ;; P2SBIND is not called because PASS1 has included code in EXPRESSION
	    ;; to do any necessary initialization of arguments.
	    (SETQ PDLLVL 1))		   ; number of optional arguments supplied is on stack
	;; Else VM1
	(P2SBIND LAMBDA-LIST VARS OLD-VARS))	   ;Can compile initializing code
      (UNLESS (NULL (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES *CURRENT-COMPILAND*))
	(SETQ KEEP-CURRENT-FRAME T))
      (P2 EXPRESSION 'D-RETURN)) ; generate code for the function body
    (OUTF '(NO-DROP-THROUGH))
    (OUTF (LIST 'PARAM 'MXPDL (1+ MAXPDLLVL)))
    )) 

;; Compile a form for multiple values (maybe).
;; If our value is non-nil, it means that the code compiled
;; failed to produce the multiple values as it was asked to.
;; Normally, the destination should be D-PDL.
;; If you use another destination, then, if the value returned is non-NIL
;; then the single value has been compiled to the given destination,
;; but if the value is NIL, then the destination has been ignored.
;; This happens because forms that know how to generate the multiple
;; values setq M-V-TARGET to NIL.

;; Note: It is assumed that D-RETURN never has an M-V-TARGET,
;; and that an M-V-TARGET of MULTIPLE-VALUE-LIST implies D-PDL.

(DEFUN P2MV (FORM DEST M-V-TARGET)
 ;;  2/18/86 Add special handling for CHANGE-PDLLVL.
  (IF (NULL M-V-TARGET)
    (P2 FORM DEST)
    (COND ((ADRREFP FORM)
	   (P2 FORM DEST))
	  ((MEMBER (CAR FORM) '(LEXICAL-REF %POP) :TEST #'EQ)
	   (P2 FORM DEST))
	  ((EQ (CAR FORM) 'CHANGE-PDLLVL)
	   (RETURN-FROM P2MV
	     (PROG1
	       (P2MV (CADDR FORM) DEST M-V-TARGET)
	       (MKPDLLVL (+ PDLLVL (CADR FORM))))))
	  (T (P2F FORM DEST))))
  M-V-TARGET) 

(DEF %POP) ; Sub-primitive implemented by special handling in P2 below.
(SETF (GET '%POP 'ARGLIST) '())
(SETF (DOCUMENTATION '%POP) "Pop the top value off the stack.")
(DEFPROP %POP P2 P2) ; for the benefit of DOC:DOCUMENT-FUNCTION .

;Compile code to compute FORM and put the result in destination DEST.
;If DEST is D-IGNORE, we may not actually bother to compute the value
;if we can tell that there would be no side-effects.

(DEFUN P2 (FORM DEST)
  ;;  7/03/85 DNG - Add special handling of D-RETURN for release 3.
  ;;  7/19/85 DNG - Call P2PUSH-CONSTANT instead of emitting PUSH-NUMBER directly.
  ;;  8/22/85 DNG - Use RETURN-NIL and RETURN-T instructions.
  ;;  8/28/85 DNG - Use PUSH-CONSTANT for constants other than numbers.
  ;;  1/09/86 DNG - LOAD-FROM-HIGHER-CONTEXT instead of %LOAD-FROM-HIGHER-CONTEXT.
  ;;  1/14/86 DNG - Implement addressing mode LEX-A.
  ;;  7/02/86 DNG - Change handling of LEXICAL-REF addresses.
  ;; 12/18/86 DNG - Fix to decrement PDLLVL on a %POP when debug printout removed.
  (DECLARE (INLINE ADRREFP QUOTEP))
  (WHEN (MEMBER DEST '(D-PDL D-NEXT) :TEST #'EQ)
    (NEEDPDL 1))
  (COND ((ADRREFP FORM)
	 (COND ((EQ DEST 'D-IGNORE))
	       ((AND (EQ DEST 'D-RETURN)
		     (COMPILING-FOR-V2))
		(COND ((EQUAL FORM '(QUOTE NIL)) (OUTI '(AUX RETURN-NIL)))
		      ((EQUAL FORM ''T) (OUTI '(AUX RETURN-T)))
		      (T
		       ;; (OUTI `(RETURN 0 ,(P2-SOURCE FORM DEST)))
		       ;; This will really be a RETURN instruction, but for now
		       ;; emit a MOVE D-RETURN because that is what the peephole
		       ;; optimizer understands; LAP-WORD-EVAL will change it to
		       ;; a RETURN instruction.
		       (OUTI `(MOVE D-RETURN ,(P2-SOURCE FORM DEST)))))
		(WHEN DROPTHRU
		  (OUTF '(NO-DROP-THROUGH))
		  (SETQ DROPTHRU NIL) ))
	       ((AND (EQ DEST 'D-PDL)
		     (QUOTEP FORM))
		(P2PUSH-CONSTANT (SECOND FORM)))
	       (T (OUTI `(MOVE ,DEST ,(P2-SOURCE FORM DEST))) )))
	((EQ (CAR FORM) 'LEXICAL-REF) ; (LEXICAL-REF level count)
	 (UNLESS (EQ DEST 'D-IGNORE)
	   (LET ((ADR (LEX-REF-ADDRESS FORM)))
	     (DECLARE (UNSPECIAL ADR))
	     (IF (CONSP ADR)
		 (OUTI `(MOVE ,DEST ,ADR))
	       (IF (NOT (COMPILING-FOR-V2))
		   (PROGN
		     (P2PUSH-CONSTANT ADR)
		     (OUTI `(MISC ,DEST %LOAD-FROM-HIGHER-CONTEXT)) )
		 (NO-D-RETURN
		   (P2PUSH-CONSTANT ADR)
		   (OUTI `(MISC ,DEST LOAD-FROM-HIGHER-CONTEXT)) ))))))
	((EQ (CAR FORM) '%POP)		   ;Must check for this before calling P2F
					   ;so that we can decrement PDLLVL.
	 (IF (ZEROP PDLLVL)
	     (progn
	       #+compiler:debug
	       (FORMAT T "~%warn: pop done at top level of pdl while compiling ~S"
		     (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*)))	     ;***
	   (SETQ PDLLVL (1- PDLLVL)))
	 (MOVE-RESULT-FROM-PDL DEST))
	((EQ (CAR FORM) 'CHANGE-PDLLVL)
	 (LET (BDEST
	       M-V-TARGET)
	   (PROG1
	     (P2F (CADDR FORM) DEST)
	     (MKPDLLVL (+ PDLLVL (CADR FORM))))))
	(T (LET (BDEST
		 M-V-TARGET)
	     (P2F FORM DEST))))) 

(DEFUN P2F (FORM DEST)
 ;;  4/23/85 DNG - Don't call P2MISC if the number of arguments is wrong,
 ;;                so an error will be reported at run-time. [bug 1574]
 ;;  7/10/85 DNG - Re-written for release 3 instruction set.
 ;;  7/12/85 DNG - Use MISC-op instead of a class II with PDL-POP source.
 ;;  7/17/85 DNG - Fix to work for release 1 instruction set.
 ;;  7/24/85 DNG - Fix to not call P2DEST for rel. 2 instruction set.
 ;;  7/29/85 DNG - Add handling of AUX ops.
 ;;  8/24/85 DNG - Fix bug on destination D-INDS.
 ;; 10/02/85 DNG - Use instructions PREDICATE and RETURN-PRED.
 ;;  1/20/86 DNG - Fix AUX op with D-RETURN; warning on function that just calls itself.
 ;;  1/28/86 DNG - Modify AUX op handling to give preference to Misc-op.
 ;;  6/09/86 DNG - Fix to not call P2MISC with a null argument list when M-V-TARGET.
 ;;  8/09/86 DNG - Use macro BOOLEAN-FUNCTION-P instead of BOOLEAN-FUNCTIONS list.
 ;;  8/28/86 CLM - Calls to P2ARGC no longer require the result of GETARGDESC.
 ;;  4/11/88 CLM - Optimize to use main-ops instead of misc-ops when there is a
 ;;                PDL-POP source (undo change of 7/12/85).
  (DECLARE (INLINE GET-FOR-TARGET GET-OPCODES)
	   (OPTIMIZE (SPEED 2) (SPACE 1)))
  (LET* ((PDLLVL PDLLVL)
	 (FN (FIRST FORM))
	 (ARGL (REST FORM))
	 HANDLER
	 OPCODES
	 NARGS)
    (COND ((AND (EQ (CADR BDEST) 'NULL)
		(NULL (CDDR FORM))
		(GET-FOR-TARGET FN 'DEF-BRANCH-OP))
	   ;; A predicate that can be tested by a conditional branch.
	   (LET ((SENSE (OTHER (CADDR BDEST))))
	     (P2BRANCH (FIRST ARGL) DEST `(BRANCH ,FN ,SENSE ,@(CDDDR BDEST))))
	   (SETQ BDEST nil))
	  ((AND (NOT (NULL (SETQ HANDLER (GET FN 'P2))))
		(OR (NEQ HANDLER 'P2DEST)
		    (NOT (COMPILING-FOR-V2))))
	   (LET ((P2FN FN))
	     (FUNCALL HANDLER ARGL DEST)))
	  ((AND (NOT (NULL (SETQ OPCODES (GET-OPCODES FN))))
		(EQ (SETQ NARGS (OPCODE-NARGS OPCODES))
		    (LENGTH ARGL)))
	   (LET (INSTR)
	     (COND ((AND (NOT (NULL (SETQ INSTR (OPCODE-AUX-OP OPCODES))))
			 (OR (EQ DEST 'D-IGNORE)
			     (AND (EQ DEST 'D-RETURN)
				  (NULL (OPCODE-MISC-OP OPCODES)))))
		    ;; Emit an AUX-op instruction.
		    (ARGLOAD ARGL 'D-PDL)
		    (OUTI (LIST INSTR))
		    (RETURN-FROM P2F (P2 '(QUOTE NIL) DEST)))
		   ((AND (EQ DEST 'D-RETURN)
			 (COMPILING-FOR-V2))
		    (IF (AND (NOT (NULL (OPCODE-TEST-OP OPCODES)))
			     (NULL (OPCODE-PUSH-OP OPCODES))
			     (BOOLEAN-FUNCTION-P FN)
			     #+compiler:debug
			     (LAP-VALUE 'RETURN-PRED))
			(PROGN
			  (P2F FORM 'D-INDS)
			  (OUT-AUX 'RETURN-PRED)
			  (RETURN-FROM P2F nil))
		      (PROGN
			(P2F FORM 'D-PDL)
			(RETURN-FROM P2F (MOVE-RESULT-FROM-PDL 'D-RETURN))) ) )
		   ((AND (OR (EQ DEST 'D-PDL)
			     (EQ DEST 'D-NEXT))
			 (NOT (NULL (SETQ INSTR (OPCODE-PUSH-OP OPCODES))))
			 (NOT GENERATING-MICRO-COMPILER-INPUT-P)))
		   ((AND (EQ DEST 'D-INDS)
			 (NOT (NULL (SETQ INSTR (OPCODE-TEST-OP OPCODES))))
			 (NOT GENERATING-MICRO-COMPILER-INPUT-P)))
		   ((AND (EQ DEST 'D-IGNORE)
			 (OR (NOT (NULL (SETQ INSTR (OPCODE-NO-RESULT-OP OPCODES))))
			     (WHEN (OR (OPCODE-PUSH-OP OPCODES) (OPCODE-TEST-OP OPCODES))
			       (DOLIST (ARG ARGL)
				 (P2 ARG 'D-IGNORE))
			       (RETURN-FROM P2F nil) ) ) ))
		   #+compiler:debug
		   ((AND (NOT (MEMBER DEST '(D-PDL D-INDS D-IGNORE D-NEXT) :TEST #'EQ))
			 (OR (COMPILING-FOR-V2)
			     (NOT (MEMBER DEST '(D-LAST D-RETURN) :TEST #'EQ))))
		    (BARF DEST "undefined destination in P2F" 'BARF))
		   ((NOT (NULL (SETQ INSTR (OPCODE-MISC-OP OPCODES))))
		    ;; Emit a MISC-op instruction.
		    (LET ((P2FN FN))
		      (RETURN-FROM P2F (P2MISC INSTR ARGL DEST NARGS))))
		   ((AND (EQ DEST 'D-INDS)
			 (NOT (NULL (OPCODE-PUSH-OP OPCODES))))
		    (P2F FORM 'D-PDL)
		    (RETURN-FROM P2F (OUTI '(MOVE D-INDS PDL-POP))))
		   ((AND (EQ DEST 'D-PDL)
			 (NOT (NULL (OPCODE-TEST-OP OPCODES)))
			 (BOOLEAN-FUNCTION-P FN))
		    (P2F FORM 'D-INDS)
		    (OUTM '(MISC D-PDL PREDICATE))
		    (RETURN-FROM P2F nil))
		   ((NOT (NULL (SETQ INSTR (OPCODE-AUX-OP OPCODES))))
		    ;; Emit an AUX-op instruction.
		    (ARGLOAD ARGL 'D-PDL)
		    (OUTI (LIST INSTR))
		    (WARN 'OPCODE-AUX-OP :IMPLAUSIBLE
			  "Trying to use result of ~S which does not return a value." FN)
		    (RETURN-FROM P2F (P2 '(QUOTE NIL) DEST)))
		   ((FBOUNDP FN)
		    (RETURN-FROM P2F (P2ARGC nil ARGL nil DEST FN)))
		   (T (BARF FN "can't be handled in P2F" 'BARF)))
	     ;; Emit an instruction having an address field:
	     ;; push each argument except the last onto the stack and
	     ;; then address the last argument with the instruction.
	     (DO ((TAIL ARGL (CDR TAIL)))
		 ((NULL (CDR TAIL))
		  (LET ((LAST-ARG (P2-SOURCE (CAR TAIL) 'D-PDL)))
		      (OUTI `(,INSTR 0 ,LAST-ARG)) ))
	       (P2 (CAR TAIL) 'D-PDL) ) ) )
	  (T (WHEN (AND (EQ FN (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*))
			(EQ (AREF QCMP-OUTPUT (- (LENGTH QCMP-OUTPUT) 1)) 'PROGSA))
	       (WARN 'P2F :IMPLAUSIBLE "~A calls itself unconditionally." FN))
	     (P2ARGC nil ARGL nil DEST FN)) ) ) )

;Move the quantity on the top of the stack to the value of a variable
;and also move it to the specified destination.
(DEFUN MOVEM-AND-MOVE-TO-DEST (VAR DEST)
  ;; 12/26/84 DNG - Re-written to use new function P2-DESTINATION.
  ;;  1/09/86 DNG - For release 3, use (Aux) STORE-IN-HIGHER-CONTEXT.
  ;;  7/07/86 DNG - Changed handling of LEXICAL-REF variables.
  ;;  7/22/86 DNG - Fix to not assume that STORE-IN-HIGHER-CONTEXT leaves the value on the stack.
  ;; 10/18/86 DNG - Use OUTIV to enable storing in phantom variables.
  ;;  4/07/88 CLM - Fix to handle variables re-allocated by EXTEND-LOCAL-VARIABLES (SPR 7631).
  (LET ((ADR NIL))
    (DECLARE (UNSPECIAL ADR))
    (IF (AND (CONSP VAR)
	     (OR (AND (EQ (CAR VAR) 'LEXICAL-REF)
		      (ATOM (SETQ ADR (LEX-REF-ADDRESS VAR))))
		 ;; variable re-allocated by extend-local-variables 
		 (AND (EQ (CAR VAR) 'LOCAL-REF)
		      (EQ (CAR (VAR-LAP-ADDRESS (SECOND VAR))) 'LEXICAL-REF)
		      (ATOM (SETQ ADR (LEX-REF-ADDRESS (VAR-LAP-ADDRESS (SECOND VAR))))))))
	(IF (COMPILING-FOR-V2)
	    (IF (MEMBER DEST '(D-IGNORE D-INDS) :TEST #'EQ)
		(PROGN
		  (P2PUSH-CONSTANT ADR)
		  (NEEDPDL 1)
		  (OUT-AUX 'STORE-IN-HIGHER-CONTEXT))
		(PROGN
		  (OUTI '(MOVEM 0 PDL-PUSH))
		  (P2PUSH-CONSTANT ADR)
		  (NEEDPDL 2)
		  (OUT-AUX 'STORE-IN-HIGHER-CONTEXT)
		  (MOVE-RESULT-FROM-PDL DEST)))
	    (PROGN
	      (P2PUSH-CONSTANT ADR)
	      (NEEDPDL 1)
	      (OUTI `(MISC ,DEST %STORE-IN-HIGHER-CONTEXT))))
	
	(PROGN
	  (WHEN (NULL ADR)
	    (SETQ ADR (P2-DESTINATION VAR)))
	  (IF (MEMBER DEST '(D-IGNORE D-INDS) :TEST #'EQ)
	      (OUTIV 'POP NIL ADR)
	      (PROGN 
		(OUTIV 'MOVEM NIL ADR)
		(MOVE-RESULT-FROM-PDL DEST))))))
  NIL) 

(DEFUN MOVE-RESULT-FROM-PDL (DEST)
  (UNLESS (EQ DEST 'D-PDL)
    (OUTI `(MOVE ,DEST PDL-POP)))) 

;;; Compile functions which have their own special instructions.

;; Here for a "miscellaneous" instruction (no source address field; args always on PDL).
;; Such functions have no P2 properties.  We recognize them by their OPCODE
;; properties, which contain the corresponding instruction and the number of
;; arguments that it requires.
;; The number of arguments is passed as NARGS.  Since P1 already took care of
;; any error message, we just ignore any extra args or nullify omitted ones.
(DEFUN P2MISC (INSN ARGL DEST NARGS)
  ;;  6/24/86 DNG - For VM2, assume that Misc-ops never return multiple values.
  ;;  8/28/86 CLM - no longer need a DESC arg for call to P2ARGC; just pass nil
  ;;  2/04/87 DNG - For efficiency, modify to avoid calling FIRSTN and ARGLOAD.
  (COND ((AND M-V-TARGET
	      (NOT (COMPILING-FOR-V2))
	      (FBOUNDP-FOR-TARGET INSN))
	 (WHEN (> NARGS (LENGTH ARGL))		;Too few args
	   (SETQ ARGL
		 (APPEND ARGL
			 (DO ((N (- NARGS (LENGTH ARGL)) (1- N))
			      (L NIL (CONS ''NIL L)))
			     ((ZEROP N)
			      L)))))
	 (P2ARGC nil ARGL nil DEST INSN))
	(T (DO ((TAIL ARGL (REST TAIL))
		(I 0 (1+ I)))
	       ((AND (NULL TAIL) (>= I NARGS)))
	     (IF (< I NARGS)
		 (PROGN (P2 (IF TAIL (FIRST TAIL) '(QUOTE NIL)) 'D-PDL)
			(INCPDLLVL))
	       (P2 (FIRST TAIL) 'D-IGNORE)))
	   (LOCALLY (DECLARE (INLINE GET-FOR-TARGET))
		    (IF (AND (NOT (COMPILING-FOR-V2))
			     (>= (GET-FOR-TARGET INSN 'QLVAL) 512))
			(OUTI (LIST 'MISC1 DEST INSN))
		      (OUTI (LIST 'MISC DEST INSN)))))))

; Compile functions which have special instructions with destination fields.
; These take only one argument.
; The result can go directly to any destination, not just to the PDL.

(MAPC #'(LAMBDA (FN)
	  (SETF (GET FN 'P2) 'P2DEST))
      '(CAR CDR CAAR CADR CDAR CDDR)) 


(DEFUN P2DEST (ARGL DEST)
  (LET ((SOURCE (P2-SOURCE (CAR ARGL) DEST)))
    (OR (EQ DEST 'D-IGNORE) (OUTI `(,P2FN ,DEST ,SOURCE))))) 


;Output code to unbind to a specpdl index saved on the stack
;underneath N values.  The code pops that one word out of the stack
;but we do not change PDLLVL.

(DEFUN OUTPUT-UNBIND-TO-INDEX (NVALUES)
 ;;  9/23/85 DNG - Use OUT-AUX.
 ;;  4/14/86 CLM - No longer use the obsolete misc-op UNBIND-TO-INDEX-UNDER-N.
  (COND ((= NVALUES 0)
	 (OUT-AUX 'UNBIND-TO-INDEX))
	((= NVALUES 1)
	 (OUTM '(MISC D-PDL UNBIND-TO-INDEX-MOVE)))
	(T (IF (COMPILING-FOR-V2)
	       (PROGN
		 (P2PUSH-CONSTANT NVALUES)        ;GET THE INDEX FROM THE PDL
		 (OUTM '(MISC D-PDL PDL-WORD))
		 (OUT-AUX 'UNBIND-TO-INDEX)       ;USE THE AUX-OP
		 (P2PUSH-CONSTANT 1)
		 (P2PUSH-CONSTANT NVALUES)
		 (OUT-AUX 'POP-M-FROM-UNDER-N)    ;REMOVE INDEX FROM STACK
		 )
	     (PROGN
	       (P2PUSH-CONSTANT NVALUES)
	       (OUTM '(MISC D-IGNORE UNBIND-TO-INDEX-UNDER-N))))))) 


(DEFUN OUTI (X)
 ;;  7/24/85 DNG - Modified for release 3.
  (UNLESS (NULL DROPTHRU)
    (WHEN (AND (EQ (CADR X) 'D-RETURN)
	       (OR (NOT (EQ (CAR X) 'CALL))
		   (COMPILING-FOR-V2)))
      (SETQ DROPTHRU NIL))
    (IF (EQ (CAR X) 'MISC)
      (OUTF X)
      (OUTS X)))
  NIL) 

(DEFUN OUTI1 (X)			   ;USE THIS FOR OUTPUTING INSTRUCTIONS
  (WHEN DROPTHRU			   ;KNOWN TO TAKE DELAYED TRANSFERRS
    (OUTS X))) 


(DEFUN TAKE-DELAYED-TRANSFER ()            ;CALL THIS WHEN ARGS TO LIST OR CALL COMPLETED
  (SETQ DROPTHRU NIL)) 

;Output a BRANCH instruction

(DEFUN OUTB (X)
  (COND ((EQ (CADDR X) 'NO-OP))
	((EQ (CADDR X) 'RETURN))
	((NULL DROPTHRU))
	(T (WHEN (EQ (CADR X) 'ALWAYS)
	     (SETQ DROPTHRU nil))
	   (SETF (GET (CAR (LAST X)) 'USED) T)
	   (OUTF X))))  	

;BRANCH INDICATOR SENSE POPONNOJUMP TAG BRANCH
;OCCURS IN C(IND) = SENSE

(DEFUN OUTTAG (X)
  (WHEN (GET X 'USED)
    (OR DROPTHRU (OUTF '(NO-DROP-THROUGH)))
    (SETQ DROPTHRU T)
    (OUTF X))) 

(DEFUN OUTTAG-FORCED (TAG)
  (UNLESS DROPTHRU
    (OUTF '(NO-DROP-THROUGH))
    (SETQ DROPTHRU T))
  (OUTF TAG)
  )

;For various types of source address, this gives the maximum index
;that there is room for.  If an attempt is made to output a source address
;with a bigger index, it gets turned into a two word instruction
;whose second word is an EXTENDED-ADDRESS instruction,
;and whose first word has EXTEND as a source.
(DEFPARAMETER SOURCE-TYPE-INDEX-LIMIT-ALIST
	      '((LOCBLOCK 63) (ARG 63))) 

;Output an instruction that might have a source address which might require an extra word.
#-Explorer
(DEFUN OUTS (INSN)
  (LET ((SOURCELOC (LAST INSN))
	TEM)
    (IF (AND (CONSP (CAR SOURCELOC))
	     (SETQ TEM (ASSOC (CAAR SOURCELOC) SOURCE-TYPE-INDEX-LIMIT-ALIST :TEST #'EQ))
	     (> (CADR (CAR SOURCELOC)) (CADR TEM)))
	(LET ((EXTENDED-ADDRESS
		`(EXTENDED-ADDRESS
		   ,(IF (MEMBER (CADR INSN) '(D-IGNORE D-INDS D-LAST D-NEXT D-PDL D-RETURN) :TEST #'EQ)
			(CADR INSN)
		      0)
		   ,(CAR SOURCELOC))))
	  (OUTF (APPEND (BUTLAST INSN) '(EXTEND)))
	  (OUTF EXTENDED-ADDRESS))
      (OUTF INSN))))

#+Explorer
(DEFF OUTS 'OUTF) 

(DEFUN OUTF (X)
 ;;  3/27/86 DNG - Work around bug in ADJUST-ARRAY by making the second
 ;;		argument a list; fix UNMADR test to not choke on new debug-info struct.
  (COND #+compiler:debug
	((NULL HOLDPROG)
	 (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))   ;Stream may cons
	   (FORMAT T "~&  ~A " X)
	   (WHEN (AND (CONSP X)
		      (CONSP (CDR X))
		      (CDDR X))
	     (UNMADR (CADDR X)))))
	((VECTOR-PUSH X QCMP-OUTPUT))
	(T (ADJUST-ARRAY QCMP-OUTPUT
			 (LIST (* 2 (ARRAY-DIMENSION QCMP-OUTPUT 0))))
	   (OUTF X))	   ;TRY AGAIN
	)) 

#-Compiler:debug (PROCLAIM '(INLINE OUT-AUX MAKE-AUX))
(DEFUN OUT-AUX (&REST ARGS)
  (DECLARE (ARGLIST NAME &OPTIONAL COUNT))
  (OUTI (APPLY #'MAKE-AUX ARGS))) 

(DEFUN MAKE-AUX (NAME &OPTIONAL (COUNT NIL COUNTP))
  (IF (NULL COUNTP)
      (IF (COMPILING-FOR-V2)
	  `(AUX ,NAME)
	`(MISC D-IGNORE ,(MISC-LAP-CODE NAME)))
    (IF (COMPILING-FOR-V2)
	`(AUX ,NAME ,COUNT)
      `(MISC D-IGNORE ,(MISC-LAP-CODE NAME) ,COUNT)))) 


(DEFCONSTANT UNBIND-LIMIT 16)  ; limit on number of unbinds in one instruction
(DEFUN UNBIND (IDEST NBINDS)
 ;; Unbind NBINDS special variables, unless IDEST is D-RETURN.
 ;; Note that an UNBIND X instruction unbinds X+1 vars.
 ;;  8/10/85 DNG - Modified for release 3.
 ;;  9/25/85 DNG - Aux name changed from UNBIND to UNBIND-1.
  (UNLESS (EQ IDEST 'D-RETURN)
    (LOOP WHILE (> NBINDS UNBIND-LIMIT) DO
       (PROGN
	 (OUT-AUX 'UNBIND-1 (- UNBIND-LIMIT 1))
	 (DECF NBINDS UNBIND-LIMIT)))
    (UNLESS (= NBINDS 0)
      (OUT-AUX 'UNBIND-1 (- NBINDS 1))))) 

(DEFUN LEX-REF-ADDRESS (LEXICAL-REF-FORM)
  ;; Given an address of the form (LEXICAL-REF level offset), return either
  ;; a list of the form (LEX number) to be used as a main-op address, or a
  ;; number to be used as the operand of LOAD-FROM-HIGHER-CONTEXT or STORE-IN-HIGHER-CONTEXT.
  ;;  7/02/86 DNG - Re-written.
  ;;  7/12/86 DNG - Add support for LEX-B addressing.
  (LET* ((RELATIVE-LEVEL (- (COMPILAND-NESTING-LEVEL *CURRENT-COMPILAND*)
			    (SECOND LEXICAL-REF-FORM)
			    1))
	 (OFFSET (THIRD LEXICAL-REF-FORM))
	 (LEX-REG (POSITION RELATIVE-LEVEL (THE LIST *LEXICAL-REGISTER-LEVELS*) :TEST #'EQ)))
    (DECLARE (FIXNUM RELATIVE-LEVEL OFFSET))
    (IF (AND LEX-REG
	     (ZEROP (DPB 0 (SYMEVAL-FOR-TARGET '%%QMI-LEX-OFFSET) OFFSET)))
	;; Can be directly addressed
	`(LEX ,(DPB LEX-REG (SYMEVAL-FOR-TARGET '%%QMI-LEX-LEVEL) OFFSET))
      ;; Else create code value for LOAD-FROM-HIGHER-CONTEXT.
      (DPB RELATIVE-LEVEL
	   (SYMEVAL-FOR-TARGET 'SI:%%CONTEXT-DESC-REL-LEVEL)
	   (DPB OFFSET
		(SYMEVAL-FOR-TARGET 'SI:%%CONTEXT-DESC-SLOT)
		0)) ))) 

(DEFVAR IVAR-ADDRESS-ENABLE T
   "True to enable use of instance variable addressing mode.
Setting this variable true enables more efficient code to be generated
for flavor methods when maximum optimization is selected.") 

;Compile something to be addressed by an instruction.
;Return the address which the instruction can address it by.
;Can push the value on the stack and return PDL-POP,
;or for a variable or constant can just return its address.
;DEST is significant only if it is D-IGNORE, in which case
;we compile code to compute and ignore the value.  What we return then is irrelevant.
(DEFUN P2-SOURCE (FORM DEST)
 ;; 12/26/84 DNG - Added trap for null form in order to report the error
 ;;                here instead of in QLAPP.
 ;; 12/26/84 DNG - Added use of instance variable addressing for Explorer.
 ;;  1/04/85 DNG - Added special case for %POP.
 ;;  1/28/85 DNG - Instance var. addressing depends on optimization switches.
 ;;  4/02/85 DNG - Add test of IVAR-ADDRESS-ENABLE.
 ;;  4/26/85 DNG - Fix use of mapping table with instance variable addressing
 ;;                in a compile to file.
 ;;  9/13/85 DNG - Re-enable use of IVAR addressing, but only for compile to memory.
 ;;  1/09/86 DNG - For VM2, LOAD-FROM-HIGHER-CONTEXT instead of %LOAD-FROM-HIGHER-CONTEXT.
 ;;  1/14/86 DNG - Implement addressing mode LEX-A.
 ;;  7/08/86 DNG - Change handling of LEXICAL-REF and BREAKOFF-FUNCTIONs.
 ;; 10/18/86 DNG - Handle local variables moved to lexical environment by EXTEND-LOCAL-VARIABLES .
  (COND ((ATOM FORM)
	 (debug-assert (symbolp form)) ; 12/9/86
	 (IF (NULL FORM)
	     (BARF FORM "Null 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 DEST)
	     A)))
	((EQ (CAR FORM) 'LEXICAL-REF)
	 (LET (( ADR (LEX-REF-ADDRESS FORM) ))
	   (DECLARE (UNSPECIAL ADR))
	   (IF (CONSP ADR)
	       ADR
	     (PROGN
	       (UNLESS (EQ DEST 'D-IGNORE)
		 (P2PUSH-CONSTANT ADR)
		 (IF (COMPILING-FOR-V2)
		     (OUTM '(MISC D-PDL LOAD-FROM-HIGHER-CONTEXT))
		   (OUTM '(MISC D-PDL %LOAD-FROM-HIGHER-CONTEXT))))
	       'PDL-POP))))
	((AND (EQ (CAR FORM) 'SELF-REF)	   ; flavor instance variable
	      (COMPILING-FOR-EXPLORER-P)
	      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))))))
	((MEMBER (CAR FORM) '(FUNCTION QUOTE SELF-REF) :TEST #'EQ)
	 `(QUOTE-VECTOR ,FORM))
	((EQ (CAR FORM) 'BREAKOFF-FUNCTION)
	 (LET* ((COMPILAND (SECOND FORM))
		(NAME (COMPILAND-FUNCTION-SPEC COMPILAND)))
	   (UNLESS (MEMBER COMPILAND COMPILER-QUEUE :TEST #'EQ)
	     (PUSH-END COMPILAND COMPILER-QUEUE) )
	   (WHEN (AND (CONSP NAME)
		      (EQ (FIRST NAME) ':INTERNAL)
		      (EQ (SECOND NAME) 'NIL))
	     ;; Offspring of an anonymous LAMBDA generated by COMPILE-TOP-LEVEL-FORM;
	     ;; fill in the gensym function name which should have been set by now.
	     (SETF (SECOND NAME)
		   (COMPILAND-FUNCTION-SPEC
		     (COMPILAND-PARENT COMPILAND))))
	   (IF (EQ (COMPILAND-PARENT COMPILAND) *CURRENT-COMPILAND*)
	       `(QUOTE-VECTOR (BREAKOFF-FUNCTION ,NAME))
	     (P2-SOURCE `(FUNCTION ,NAME) DEST))))
	((EQ (CAR FORM) '%POP) 'PDL-POP)
	(T (LET (BDEST M-V-TARGET)
	     (P2F FORM (IF (EQ DEST 'D-IGNORE)
			   'D-IGNORE
			 'D-PDL))
	     'PDL-POP)))) 

(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.
 ;;  9/29/87 DNG - For Scheme, allow symbol function cell to be used as a destination.
 ;;  5/09/88 DNG - For CLOS, add support for %STANDARD-INSTANCE-REF .
  (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))
	((EQ (CAR FORM) '%STANDARD-INSTANCE-REF)
	 (INSTANCE-REF-HANDLER (CDR FORM)))
	((EQ (CAR FORM) 'FUNCTION) ; this is used only by SCHEME:SET!
	 `(QUOTE-VECTOR ,FORM))
	(T (BARF FORM "Bad destination variable in pass 2" 'BARF)) )) 

(DEFUN P2PUSH-CONSTANT (CONSTANT)
 ;;  7/12/85 - Support use of PUSH-NEG-NUMBER instruction.
 ;;  8/28/85 - For release 3, use TRUE and FALSE Misc-ops.
 ;;  9/24/85 - Use SET-NIL and SET-T instead of FALSE and TRUE.
  (WHEN (FIXNUMP CONSTANT)
    (IF (>= CONSTANT 0)
      (WHEN (<= CONSTANT 511)
	(RETURN-FROM P2PUSH-CONSTANT
	  (OUTI `(PUSH-NUMBER ,CONSTANT))))
      (WHEN (AND (>= CONSTANT -511)
		 (INSTRUCTION-EXISTS-P 'PUSH-NEG-NUMBER))
	(RETURN-FROM P2PUSH-CONSTANT
	  (OUTI `(PUSH-NEG-NUMBER ,(- CONSTANT))))) ) )
  (WHEN (COMPILING-FOR-V2)
    (COND ((EQ CONSTANT NIL)
	   (RETURN-FROM P2PUSH-CONSTANT
	     (IF (GET-FOR-TARGET 'FALSE 'MISC-VAL)
		 (OUTM '(MISC D-PDL FALSE))
	       (OUTI '(SET-NIL 0 PDL-PUSH)))))
	  ((EQ CONSTANT T)
	   (RETURN-FROM P2PUSH-CONSTANT
	     (IF (GET-FOR-TARGET 'TRUE 'MISC-VAL)
		 (OUTM '(MISC D-PDL TRUE))
	       (OUTI '(SET-T 0 PDL-PUSH)))))))
  (OUTI `(MOVE D-PDL (QUOTE-VECTOR ',CONSTANT)))) 

(DEFUN MKPDLLVL (X)
  ;;  2/18/86 DNG - Commented out warning because P1-WITH-STACK-LIST now
  ;;		generates a CHANGE-PDLLVL that uses MKPDLLVL to decrement.
  (COMMENT
    (IF (< X PDLLVL)
	(FORMAT T "~%Warning: Call to mkpdllvl did pop while compiling ~S" FUNCTION-TO-BE-DEFINED) ;***
      ))
  (WHEN (> (SETQ PDLLVL X) MAXPDLLVL)
    (SETQ MAXPDLLVL PDLLVL))) 

;Equivalent to (MKPDLLVL (1+ PDLLVL)) but call is just one word.
(DEFUN INCPDLLVL ()
  (SETQ MAXPDLLVL (MAX MAXPDLLVL (SETQ PDLLVL (1+ PDLLVL))))) 

(DEFUN ARGLOAD (ARGL DEST)
  (PROG (IDEST)
	(SETQ IDEST 'D-PDL)
	(AND (EQ DEST 'D-IGNORE) (SETQ IDEST 'D-IGNORE))
     L
	(WHEN (NULL ARGL)
	  (RETURN NIL))
	(P2 (CAR ARGL) IDEST)
	(OR (EQ IDEST 'D-IGNORE) (INCPDLLVL))
	(SETQ ARGL (CDR ARGL))
	(GO L))) 

;FCTN is either a symbol which is the name of a function
;or it is a list which can be used as a source address in an instruction.
;MAPPING-TABLE, if not NIL, is an expression whose value is a flavor mapping table;
;we compile code to compute that table and put it in SELF-MAPPING-TABLE.
(DEFUN P2ARGC (FUNCTION-VALUE ARGL lexpr-funcall
	       DEST FUNCTION-SPEC
	       &OPTIONAL (MAPPING-TABLE nil MAPPING-TABLE-supplied)
	                 (continuation nil continuation-supplied))
  "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.
  ;;	[The next 3 changes not included in this file until 3/15/89.]
  ;; 12/12/87 DNG - Use D-TAIL in Scheme mode regardless of OPTIMIZE values.
  ;;  4/18/88 CLM - start working on CLOS; also delete code for rel.1.
  ;;  5/02/88 CLM - added a supplied-p parameter for mapping-table in case it supplied but NIL.
  (LET (IDEST CALLI FCTN-ADDR
	(TDEST DEST) (LDEST DEST)	   ;MAY GET CHANGED TO D-PDL BELOW
	(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-supplied))  
		    '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.
    (SETQ FCTN-ADDR
	  (IF (NULL FUNCTION-VALUE)
	      `(QUOTE-VECTOR (FUNCTION ,FUNCTION-SPEC))
	    FUNCTION-VALUE))
    
    (WHEN (OR MAPPING-TABLE-supplied
	      LEXPR-FUNCALL 
	      MVTARGET)
      (SETQ CALL-INFO-WORD
	    (DPB NARGS
		 (SYMEVAL-FOR-TARGET 'SI:%%CALL-INFO-NUMBER-OF-ARGUMENTS)
		 CALL-INFO-WORD)) )
    (WHEN 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))
      (IF (AND LEXPR-FUNCALL
	       (NULL (CDR ARGS)))
	  (PROGN
	    (P2 (CAR ARGS) 'D-PDL))
	  (PROGN
	    (P2 (CAR ARGS) IDEST)
	    (WHEN (EQ IDEST 'D-PDL)
	      (INCPDLLVL))) ) )
    (WHEN (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)
		 (OR (> (OPT-SPEED OPTIMIZE-SWITCH)
			(OPT-SAFETY OPTIMIZE-SWITCH))
		     (COMPILING-SCHEME-P))
		 (NOT (AND (SYMBOLP FUNCTION-SPEC)
			   (GET FUNCTION-SPEC :ERROR-REPORTER)))
		 (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))
      ;;for method calls, set the appropriate bit in the call-info-word
      (WHEN MAPPING-TABLE-supplied    ;MAPPING-TABLE
	(if continuation-supplied
	  (progn
	    (setq call-info-word
		    (%logdpb 1
			 (symeval-for-target 'si:%%call-info-clos-info-provided)
			 call-info-word))
	    (if (atom continuation)
		(P2PUSH-CONSTANT (QUOTE NIL))
		(p2push continuation)))
	      
	  (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-supplied
		  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))
    ))  ; end of function P2ARGC


;;;Testing functions
#+compiler:debug
;Given the lap address of a variable, print out the name of the variable in a comment.
;Used when compiling a function and printing the lap code on the terminal.
(DEFUN UNMADR (X)
  (WHEN (AND (NOT (ATOM X))
	     (MEMBER (CAR X) '(ARG LOCBLOCK) :TEST #'EQ))
    (DO ((VS ALLVARS (CDR VS)))
	((NULL VS)
	 NIL)
      (AND (EQUAL X (VAR-LAP-ADDRESS (CAR VS)))
	   (PROGN
	     (PRINC "  ;")
	     (PRIN1 (VAR-NAME (CAR VS)))
	     (RETURN (VAR-NAME (CAR VS))))))))