LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760030393. :SYSTEM-TYPE :LOGICAL :VERSION 14. :TYPE "LISP" :NAME "P2FUNS" :DIRECTORY ("REL3-SOURCE" "COMPILER") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758302870. :AUTHOR "REL3" :LENGTH-IN-BYTES 49535. :LENGTH-IN-BLOCKS 49. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                            ;;;;  -*- Mode:Common-Lisp; Package:COMPILER2; Base:10. -*-;;;;;;                           RESTRICTED RIGHTS LEGEND;;;;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(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) 1980 Massachusetts Institute of Technology; Copyright (C) 1984,1987 Texas Instruments Incorporated. All rights reserved.;;;;   *-----------------------------------------------------------*;;;;   |           --  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.(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 %LOGDPBinstead 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.  (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)))))    (OUTF 'PROGSA)    (LET ((LEXICAL-CLOSURE-COUNT 0)  (CLOSURE-DISCONNECT-OFFSETS NIL))      (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) ;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.  (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)))    (IF (AND (EQ LAST-ARG 'PDL-POP)     (NOT (NULL (OPCODE-MISC-OP OPCODES)))     (NULL M-V-TARGET) ; don't let P2MISC call P2ARGC   )(P2MISC (OPCODE-MISC-OP OPCODES) '() DEST 0)      (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.  (LET ((ADR NIL))    (DECLARE (UNSPECIAL ADR))    (IF (AND (CONSP VAR)     (EQ (CAR VAR) 'LEXICAL-REF)     (ATOM (SETQ ADR (LEX-REF-ADDRESS 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)) (comment - no longer used in release 3;;; ARG DESC LIST -- A LIST OF LISTS;;; EA LIST (<REPEAT-COUNT> <TOKEN-LIST>);;; TOKEN LIST HAS THINGS LIKE FEF-ARG-REQ FEF-ARG-OPT FEF-ARG-REST,;;; AND FEF-QT-EVAL FEF-QT-QT.(DEFUN GETARGDESC (X)   ;second value on LISPM T if this is a guess.  ;; 10/26/85 DNG - Use GET-OPCODES instead of QINTCMP property.  ;;  3/05/86 DNG - Take %ARGS-INFO of the definition instead of the name.  ;;  4/24/86 DNG - For VM2, use ARGS-DESC instead of %ARGS-INFO; eliminate  ;;checking of Q-ARGS-PROP since it is never defined anywhere.  ;;  4/26/86 DNG - Add handling of special forms for VM2.  ;;  8/09/86 DNG - Eliminate use of THIS-FUNCTION-ARGLIST since the current function  ;;will be on FILE-LOCAL-DECLARATIONS for DECLARED-DEFINITION to access.  (DECLARE (INLINE GET-FOR-TARGET))  (PROG (TEM DEF)(COND ((SETQ TEM (GET-FOR-TARGET X 'ARGDESC))       (RETURN TEM))      ((SETQ DEF (DECLARED-DEFINITION X))       (RETURN (COND ((SYMBOLP DEF)      (GETARGDESC DEF))     ((CONSP DEF)      (SETQ TEM (LAMBDA-MACRO-EXPAND DEF))      (GET-ARGDESC-PROP-FROM-LAMBDA-LIST(CAR (SI:LAMBDA-EXP-ARGS-AND-BODY TEM))))     #-Elroy     ((AND (TYPEP DEF 'COMPILED-FUNCTION)   (SETQ TEM (GET-MACRO-ARG-DESC-POINTER DEF)))      ;; Use ADL in preference to %ARGS-INFO so that we      ;; find things like FEF-ARG-FUNCTIONAL.      ;; The only reason we would have an ADL if the      ;; %ARGS-INFO would otherwise be correct      ;; is if things like FEF-ARG-FUNCTIONAL are present.      (GET-ARGDESC-PROP-FROM-ADL TEM))     #-Elroy     (T (SETQ TEM (%ARGS-INFO DEF))(IF (LOGTEST %ARG-DESC-INTERPRETED TEM)    '((517 (FEF-ARG-OPT FEF-QT-EVAL)))  (GET-ARGDESC-PROP-FROM-Q-ARGS-PROP TEM X)))     #+Elroy     ((AND (TYPEP DEF 'COMPILED-FUNCTION)   (NOT (ZEROP (%P-LDB SI:%%FEF-HEADER-SPECIAL-FORM DEF))))      ;; Some arguments &QUOTEed, have to check ARGLIST to see which ones.      (GET-ARGDESC-PROP-FROM-LAMBDA-LIST (ARGLIST DEF 'COMPILE)))     #+Elroy     (T (MULTIPLE-VALUE-BIND (MIN MAX REST)    (SI:ARGS-DESC DEF)  (LET (( DESC NIL ))    (WHEN REST      (SETQ DESC    '((1 (FEF-ARG-REST FEF-QT-EVAL)))) )    (WHEN (> MAX MIN)      (PUSH (LIST (- MAX MIN) '(FEF-ARG-OPT FEF-QT-EVAL))    DESC) )    (IF (= MIN 0)(WHEN (NULL DESC)  (SETQ DESC'((0 (FEF-ARG-REQ FEF-QT-EVAL)))) )      (PUSH (LIST MIN '(FEF-ARG-REQ FEF-QT-EVAL))    DESC) )    DESC )))     )))      ((AND (SETQ TEM (GET-OPCODES X))    (SETQ TEM (OPCODE-NARGS TEM)))       (RETURN (LIST (CONS TEM '((FEF-ARG-REQ FEF-QT-EVAL)))))))(RETURN (VALUES '((517 (FEF-ARG-OPT FEF-QT-EVAL))) T))))#-Elroy(DEFUN GET-ARGDESC-PROP-FROM-Q-ARGS-PROP (ARG-PROP FN-NAME)  (PROG (ANS MIN-ARGS OPT-ARGS)    (UNLESS (= 0 (LOGAND %ARG-DESC-FEF-QUOTE-HAIR ARG-PROP))      (GET-ARGDESC-PROP-FROM-ADL (GET-MACRO-ARG-DESC-POINTER (SYMBOL-FUNCTION FN-NAME))))    (UNLESS (= 0 (SETQ MIN-ARGS (LDB %%ARG-DESC-MIN-ARGS ARG-PROP)))      (SETQ ANS (NCONC ANS (LIST (CONS MIN-ARGS '((FEF-ARG-REQ FEF-QT-EVAL)))))))    (UNLESS (= 0 (SETQ OPT-ARGS (- (LDB %%ARG-DESC-MAX-ARGS ARG-PROP) MIN-ARGS)))      (SETQ ANS (NCONC ANS (LIST (CONS OPT-ARGS '((FEF-ARG-OPT FEF-QT-EVAL)))))))    (UNLESS (= 0 (LOGAND %ARG-DESC-QUOTED-REST ARG-PROP))      (SETQ ANS (NCONC ANS (LIST '(1 (FEF-ARG-REST FEF-QT-QT))))))    (UNLESS (= 0 (LOGAND %ARG-DESC-EVALED-REST ARG-PROP))      (SETQ ANS (NCONC ANS (LIST '(1 (FEF-ARG-REST FEF-QT-EVAL))))))    (RETURN ANS))) (DEFUN GET-ARGDESC-PROP-FROM-LAMBDA-LIST (LL)  (PROG (ANS QUOTE-STATUS REST-FLAG OPT-FLAG TOKEN-LIST NEXT-ELEMENT)(SETQ QUOTE-STATUS '&EVAL)     L0(SETQ TOKEN-LIST NIL)     L1(OR LL (RETURN ANS))(SETQ NEXT-ELEMENT (CAR LL)      LL (CDR LL))(COND ((EQ NEXT-ELEMENT '&AUX) (RETURN ANS))      ((EQ NEXT-ELEMENT '&OPTIONAL) (SETQ OPT-FLAG T) (GO L1))      ((EQ NEXT-ELEMENT '&FUNCTIONAL)       (SETQ TOKEN-LIST (CONS 'FEF-FUNCTIONAL-ARG TOKEN-LIST))       (GO L1))      ((MEMBER NEXT-ELEMENT '(&EVAL &QUOTE &QUOTE-DONTCARE) :TEST #'EQ)       (SETQ QUOTE-STATUS NEXT-ELEMENT)       (GO L1))      ((OR (EQ NEXT-ELEMENT '&REST) (EQ NEXT-ELEMENT '&KEY))       (SETQ REST-FLAG T)       (GO L1))      ((MEMBER NEXT-ELEMENT LAMBDA-LIST-KEYWORDS :TEST #'EQ)       (GO L1)))(PUSH  (CDR    (ASSOC QUOTE-STATUS   '((&EVAL . FEF-QT-EVAL) (&QUOTE . FEF-QT-QT) (&QUOTE-DONTCARE . FEF-QT-DONTCARE))   :TEST #'EQ))  TOKEN-LIST)(PUSH (COND (REST-FLAG 'FEF-ARG-REST)    ((NULL OPT-FLAG) 'FEF-ARG-REQ)    (T 'FEF-ARG-OPT))      TOKEN-LIST)(SETQ ANS (NCONC ANS (LIST (LIST 1 TOKEN-LIST))))(WHEN REST-FLAG  (RETURN ANS))(GO L0))) #-Elroy(DEFUN GET-ARGDESC-PROP-FROM-ADL (ADL)  (LET (ARGDESC)    (DO ((L ADL (CDR L)) ITEM SYNTAX QUOTE)((NULL L) (NREVERSE ARGDESC))      (SETQ ITEM (CAR L))      (AND (LOGTEST %FEF-NAME-PRESENT ITEM) (SETQ L (CDR L)))      (SETQ SYNTAX (MASK-FIELD %%FEF-INIT-OPTION ITEM))   ;SKIP EXTRA INIT Q      (OR (= SYNTAX FEF-INI-NONE) (= SYNTAX FEF-INI-NIL) (= SYNTAX FEF-INI-SELF)  (SETQ L (CDR L)))      (SETQ SYNTAX (MASK-FIELD %%FEF-ARG-SYNTAX ITEM))      (SETQ QUOTE    (IF (> (MASK-FIELD %%FEF-QUOTE-STATUS ITEM) FEF-QT-EVAL)'(FEF-QT-QT)      '(FEF-QT-EVAL)))      (AND (LOGTEST FEF-FUNCTIONAL-ARG ITEM) (PUSH 'FEF-FUNCTIONAL-ARG QUOTE))      (COND ((> SYNTAX FEF-ARG-REST)     (RETURN (NREVERSE ARGDESC)))    ((= SYNTAX FEF-ARG-REST)     (RETURN (NRECONC ARGDESC `((1 (FEF-ARG-REST . ,QUOTE))))))    ((= SYNTAX FEF-ARG-OPT)     (PUSH `(1 (FEF-ARG-OPT . ,QUOTE)) ARGDESC))    (T (PUSH `(1 (FEF-ARG-REQ . ,QUOTE)) ARGDESC))))))) ; end of comment #-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 generatedfor 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.  (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))(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)  "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.  (LET (IDEST CALLI FCTN-ADDR(TDEST DEST) (LDEST DEST)   ;MAY GET CHANGED TO D-PDL BELOWADI-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) (> (OPT-SPEED OPTIMIZE-SWITCH)    (OPT-SAFETY OPTIMIZE-SWITCH)) ;; 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)   (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))      ;;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))    ))  ; 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)))))))) COND FORM)); (PROGN c x ...) ==> (PROGN x ...)     (DISCARD (SECOND FORM))     (CONS 'PROGN (CDDR FORM)))    ((ATOM (SECOND FORM)) FORM)    ((MEMBER (FIRST (SECOND FORM)); (PROGN (RETURN...)...) ==> (RETURN...)     '(RETURN-FROM GO *THROW THROW)     :TEST #'EQ)     (DISCARD-FORMS (CDDR FORM))     (VALUES (SECOND FORM) T))    (T FORM)))(ADD-POST-OPTIMIZER BLOCK BLOCK-OPT)(ADD-POST-OPTIMIZER BLOCK-FOR-PROG BLOCK-OPT)(DEFUN BLOCK-OPT (FORM) ;; the P1'd form is: (BLOCK gotags progdesc . body)  ;;  9/12/86 - Add call to DISCARD-FORMS.  ;; 10/17/86 - Return 2nd value of T when result doesn't need further optimization. 