LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760030397. :SYSTEM-TYPE :LOGICAL :VERSION 12. :TYPE "LISP" :NAME "P2HAND" :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 2758302905. :AUTHOR "REL3" :LENGTH-IN-BYTES 120906. :LENGTH-IN-BLOCKS 119. :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 defines the special-form handlers for pass 2.  |;;;;   *-----------------------------------------------------------*;;; 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.;;; Aug. '85 through Aug. '86 - Modifications for Explorer release 3.;;;  8/08/86 - Changes to handling of non-local lexical variables and breakoff-functions.;;; 11/19/86;;; 12/09/86 DNG - Fix for THE around non-local lexical variable.;;; 12/15/86 DNG - New handling for %BIND in LET with unknown number of result values.;;; 12/23/86 DNG - Fix PDLLVL in P2SELECT.;;; 12/31/86 DNG - Bind BDEST to NIL in P2SELECT. [SPR 2911];;;  2/04/87 DNG - Modify SIMPLEGOP for efficiency.;Max index for the new AREFI and AREFI-SET series of instructions(DEFCONSTANT AREFI-MAX 63) (DEFPROP GLOBAL:AR-1      P2-AR-1 P2)(DEFPROP COMMON-LISP-AR-1 P2-AR-1 P2) (DEFPROP ARRAY-LEADER     P2-AR-1 P2) (DEFPROP %INSTANCE-REF    P2-AR-1 P2) (DEFUN P2-AR-1 (ARGL DEST)  ;;  8/24/85 - Support PUSH-AR-1 instruction.  ;;  9/26/85 - Modify format of the AREFI LAP instruction and  ;;            combine handlers for AR-1, COMMON-LISP-AR-1, and ARRAY-LEADER.  (NO-D-RETURN    (LET (INDEX)      (IF (AND (NULL M-V-TARGET)       (NOT GENERATING-MICRO-COMPILER-INPUT-P)       (= (LENGTH ARGL) 2)       (QUOTEP (SECOND ARGL))       (FIXNUMP (SETQ INDEX (SECOND (SECOND ARGL))))       (<= 0 (IF (EQ P2FN '%INSTANCE-REF) ;; %INSTANCE-REF is cretinously origin-1, but we are always origin-0. (SETQ INDEX (- INDEX 1))       INDEX)   AREFI-MAX))  (PROGN    (P2PUSH (FIRST ARGL))    (OUTI `(AREFI ,DEST ,P2FN ,INDEX)))(IF (AND (EQ DEST 'D-PDL) (EQ P2FN 'COMMON-LISP-AR-1) (INSTRUCTION-EXISTS-P 'PUSH-AR-1) (ADRREFP (FIRST ARGL)) (INDEPENDENT-EXPRESSIONS-P (FIRST ARGL) (SECOND ARGL)))    (PROGN      (P2PUSH (SECOND ARGL))      (OUTI `(PUSH-AR-1 0 ,(P2-SOURCE (FIRST ARGL) 'D-PDL))))  (P2MISC P2FN ARGL DEST 2)))))) (DEFPROP SET-AR-1          P2-SET-AR-1 P2)  ;   (SET-AR-1 array index value)(DEFPROP SET-ARRAY-LEADER  P2-SET-AR-1 P2)  ;   (SET-ARRAY-LEADER array index value)(DEFPROP SET-%INSTANCE-REF P2-SET-AR-1 P2) (DEFUN P2-SET-AR-1 (ARGL DEST)  ;;  9/26/85 - Modify format of the AREFI LAP instruction;  ;;            combine handlers for SET-AR-1 and SET-ARRAY-LEADER.  ;;  6/04/86 - Fix to properly decrement index for SET-%INSTANCE-REF.  (NO-D-RETURN    (LET (INDEX)      (IF (AND (NULL M-V-TARGET)       (NOT GENERATING-MICRO-COMPILER-INPUT-P)       (= (LENGTH ARGL) 3)       (QUOTEP (SECOND ARGL))       (FIXNUMP (SETQ INDEX (SECOND (SECOND ARGL))))       (<= 0 (IF (EQ P2FN 'SET-%INSTANCE-REF) ;; %INSTANCE-REF is cretinously origin-1, but we are always origin-0. (SETQ INDEX (- INDEX 1))       INDEX)   AREFI-MAX))  (PROGN    (P2PUSH (FIRST ARGL))    (P2PUSH (THIRD ARGL))    (OUTI `(AREFI ,DEST ,P2FN ,INDEX)))(P2MISC P2FN ARGL DEST 3))))) (DEFPROP FUNCTION P2FUNCTION P2) (DEFUN P2FUNCTION (ARGL DEST)  (OUTI `(MOVE ,DEST (QUOTE-VECTOR (FUNCTION ,(CAR ARGL)))))) ;; 8/8/86 DNG - deleted function P2BREAKOFF-FUNCTION.(DEFUN (:PROPERTY LEXICAL-CLOSURE P2) (ARGL DEST)  ;;  1/09/86 DNG - New way of handling lexical closures for release 3.  ;;  2/21/86 DNG - Add support for MAKE-EPHEMERAL-LEXICAL-CLOSURE.  ;;  7/07/86 DNG - Get LOCAL-MAP from *CURRENT-COMPILAND*.  ;;  7/12/86 DNG - First argument is compiland structure instead of BREAKOFF-FUNCTION form.  ;;  7/15/86 DNG - Add update of CLOSURE-DISCONNECT-OFFSETS.  (IF (COMPILING-FOR-V2)      (NO-D-RETURN(P2PUSH-CONSTANT ENVIRONMENT-DESCRIPTOR-LIST)(WITH-STACK-LIST ( FORM 'BREAKOFF-FUNCTION (FIRST ARGL) )  (P2PUSH FORM) )(OUTM `(MISC ,DEST ,(IF (SECOND ARGL)(MISC-LAP-CODE 'MAKE-EPHEMERAL-LEXICAL-CLOSURE)      (MISC-LAP-CODE 'MAKE-LEXICAL-CLOSURE)))))    (PROGN      (WITH-STACK-LIST ( FORM 'BREAKOFF-FUNCTION (FIRST ARGL) )(P2PUSH FORM) )      (LET (( OFFSET (+ (LENGTH (COMPILAND-LOCAL-MAP *CURRENT-COMPILAND*))(* 4 LEXICAL-CLOSURE-COUNT)) ))(OUTI `(MAKE-STACK-CLOSURE ,OFFSET))(PUSH OFFSET CLOSURE-DISCONNECT-OFFSETS) )      (MOVE-RESULT-FROM-PDL DEST)))  (INCF LEXICAL-CLOSURE-COUNT)) (DEFPROP FUNCALL P2FUNCALL P2) (DEFUN P2FUNCALL (ARGL DEST)  ;;DONT HACK PDLLVL HERE SINCE GOING TO POP 1 AND PUSH 4  ;;  8/28/86 CLM - no longer need DESC arg for P2ARGC  (P2ARGC (CAR ARGL) (CDR ARGL) nil DEST NIL))(DEFUN (:PROPERTY FUNCALL-WITH-MAPPING-TABLE-INTERNAL P2) (ARGL DEST)  ;;DONT HACK PDLLVL HERE SINCE GOING TO POP 1 AND PUSH 4  ;;  8/28/86 CLM - no longer need DESC arg for call to P2ARGC  (P2ARGC (CAR ARGL) (CDDR ARGL) nil DEST NIL (CADR ARGL)))(DEFPROP APPLY P2-LEXPR-FUNCALL P2) (DEFPROP LEXPR-FUNCALL P2-LEXPR-FUNCALL P2) (DEFUN P2-LEXPR-FUNCALL (ARGL DEST)  ;; 10/28/85 CLM - Changed to generate Rel.3 aux-op APPLY  ;;                instead of obsolete misc-op APPLY.  ;;  8/28/86 CLM - instead of a DESC arg, pass T to indicate this is a lexpr-funcall  (IF (AND (= (LENGTH ARGL) 2) (NULL M-V-TARGET))      (IF (COMPILING-FOR-V2)  (PROGN    (P2 (CADR ARGL) 'D-PDL)    (P2 (CAR ARGL) 'D-PDL)    (OUTI `(AUX APPLY ,DEST)))(P2MISC 'APPLY ARGL DEST 2))    ;;DONT HACK PDLLVL HERE SINCE GOING TO POP 1 AND PUSH 4    (P2ARGC (CAR ARGL) (CDR ARGL) t DEST NIL)))(DEFUN (:PROPERTY LEXPR-FUNCALL-WITH-MAPPING-TABLE-INTERNAL P2) (ARGL DEST)  ;;DONT HACK PDLLVL HERE SINCE GOING TO POP 1 AND PUSH 4  ;;  8/28/86 CLM - instead of a DESC arg, pass T to indicate this is a lexpr-funcall    (P2ARGC (CAR ARGL) (CDDR ARGL) t DEST NIL  (CADR ARGL)))(DEFPROP VARIABLE-LOCATION P2VARIABLE-LOCATION P2)(DEFUN P2VARIABLE-LOCATION (ARGL DEST)  ;; 8/24/85 - Change name of instruction PUSH-E to PUSH-LOC.  ;; 1/09/86 - LOCATE-IN-HIGHER-CONTEXT instead of %LOCATE-IN-HIGHER-CONTEXT.  ;; 1/14/86 - Use LEX addressing mode when possible.  ;; 7/07/86 - Change handling of LEXICAL-REF addresses.  ;;10/18/86 - Handle local variables moved to lexical environment by EXTEND-LOCAL-VARIABLES .  (CASE (CAAR ARGL)    (LOCAL-REF     (LET ((A (VAR-LAP-ADDRESS (CADR (CAR ARGL)))))       (IF (EQ (FIRST A) 'LEXICAL-REF) ; re-allocated by EXTEND-LOCAL-VARIABLES   (P2VARIABLE-LOCATION (CONS A (REST ARGL)) DEST) (PROGN (OUTI `(PUSH-LOC 0 ,A))(NEEDPDL 1)(MOVE-RESULT-FROM-PDL DEST)))))    (LEXICAL-REF      (LET ((ADR (LEX-REF-ADDRESS (CAR ARGL))))(DECLARE (UNSPECIAL ADR))(IF (CONSP ADR)    (PROGN (OUTI `(PUSH-LOC 0 ,ADR))   (MOVE-RESULT-FROM-PDL DEST))  (PROGN    (P2PUSH-CONSTANT ADR)    (NEEDPDL 1)    (IF (COMPILING-FOR-V2)(PROGN  (OUTM '(MISC D-PDL LOCATE-IN-HIGHER-CONTEXT))  (MOVE-RESULT-FROM-PDL DEST))      (OUTM `(MISC ,DEST %LOCATE-IN-HIGHER-CONTEXT)))))))    (SELF-REF (OUTI `(PUSH-LOC 0 (QUOTE-VECTOR ,(CAR ARGL))))      (NEEDPDL 1)      (MOVE-RESULT-FROM-PDL DEST))    #+compiler:debug    (OTHERWISE (BARF (FIRST ARGL) 'VARIABLE-LOCATION 'BARF))  )) ;;; %ACTIVATE-OPEN-CALL-BLOCK must ignore its apparent destination and;;; instead compile to D-IGNORE (microcode depends on this).;;; This fails to let the compiler know that the pdl is popped and a delayed;;; transfer may be taken, but then it didn't know the pdl was pushed either.(DEFPROP %ACTIVATE-OPEN-CALL-BLOCK P2%ACTIVATE-OPEN-CALL-BLOCK P2) (DEFUN P2%ACTIVATE-OPEN-CALL-BLOCK (IGNORE IGNORE)  (IF (COMPILING-FOR-V2)      (PROGN(WARN '%ACTIVATE-OPEN-CALL-BLOCK      :IMPOSSIBLE      "~A and ~A are no longer supported; use ~S."      '%OPEN-CALL-BLOCK '%ACTIVATE-OPEN-CALL-BLOCK '%CALL)(P2ARGC NIL NIL NIL 'D-IGNORE '%ACTIVATE-OPEN-CALL-BLOCK))    (OUTM '(MISC D-IGNORE %ACTIVATE-OPEN-CALL-BLOCK)))) (DEF %CALL) (DEFPROP %CALL (FUNCTION NUMBER-OF-ARGS &KEY :LEXPR :SELF-MAPPING-TABLE) ARGLIST) (SETF (DOCUMENTATION '%CALL 'FUNCTION)      "Call a function, passing arguments that have already been pushed on the stack with %PUSH.This is a sub-primitive that only works in compiled code.") (DEFUN (:PROPERTY %CALL P2) (ARGL DEST)  ;;  9/17/85 DNG - Original.  This is an incomplete, preliminary version.  ;; 10/23/85 DNG - Fix to not barf when only one argument.  ;;  2/20/86 CLM - Add support for lexpr-funcalls, functions using self-mapping-table and  ;;                functions returning multiple values.  ;;  9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET.    (LET (LEXPRSELF-MAPPING-TABLE(CALL-INFO-WORD 0))    ;;argl should look like    ;; fn nargs (quote :lexpr) (quote t/nil) (quote :self-mapping-table) (*)    (DO ((KEYS (CDDR ARGL) (CDDR KEYS)))((NULL KEYS))      (LET ((VALUE (CADR KEYS)))(CASE (SECOND (CAR KEYS))      (:LEXPR       (UNLESS (QUOTEP VALUE) (WARN '%CALL :FATAL       "~A is an invalid value for the keyword argument :LEXPR" VALUE))       (SETQ LEXPR (SECOND VALUE)))      (:SELF-MAPPING-TABLE (SETQ SELF-MAPPING-TABLE VALUE))      (T (WARN '%CALL :FATAL       "~A is an invalid keyword argument" (SECOND (CAR KEYS))))      )))    (COND ((NOT (COMPILING-FOR-V2))   (WARN '%CALL :IMPOSSIBLE "~A is not supported yet." '%CALL)   (P2FUNCALL (CONS '(FUNCTION %CALL) ARGL) DEST))  ((OR (NULL (REST ARGL))       (AND (EQUAL (SECOND ARGL) ''0)    (NULL (CDDR ARGL))))   (P2ARGC (FIRST ARGL) (QUOTE NIL) NIL DEST NIL))  ((OR LEXPR M-V-TARGET)   (WHEN LEXPR     (SETQ CALL-INFO-WORD   (DPB 1(SYMEVAL-FOR-TARGET 'SI:%%CALL-INFO-LEXPR-FUNCALL-FLAG)CALL-INFO-WORD)))   (WHEN M-V-TARGET     (LET ((MVTARGET M-V-TARGET))       (SETQ M-V-TARGET NIL)       ;;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))) ((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))) ((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))) ((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))))))   ;;add the self-mapping-table bit to the call info word if necessary   (WHEN SELF-MAPPING-TABLE     (SETQ CALL-INFO-WORD   (DPB 1(SYMEVAL-FOR-TARGET 'SI:%%CALL-INFO-SELF-MAP-TABLE-PROVIDED)CALL-INFO-WORD))     (P2PUSH SELF-MAPPING-TABLE))   ;;place the number or args in the call-info-word and push   (P2 `(DPB ,(SECOND ARGL)     ',(SYMEVAL-FOR-TARGET 'SI:%%CALL-INFO-NUMBER-OF-ARGUMENTS)     ',CALL-INFO-WORD)       'D-PDL)   (P2PUSH (FIRST ARGL))   (OUTI1 (LIST 'AUX 'COMPLEX-CALL DEST)) )  (T (P2PUSH (SECOND ARGL))   ; number of arguments pushed     (OUTI (LIST 'CALL-N DEST (P2-SOURCE (FIRST ARGL) 'D-PDL))) ))))(DEFUN (:PROPERTY %ASSURE-PDL-ROOM P2) (ARGL DEST)  ;;  9/26/85 DNG - Original version.  (P2PUSH (FIRST ARGL))  (OUT-AUX '%ASSURE-PDL-ROOM)  (UNLESS (EQ DEST 'D-IGNORE)    (P2 '(QUOTE NIL) DEST))) (DEF %PUSH     ;; Don't actually call %PUSH, just push its argument     (DEFPROP %PUSH P2%PUSH P2)) (DEFUN P2%PUSH (ARGL IGNORE)  (P2 (CAR ARGL) 'D-PDL)) (DEF %PUSH-VALUES-AND-COUNT);; Like %PUSH except that all the values produced by the form are pushed on the;; stack, followed by the number of values on the top.(DEFUN (:PROPERTY %PUSH-VALUES-AND-COUNT P2) (ARGL DEST)  (DECLARE (IGNORE DEST))  (WHEN (P2MV (FIRST ARGL) 'D-PDL 'RETURN)    (P2PUSH-CONSTANT 1)))(DEFUN (:PROPERTY %DUP P2) (ARGL DEST)  ;; Duplicate the top-of-stack.  ;; This only works on an Explorer with microcode version 170 or later.  ;;  1/4/85 - Original.  (P2 (FIRST ARGL) 'D-PDL)  (OUTI '(MOVEM 0 PDL-PUSH))  (MOVE-RESULT-FROM-PDL DEST) )(DEF %EXCHANGE);; Push a value on the stack and then swap it with the previous top of stack.(DEFUN (:PROPERTY %EXCHANGE P2) (ARGL IGNORE)  (P2 (CAR ARGL) 'D-PDL)  (OUT-AUX 'EXCHANGE))(DEFUN (:PROPERTY FLOOR P2) (ARGL DEST)  (P2FLOOR 0 ARGL DEST)) (DEFUN (:PROPERTY CEILING P2) (ARGL DEST)  (P2FLOOR 1 ARGL DEST)) (DEFUN (:PROPERTY TRUNCATE P2) (ARGL DEST)  (P2FLOOR 2 ARGL DEST)) (DEFUN (:PROPERTY ROUND P2) (ARGL DEST)  (P2FLOOR 3 ARGL DEST)) (DEFUN OUTFLOOR (ROUNDING-TYPE OPERATION)  ;;  8/17/85 - Original.  (DECLARE (SPECIAL %%MACRO-DEST-FIELD))   ; Will be defined in DEFMIC file.  (IF (COMPILING-FOR-V2)      (OUTM `(MISC D-PDL ,OPERATION ,ROUNDING-TYPE))    (LET ((DESTFIELD (DPB ROUNDING-TYPE %%MACRO-DEST-FIELD 0)))      (OUTM `(MISC ,DESTFIELD ,OPERATION))))) ;There are two forms of them: FLOOR-2 returns two values,;and FLOOR-1 returns only the first value.;The value or values are left on the stack.;We produce code to request one or two values and move them to;the appropriate place.;FLOOR, CEILING, TRUNCATE and ROUND are distinguished by ROUNDING-TYPE,;which will be put into the destination field of the instruction.(DEFUN P2FLOOR (ROUNDING-TYPE ARGL DEST)  ;;  8/17/85 - For release 2, add rounding type to MISC-OP code instead  ;;            of putting in the destination field.  ;;  8/21/85 - Use OUT-AUX for %RETURN-2.  ;;  9/25/85 - Changed name from INTERNAL-FLOOR-1 to FLOOR-1.  ;; 10/28/85 CLM - Changed to generate Rel.3 aux-op %THROW-N  ;;            instead of misc-op THROW-N.  ;;  2/17/86 DNG - Use (AUX RETURN-0 2) instead of %RETURN-2;  ;;don't use RETURN-N-KEEP-CONTROL for VM2.  ;;  7/16/86 CLM - No longer generate a throw here; this was causing too  ;;                many throws when there was an intervening CATCH between   ;;                the throw and its target.  ;;  9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET.    (P2PUSH (CAR ARGL))  (IF (CDR ARGL)      (P2PUSH (CADR ARGL))    (P2PUSH-CONSTANT 1))  (ARGLOAD (CDDR ARGL) 'D-IGNORE)  (COND ((EQ DEST 'D-RETURN) (OUTFLOOR ROUNDING-TYPE 'FLOOR-2) (IF (COMPILING-FOR-V2)     (OUTI '(AUX RETURN-0 2))   (OUT-AUX '%RETURN-2)) (SETQ DROPTHRU NIL))((NULL M-V-TARGET) (OUTFLOOR ROUNDING-TYPE 'FLOOR-1) (MOVE-RESULT-FROM-PDL DEST))((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST) (OUTFLOOR ROUNDING-TYPE 'FLOOR-2) (OUTM '(MISC D-PDL NCONS)) (OUTM '(MISC D-PDL CONS)))((EQ M-V-TARGET 'THROW) (OUTFLOOR ROUNDING-TYPE 'FLOOR-2) (P2PUSH-CONSTANT 2) (UNLESS (COMPILING-FOR-V2)   (OUTM '(MISC D-IGNORE THROW-N))   (SETQ DROPTHRU NIL)   ))((MEMBER M-V-TARGET '(RETURN RETURN-CATCH) :TEST #'EQ) (OUTFLOOR ROUNDING-TYPE 'FLOOR-2) (P2PUSH-CONSTANT 2) (UNLESS (COMPILING-FOR-V2)   (OUTM '(MISC D-IGNORE RETURN-N-KEEP-CONTROL))))((= M-V-TARGET 1) (OUTFLOOR ROUNDING-TYPE 'FLOOR-1))(T (OUTFLOOR ROUNDING-TYPE 'FLOOR-2)   (PUSH-NILS (- M-V-TARGET 2))))  (SETQ M-V-TARGET NIL))(DEFUN (:PROPERTY MOD P2) (ARGL DEST)  ;;  7/15/86 CLM - Fixed so that if DEST is D-INDS the  ;;                operation will be done.  (UNLESS (EQ DEST 'D-IGNORE)    (LET ((M-V-TARGET 2))      (P2FLOOR 0 ARGL 'D-PDL))    (UNLESS (EQ DEST 'D-RETURN)      (P2PUSH-CONSTANT 1)      (OUTM '(MISC D-PDL SHRINK-PDL-SAVE-TOP)))    (MOVE-RESULT-FROM-PDL DEST))) (DEFUN (:PROPERTY REM P2) (ARGL DEST)  ;;  7/15/86 CLM - Fixed so that if DEST is D-INDS the  ;;                operation will be done.  (UNLESS (EQ DEST 'D-IGNORE)    (LET ((M-V-TARGET 2))      (P2FLOOR 2 ARGL 'D-PDL))    (UNLESS (EQ DEST 'D-RETURN)      (P2PUSH-CONSTANT 1)      (OUTM '(MISC D-PDL SHRINK-PDL-SAVE-TOP)))    (MOVE-RESULT-FROM-PDL DEST)    )) #|  (DEFUN (:PROPERTY GET P2) (ARGL DEST)  ;;  4/23/85 DNG - Use two-argument instruction if the default  ;;                argument is 'NIL.  (NO-D-RETURN   (IF (OR (= (LENGTH ARGL) 2) (EQUAL (THIRD ARGL) '(QUOTE NIL)))       (P2MISC 'GET ARGL DEST 2)     (P2MISC 'INTERNAL-GET-3 ARGL DEST 3)))  )  |#(DEFPROP SETQ P2SETQ P2) (DEFUN P2SETQ (ARGL DEST)  (PROG NIL(OR ARGL (RETURN (P2 '(QUOTE NIL) DEST)))     LOOP(P2SETQ-1 (CAR ARGL) (CADR ARGL)  (IF (NULL (CDDR ARGL))      DEST    'D-IGNORE))(SETQ ARGL (CDDR ARGL))(AND ARGL (GO LOOP)))) ;Compile code to set VAR to the result of computing VALUE,;and also move that value to DEST.(DEFUN P2SETQ-1 (VAR VALUE DEST)  ;; 12/26/84 DNG - Modified to use P2-DESTINATION instead of P2-SOURCE.  ;;  7/10/85 DNG - Use 'SETE property for release 3.  ;;  8/24/85 DNG - Use SET-T instruction.  (LET (INSTR)    (COND ((MEMBER VAR '(NIL T) :TEST #'EQ) NIL)  ((AND (CONSP VAR) (EQ (CAR VAR) 'LEXICAL-REF))   (P2PUSH VALUE)   (MOVEM-AND-MOVE-TO-DEST VAR DEST))  ((MEMBER VALUE '('0 (QUOTE NIL)) :TEST #'EQUAL)   (OUTI     `(,(CDR (ASSOC (CADR VALUE)    '((0 . SET-ZERO) (NIL . SET-NIL)) :TEST #'EQ))       0       ,(P2-DESTINATION VAR)))   (UNLESS (MEMBER DEST '(D-IGNORE D-INDS) :TEST #'EQ)     (P2 VALUE DEST)))  ((AND (EQUAL VALUE ''T)(INSTRUCTION-EXISTS-P 'SET-T))   (OUTI `(SET-T 0 ,(P2-DESTINATION VAR)))   (UNLESS (MEMBER DEST '(D-IGNORE D-INDS) :TEST #'EQ)     (P2 VALUE DEST)))  ((AND (NOT (COMPILING-FOR-V2))(NOT (ATOM VALUE))(CDR VALUE)(EQUAL (CADR VALUE) VAR)(MEMBER (CAR VALUE) '(CDR CDDR 1+ 1-) :TEST #'EQ)(MEMBER DEST '(D-IGNORE D-INDS) :TEST #'EQ))   (OUTI `(SETE ,(CAR VALUE) ,(P2-DESTINATION VAR))))  ((AND (COMPILING-FOR-V2)(NOT (ATOM VALUE))(CDR VALUE)(EQUAL (CADR VALUE) VAR)(SETQ INSTR (GET-FOR-TARGET (CAR VALUE) 'SETE))(MEMBER DEST '(D-IGNORE D-INDS) :TEST #'EQ))   (OUTI `(,INSTR D-INDS ,(P2-DESTINATION VAR))))  (T (P2PUSH VALUE)     (MOVEM-AND-MOVE-TO-DEST VAR DEST))))  NIL) (DEFUN (:PROPERTY PUSH-CDR-STORE-CAR-IF-CONS P2) (ARGL DEST)  ;; Used for MATCHCARCDR in file SYS:SYS2;SELEV  ;; 12/26/84 DNG - Modified to use P2-DESTINATION.  (P2PUSH (CAR ARGL))  (IF (ADRREFP (CADR ARGL))      (PROGN(OUTI `(PUSH-CDR-STORE-CAR-IF-CONS ,(P2-DESTINATION (CADR ARGL))))(UNLESS (EQ DEST 'D-INDS)  (OUTM `(MISC ,DEST ,(MISC-LAP-CODE 'INDICATORS-VALUE)))))    (LET ((TAG (GENSYM)))      (OUTM '(MISC D-INDS CONSP-OR-POP))      (OUTB `(BRANCH NULL TRUE NIL ,TAG))      (OUTM '(MISC D-PDL CARCDR))      (MOVEM-AND-MOVE-TO-DEST (CADR ARGL) 'D-IGNORE)      (OUTTAG TAG)      (UNLESS (EQ DEST 'D-INDS)(OUTM `(MISC ,DEST ,(MISC-LAP-CODE 'INDICATORS-VALUE)))))))(DEFUN (:PROPERTY PUSH-CDR-IF-CAR-EQUAL P2) (ARGL DEST)  ;; Used by P1 handler for SI:MATCHCARCDR  ;; 12/04/85 DNG - Modified to not use P2NODEST.  (P2 (CAR ARGL) 'D-PDL)  (OUTI `(PUSH-CDR-IF-CAR-EQUAL 0 ,(P2-SOURCE (CADR ARGL) 'D-INDS)))  (UNLESS (EQ DEST 'D-INDS)    (OUTM `(MISC ,DEST ,(MISC-LAP-CODE 'INDICATORS-VALUE)))))(DEFUN (:PROPERTY %DOLIST P2) (ARGL DEST)  ;; %DOLIST is used in optimizer which expands DOLIST  ;; 12/26/84 DNG - Use P2-DESTINATION instead of P2-SOURCE.  ;;  4/09/85 DNG - Set TAGOUT to T.  ;;  6/02/86 DNG - Bind TAGOUT to T instead of just SETQing it.  (IGNORE DEST)  (LET ((TOP-TAG (GENSYM))(BOTTOM-TAG (GENSYM))(PDLLVL PDLLVL))    (P2PUSH (SECOND ARGL))    (INCPDLLVL)    (OUTB `(BRANCH ALWAYS NIL NIL ,TOP-TAG))    (OUTTAG TOP-TAG)    (LET ((TAGOUT T))      (OUTI `(PUSH-CDR-STORE-CAR-IF-CONS       ,(P2-DESTINATION (FIRST ARGL))))      (OUTB `(BRANCH NULL TRUE NIL ,BOTTOM-TAG))      (P2 (THIRD ARGL) 'D-IGNORE)      (OUTB `(BRANCH ALWAYS NIL NIL ,TOP-TAG))      (OUTTAG BOTTOM-TAG) )))(DEFUN (:PROPERTY THE-EXPR P2) (ARGL DEST)  ;; THE-EXPR forms are generated by P1-WITH-ANNOTATION.  ;; 1/28/85 -Original version.  ;; 3/11/86 - Call P2 instead of P2F if FORM is a variable [ADRREFP true].  ;;12/09/86 - Call P2 instead of P2F if FORM is a LEXICAL-REF.  (LET* ((THE-FORM (CONS 'THE-EXPR ARGL)) (OPTIMIZE-SWITCH (EXPR-OPTIMIZE THE-FORM)) (FORM (EXPR-FORM THE-FORM)))    (IF (OR (ATOM FORM)    (MEMBER (CAR FORM) '(QUOTE LOCAL-REF SELF-REF LEXICAL-REF FUNCTION BREAKOFF-FUNCTION %POP)    :TEST #'EQ)) ; special forms handled directly by P2(P2 FORM DEST)      (P2F FORM DEST) ) )) (DEFUN (:PROPERTY PROGN-WITH-DECLARATIONS P2) (ARGL DEST)  (LET ((VARS (CAR ARGL)))    (P2PROGN (CDR ARGL) DEST))) (DEFPROP PROGN P2PROGN P2) (DEFPROP DONT-OPTIMIZE P2PROGN P2) (DEFUN P2PROGN (ARGL DEST)  (P2PROG12N (LENGTH ARGL) DEST ARGL)) (DEFUN (:PROPERTY PROG1 P2) (ARGL DEST)  (P2PROG12N 1 DEST ARGL)) (DEFPROP PROG2 P2PROG2 P2) (DEFUN P2PROG2 (ARGL DEST)  (P2PROG12N 2 DEST ARGL)) ;Compile a PROGN or PROG2, etc.  ARGL is the list of argument expressions.;N says which arg is to be returned as the value of the PROGN or PROG2;(equals the length of ARGL for PROGN, or 2 for PROG2, etc.).(DEFUN P2PROG12N (N DEST ARGL)  (PROG ((IDEST DEST))(WHEN (AND (NOT (EQ DEST 'D-IGNORE))   (< N (LENGTH ARGL)))  (SETQ IDEST 'D-PDL))   ;MIGHT COMPILE TEST ON RESULT INDICATORS(SETQ N (1- N))   ;Convert to origin 0.;; Compile the args before the one whose value we want.(DOTIMES (I N)  (P2 (OR (CAR ARGL) '(QUOTE NIL)) 'D-IGNORE)  (POP ARGL));; Compile the arg whose value we want.;; If it's the last arg (this is PROGN),;; make sure to pass along any multiple value target that the PROGN has,;; and to report back how many args were actually pushed.(COND ((AND (NULL (CDR ARGL)) M-V-TARGET)       (COND ((P2MV (OR (CAR ARGL) '(QUOTE NIL)) IDEST M-V-TARGET)      (INCPDLLVL))     ((NUMBERP M-V-TARGET)      (MKPDLLVL (+ PDLLVL M-V-TARGET))      (SETQ M-V-TARGET NIL))     (T (INCPDLLVL)   ;target was THROW, RETURN or MULTIPLE-VALUE-LIST(SETQ M-V-TARGET NIL))))      ((AND (NULL (CDR ARGL)) BDEST)       (P2BRANCH (OR (CAR ARGL) '(QUOTE NIL)) IDEST BDEST)       (SETQ BDEST NIL)       (WHEN (EQ IDEST 'D-PDL) (INCPDLLVL)))      (T (P2 (OR (CAR ARGL) '(QUOTE NIL)) IDEST) (WHEN (EQ IDEST 'D-PDL)   (INCPDLLVL))))(OR (CDR ARGL) (RETURN NIL));; Compile the remaining args.(DOLIST (ARG (CDR ARGL))  (P2 ARG 'D-IGNORE))(COND  ((NOT (EQ IDEST DEST))   (MOVE-RESULT-FROM-PDL DEST))  ((NOT (EQ DEST 'D-IGNORE))   (OUTF '(MOVE D-PDL PDL-POP))))));Make sure it's really in indicators              ; if IDEST and DEST both D-PDL(DEFUN PUSH-NILS (COUNT) ;;  9/30/85 DNG - Use P2PUSH-CONSTANT.  (DOTIMES (I COUNT)    (P2PUSH-CONSTANT (QUOTE NIL)))) ;;; Functions to gobble multiple values.(DEFPROP MULTIPLE-VALUE-BIND P2MULTIPLE-VALUE-BIND P2) (DEFUN P2MULTIPLE-VALUE-BIND (TAIL DEST)  ;; 01/14/86 DNG - Move the binding of PDLLVL so that it is restored  ;;                after the call to P2PBIND.  This is so that a RETURN out of  ;;                the body won't pop values that have already been %POPped.  ;;  1/22/86 DNG - Fix to unbind special variables.  ;;  8/19/86 DNG - Use PUSH-NILS instead of a DO loop generating MOVEs.  (LET ((VLIST (CAR TAIL))NBINDS)    (LET ((PDLLVL PDLLVL)  (MVTARGET (LENGTH VLIST))  (VARS (SECOND TAIL))  (MVFORM (FOURTH TAIL)))      ;; Compile the form to leave N things on the stack.      ;; If it fails to do so, then it left only one, so push the other N-1.      (MKPDLLVL (+ PDLLVL MVTARGET))      (AND (P2MV MVFORM 'D-PDL MVTARGET)   (PUSH-NILS (- MVTARGET 1)))      ;; Now pop them off, binding the variables to them.      ;; Note that the vlist contains the variables      ;; in the original order,      ;; each with an initialization of (%POP).      (SETQ NBINDS (P2PBIND VLIST (THIRD TAIL))))    (LET ((VARS (THIRD TAIL))  (BODY (CDDDDR TAIL))  (PROGDESCS PROGDESCS))      (UNLESS (ZEROP NBINDS);; Push a dummy progdesc so that GOs exiting this form can unbind our specials.(PUSH (MAKE-PROGDESC NAME '(LET)     PDL-LEVEL PDLLVL     NBINDS NBINDS)      PROGDESCS))      (P2PROG12N (LENGTH BODY) DEST BODY))    (UNBIND DEST NBINDS)))(DEFUN (:PROPERTY NTH-VALUE P2) (TAIL DEST)  ;; 10/17/86 DNG - Use NTH instead of ELT so args are not evaled in reverse order.  (IF (AND (QUOTEP (CAR TAIL))   (TYPEP (CADR (CAR TAIL)) '(INTEGER 0)))      (IF (ZEROP (CADR (CAR TAIL)))  (P2 `(VALUES ,(CADR TAIL)) DEST)(PROGN  (P2MV (CADR TAIL) 'D-PDL (1+ (CADR (CAR TAIL))))  (POPPDL 1 (CADR (CAR TAIL)))  (MOVE-RESULT-FROM-PDL DEST)))    (P2 `(NTH ,(CAR TAIL)      (MULTIPLE-VALUE-LIST ,(CADR TAIL)))DEST)))(DEFPROP MULTIPLE-VALUE P2MULTIPLE-VALUE P2) (DEFUN P2MULTIPLE-VALUE (TAIL DEST)  ;;  1/29/86 CLM - Modified for Rel.3 so that if DEST equals d-ignore and  ;;                the first element in variable list is nil, a complex-call-to push  ;;                will be generated instead of a c-c-to-inds  (LET* ((VARIABLES (CAR TAIL)) (DEST1   (IF (AND (NOT (COMPILING-FOR-V2)) (EQ DEST 'D-IGNORE) (NULL (CAR VARIABLES)))       'D-IGNORE     'D-PDL)))    (BLOCK NIL      (COND ((P2MV (CADR TAIL) DEST1 (LENGTH VARIABLES)); NIL if it actually pushes N values.     ;; It didn't push them.  Set the other variables to NIL.     (DOLIST (VAR (CDR VARIABLES))       (AND VAR (P2SETQ-1 VAR '(QUOTE NIL) 'D-IGNORE)))     ;; If the single value was discarded, nothing remains to be done.     (AND (EQ DEST1 'D-IGNORE) (RETURN NIL)))    (T     ;; It really did push N values on the stack.  Pop all but the first off.     (DOLIST (VAR (REVERSE (CDR VARIABLES)))       (IF VAR   (MOVEM-AND-MOVE-TO-DEST VAR 'D-IGNORE) (OUTF '(MOVE D-IGNORE PDL-POP))))))      ;; Now there is only one thing on the stack, which is the value      ;; of the first variable, and the value to be returned by      ;; the call to MULTIPLE-VALUE.      (IF (CAR VARIABLES)  (MOVEM-AND-MOVE-TO-DEST (CAR VARIABLES) DEST)(MOVE-RESULT-FROM-PDL DEST))      NIL))) (DEFPROP MULTIPLE-VALUE-PROG1 P2MULTIPLE-VALUE-PROG1 P2) (DEFUN P2MULTIPLE-VALUE-PROG1 (TAIL DEST)  ;;  4/21/86 CLM - Fix to prevent superfluous RETURN instruction  ;;                from being generated.  ;; 10/08/86 DNG - Fix to not use RETURN-N when only a single value pushed.  ;; 01/16/87 CLM - Fix to handle unbinding of special variables if within a  ;;                CATCH.  (LET (SINGLE-VALUE-RETURN)    (COND ((OR (EQ DEST 'D-RETURN)       (EQ M-V-TARGET 'RETURN-CATCH))   (SETQ SINGLE-VALUE-RETURN (P2MV (CAR TAIL) 'D-PDL 'RETURN))   (UNLESS SINGLE-VALUE-RETURN     (SETQ M-V-TARGET NIL)) )  (M-V-TARGET   (UNLESS (P2MV (CAR TAIL) DEST M-V-TARGET)     (SETQ M-V-TARGET nil)))  (T (P2 (CAR TAIL) (IF (EQ DEST 'D-LAST)     'D-PDL   DEST))))    (DOLIST (FORM (CDR TAIL))      (P2 FORM 'D-IGNORE))    (IF (AND (COMPILING-FOR-V2)     (EQ DEST 'D-RETURN)     (NOT SINGLE-VALUE-RETURN))(OUT-AUX 'RETURN-N)      (WHEN (MEMBER DEST '(D-RETURN D-LAST) :TEST #'EQ)(MOVE-RESULT-FROM-PDL DEST)))));; Note that we make no provision for the possibility;; than anything might want to optimize being compiled;; for multiple-value-list by storing the list directly;; to a destination other than D-PDL.(DEFPROP MULTIPLE-VALUE-LIST P2MULTIPLE-VALUE-LIST P2) (DEFUN P2MULTIPLE-VALUE-LIST (TAIL DEST)  ;;  2/14/86 DNG - Use OUTI instead of OUTF for NCONS.  (IF (P2MV (CAR TAIL) 'D-PDL 'MULTIPLE-VALUE-LIST)      (NO-D-RETURN (OUTM `(MISC ,DEST ,(MISC-LAP-CODE 'NCONS))))    (MOVE-RESULT-FROM-PDL DEST))) (DEFPROP MULTIPLE-VALUE-CALL P2MULTIPLE-VALUE-CALL P2)(DEFUN P2MULTIPLE-VALUE-CALL (FORM DEST)  ;;  9/05/86 CLM - Original.  If there still is a multiple-value-call   ;;                at this point, then there is only a single form in  ;;                the arglist.  Call P2MV with this form and a DEST  ;;                D-PDL and an M-V-TARGET of RETURN so that the values  ;;                returned will be pushed on the stack followed by the  ;;                count.  This sets things up for a CALL-N to the function.  ;; 10/01/86 CLM - Use a CALL-1 instruction for cases where there is only a  ;;                single value returned from P2MV.  ;; 10/20/86 CLM - Undo the previous change; the conversion to CALL-1 is now  ;;                done in PEEP.  (LET (SINGLE-VALUE-RETURN)    (SETQ SINGLE-VALUE-RETURN  (P2MV (SECOND FORM) 'D-PDL 'RETURN))    (WHEN SINGLE-VALUE-RETURN      (P2PUSH-CONSTANT 1))    (OUTI (LIST 'CALL-N DEST (P2-SOURCE (CAR FORM) 'D-PDL)))    ))(DEFPROP *THROW P2THROW P2) (DEFPROP THROW P2THROW P2) (DEFUN P2THROW (TAIL IGNORE)  ;; 10/28/85 CLM - Changed to generate Rel.3 aux-ops %THROW and  ;;                %THROW-N instead of misc-op *THROW.  ;;  2/07/86 CLM - Modified to emit a %close-catch if the throw is  ;;                from within the undo forms of an unwind protect.  ;; 11/17/86 CLM - Increment the pdllvl after pushing the tag so that we  ;;                know it's been pushed in case we exit before the throw  ;;                and have to pop the tag off the stack.  (P2PUSH (CAR TAIL))   ;Compute and push the tag.  (INCPDLLVL)  (IF (COMPILING-FOR-V2)      (LET (SINGLE-VALUE-RETURN)(SETQ SINGLE-VALUE-RETURN      (P2MV (CADR TAIL) 'D-PDL 'THROW))(IF SINGLE-VALUE-RETURN    (OUTI '(AUX %THROW))  (OUTI '(AUX %THROW-N))))    (PROGN      (P2MV (CADR TAIL) 'D-PDL 'THROW)      (OUTI '(MISC D-IGNORE *THROW))))  (SETQ DROPTHRU NIL)) (DEF MULTIPLE-VALUE-PUSH)(DEFPROP MULTIPLE-VALUE-PUSH (&QUOTE NUMBER-OF-VALUES &EVAL EXPRESSION) ARGLIST)(DEFUN (:PROPERTY MULTIPLE-VALUE-PUSH P2) (TAIL DEST)  (DECLARE (IGNORE DEST))  (WHEN (P2MV (CADR TAIL) 'D-PDL (CAR TAIL))   ; NIL if it actually pushes N values.    ;; It didn't push them.  Push extra NILs.    (PUSH-NILS (1- (CAR TAIL))))  (MKPDLLVL (+ PDLLVL (CAR TAIL)))) ;Functions to generate multiple values.(DEFPROP VALUES P2VALUES P2) (DEFUN P2VALUES (ARGL DEST)  ;;  8/21/85 - Use OUT-AUX.  ;;  9/07/85 - Use main-op form of RETURN-2 and RETURN-3.  ;;  9/25/85 - AUX RETURN-0 etc.  ;; 10/28/85 - CLM  Changed to generate Rel.3 aux-ops %THROW  ;;            and %THROW-N instead of misc-ops THROW-N and *THROW.  ;; 12/18/85 - CLM  For rel. 3, modified so that when M-V-TARGET equals  ;;            RETURN the RETURN-N-KEEP-CONTROL misc-op is no longer  ;;            emitted; values and count are pushed on the stack.  ;;  2/17/86 DNG - Use LAP-VALUE instead of GET-FOR-TARGET.  ;;  7/16/86 CLM - No longer generate a throw here; this was causing too  ;;                many throws when there was an intervening CATCH between  ;;                the THROW and its target.  ALSO , when M-V-TARGET is RETURN  ;;                and only one item is in the argl, do not set M-V-TARGET to  ;;                nil; this signals that a single value is being returned.  ;;  9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET.    (BLOCK NIL    ;; Handle returning from the top level of a function.    (WHEN (EQ DEST 'D-RETURN)   (LET ((NARGS (LENGTH ARGL)))     (WHEN (= NARGS 1)       ;; DON'T change this to (P2 ... 'D-RETURN)       ;; because we want to make sure to pass only one value.       (P2 (CAR ARGL) 'D-PDL)       (MOVE-RESULT-FROM-PDL 'D-RETURN)       (RETURN))     (IF (COMPILING-FOR-V2) (COND ((AND (LAP-VALUE 'RETURN-0)     (<= NARGS 63))(ARGLOAD ARGL 'D-PDL)(OUT-AUX 'RETURN-0 NARGS))   ((= NARGS 2)    (P2PUSH (FIRST ARGL))    (LET ((ADR (P2-SOURCE (SECOND ARGL) 'D-PDL)))      (IF (EQ ADR 'PDL-POP)  (OUT-AUX '%RETURN-2)(OUTI `(RETURN-2 0 ,ADR)))))   ((= NARGS 3)    (P2PUSH (FIRST ARGL))    (P2PUSH (SECOND ARGL))    (LET ((ADR (P2-SOURCE (THIRD ARGL) 'D-PDL)))      (IF (EQ ADR 'PDL-POP)  (OUT-AUX '%RETURN-3)(OUTI `(RETURN-3 0 ,ADR)))))   ((ZEROP NARGS)    (P2VALUES-LIST '((QUOTE NIL)) DEST))   (T (ARGLOAD ARGL 'D-PDL)      (P2PUSH-CONSTANT NARGS)      (OUT-AUX '%RETURN-N)))       (PROGN (ARGLOAD ARGL 'D-PDL) (COND ((= NARGS 2) (OUT-AUX '%RETURN-2))       ((= NARGS 3) (OUT-AUX '%RETURN-3))       ((ZEROP NARGS)(P2VALUES-LIST '((QUOTE NIL)) DEST))       (T (P2PUSH-CONSTANT NARGS)  (OUT-AUX '%RETURN-N)))))     (SETQ DROPTHRU NIL)   ;Above MISC RETURN instructions return     (RETURN NIL)))    (COND ((NUMBERP M-V-TARGET)   ;; If we want N values on the stack,   ;; then eval all the args to return   ;; and save exactly N things on the stack.   (DO ((VALS ARGL (CDR VALS))(I 0 (1+ I)))       ((AND (NULL VALS) (>= I M-V-TARGET)))     (P2 (OR (CAR VALS) '(QUOTE NIL)) (IF (>= I M-V-TARGET)     'D-IGNORE   'D-PDL))))  ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST)   (P2 `(LIST . ,ARGL) DEST))  ((EQ M-V-TARGET 'THROW)   (DOLIST (ELT ARGL)     (P2PUSH ELT))   (IF (= (LENGTH ARGL) 1)       (UNLESS (COMPILING-FOR-V2) (OUTM '(MISC D-IGNORE *THROW)) (SETQ DROPTHRU NIL))     (PROGN       (P2PUSH-CONSTANT (LENGTH ARGL))       (UNLESS (COMPILING-FOR-V2) (OUTM '(MISC D-IGNORE THROW-N)) (SETQ DROPTHRU NIL)))     ))  ((MEMBER M-V-TARGET '(RETURN RETURN-CATCH) :TEST #'EQ)   (DOLIST (ELT ARGL)     (P2PUSH ELT))   (IF (= (LENGTH ARGL) 1)       (RETURN)     (P2PUSH-CONSTANT (LENGTH ARGL))))  ((NULL M-V-TARGET)   (LET ((PDLLVL PDLLVL))     (P2PROG12N 1 DEST ARGL))))    (SETQ M-V-TARGET NIL)    NIL))(DEFPROP VALUES-LIST P2VALUES-LIST P2) (DEFUN P2VALUES-LIST (ARGL DEST)  ;;  8/21/85 - For release 3, RETURN-LIST is an Aux-op.  ;;  1/16/86 - CLM For release 3, no longer uses the obsolete  ;;            THROW-SPREAD. Use %SPREAD and then push length   ;;            of the list on the stack.  ;;  1/20/86 - CLM For release 3, no longer uses the obsolete  ;;            %SPREAD-N.  Call P2ARGC with VALUES-LIST as the  ;;            function argument.  ;;  3/19/86 - CLM When M-V-TARGET equals RETURN, spread the ARGL  ;;            and set up for a RETURN-N; no longer uses RETURN-SPREAD-  ;;            KEEP-CONTROL.  ;;  9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET.  (PROG (ARG)(SETQ ARG (CAR ARGL))(COND ((EQ DEST 'D-RETURN)       (IF (COMPILING-FOR-V2)   (PROGN     (P2PUSH ARG)     (OUT-AUX 'RETURN-LIST)     (SETQ DROPTHRU NIL)) (P2MISC 'RETURN-LIST ARGL 'D-RETURN 1)))      ((NULL M-V-TARGET)       (P2 `(CAR ,ARG) DEST))      ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST)       (P2 ARG DEST))      ((EQ M-V-TARGET 'THROW)       ;;added 1/16/86 by CLM       (IF (COMPILING-FOR-V2)   (PROGN     #+compiler:debug     (ASSERT (TRIVIAL-FORM-P ARG) ()     "A NON-TRIVIAL ARG WAS PASSED TO P2VALUES-LIST")     (P2PUSH ARG)     (OUT-AUX '%SPREAD)     (P2PUSH ARG)     (OUTM '(MISC D-PDL LENGTH)))  ;STACK IS SET FOR A THROW-N (PROGN   (P2PUSH ARG)   (OUTM '(MISC D-IGNORE THROW-SPREAD)))))      ((MEMBER M-V-TARGET '(RETURN RETURN-CATCH) :TEST #'EQ)       (IF (COMPILING-FOR-V2)   (PROGN     #+compiler:debug     (ASSERT (TRIVIAL-FORM-P ARG) ()     "A NON-TRIVIAL ARG WAS PASSED TO P2VALUES-LIST")     (P2PUSH ARG)     (OUT-AUX '%SPREAD)     (P2PUSH ARG)     (OUTM '(MISC D-PDL LENGTH)))  ;STACK SET FOR A RETURN-N (PROGN   (P2PUSH ARG)   (OUTM '(MISC D-IGNORE RETURN-SPREAD-KEEP-CONTROL)))))      ((NUMBERP M-V-TARGET)       ;;added 1/20/86 by CLM       (IF (COMPILING-FOR-V2)   (P2ARGC NIL ARGL NIL DEST 'VALUES-LIST) (PROGN   (NEEDPDL 2)   (P2PUSH ARG)   (P2PUSH-CONSTANT M-V-TARGET)   (OUTF '(MISC D-PDL %SPREAD-N))))))(SETQ M-V-TARGET NIL)))(DEFUN (:PROPERTY UNWIND-PROTECT P2) (FORMS DEST)  ;;  11/17/85 CLM - MODIFIED FOR REL. 3.  NOW EMITS AUX-OPS  ;;                 %OPEN-CATCH, %OPEN-CATCH-MULTIPLE-VALUE  ;;                 AND %CLOSE-CATCH INSTEAD OF FORMER MISC-OPS  ;;                 TO CREATE AND THEN REMOVE A CATCH BLOCK.  ;;  12/05/85 CLM - MODIFIED FOR REL.3 TO HANDLE CASES WHERE  ;;                 M-V-TARGET EQUALS 'THROW, 'RETURN OR 'MULTIPLE-  ;;                 VALUE-LIST, AND THOSE CASES WHERE DEST EQUALS  ;;                 'D-RETURN.  ;;   1/30/86 CLM - For Rel.3, modified to handle cases where there  ;;                 is a return from within an unwind-protect.  Cleanup  ;;                 forms are now handled as a subroutine using the  ;;                 LONG-PUSHJ and POPJ instructions.  ;;   2/05/86 CLM - An addendum to the above modification.  This handles  ;;                 returns from within the cleanup-forms, and has the  ;;                 restart-pc point to a pushj to the undo-forms.  ;;   4/21/86 CLM - If DEST equals D-IGNORE then instead of an %open-catch  ;;                 generate an %open-catch-multiple-value instruction with  ;;                 an argument of 0 to indicate no values are expected.  ;;   5/07/86 CLM - In the case where only a single value is to be returned,  ;;                 do a multiple-value return with 1 as the number values.  ;;                 Also, the catch-block is now 5 words long.  ;;   5/29/86 CLM - Use the constant CATCH-BLOCK-SIZE instead of the number 5.  ;;   6/20/86 CLM - Add special handling for an M-V-TARGET of MULTIPLE-VALUE-LIST.  ;;                 Also, fix to reset PDLLVL after the clean-up forms, instead  ;;                 of before.  This was causing problems when there was a return   ;;                 from within the clean-up forms  ;;   7/15/86 CLM - Add more special handling for cases where multiple-values are  ;;                 expected, but only a single value is generated.  ;;   9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET.  ;;  11/17/86 CLM - Changed to handle the new microcode scheme for Unwind-protects.  ;;                 There are now separate mcr funtions to open and close an unwind-  ;;                 protects.  We now also take special note of the pdllvl upon  ;;                 entry to the undo forms to handle exits from them.  (LET ((RESTART-TAG (GENSYM))(UNDO-TAG (GENSYM))(EXIT-TAG (WHEN (OR (COMPILING-FOR-V2)    M-V-TARGET)    (GENSYM)))(PDLLVL0 PDLLVL)SINGLE-VALUE-RETURN)    (IF (COMPILING-FOR-V2)(LET ((CALL-BLOCK-PDL-LEVELS CALL-BLOCK-PDL-LEVELS)      (WITHIN-CATCH T))  (P2PUSH-CONSTANT T)   ;CATCH-TAG  (OUTI1 (LIST 'MOVE 'D-PDL   ;RESTART-PC       `(QUOTE-VECTOR (TAG ,RESTART-TAG))))  (COND    ((EQ DEST 'D-RETURN)     (P2PUSH-CONSTANT NIL)     (OUTF '(AUX %OPEN-CATCH-MULTIPLE-VALUE)))    ((EQ DEST 'D-IGNORE)     (P2PUSH-CONSTANT 0)     (OUT-AUX '%OPEN-CATCH-MULTIPLE-VALUE))    ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST)     (OUTF '(AUX %OPEN-CATCH-MV-LIST)))    ((OR (EQ M-V-TARGET 'THROW) (EQ M-V-TARGET 'RETURN) (EQ M-V-TARGET 'RETURN-CATCH))     (P2PUSH-CONSTANT NIL)     (OUTF '(AUX %OPEN-CATCH-MULTIPLE-VALUE)))    ((NUMBERP M-V-TARGET)     (P2PUSH-CONSTANT M-V-TARGET)     (OUTF '(AUX %OPEN-CATCH-MULTIPLE-VALUE)))    (T (OUTF '(AUX %OPEN-CATCH))))  ;;This causes a problem in the new scheme, so it has been  ;;removed.  So far its removal has caused no problems.  #|(COND    ((NULL M-V-TARGET))    ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST)     (INCPDLLVL))    ((NUMBERP M-V-TARGET)     (MKPDLLVL (+ PDLLVL M-V-TARGET))))          |#  (PUSH (LIST PDLLVL 'UNWIND-PROTECT UNDO-TAG)CALL-BLOCK-PDL-LEVELS)  (MKPDLLVL (+ CATCH-BLOCK-SIZE PDLLVL))      ;words of call block  (COND    ((EQ DEST 'D-RETURN)     (SETQ SINGLE-VALUE-RETURN (P2MV (CAR FORMS) 'D-PDL 'RETURN)))    ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST)     (WHEN       (P2MV (CAR FORMS) 'D-PDL M-V-TARGET)       (OUTI '(MISC D-PDL NCONS)) )   ;must convert a single value into a list     )    (M-V-TARGET      (SETQ SINGLE-VALUE-RETURN   (P2MV (CAR FORMS) (IF (EQ DEST 'D-IGNORE)     DEST     'D-PDL) (IF (EQ M-V-TARGET 'RETURN-CATCH)     'RETURN M-V-TARGET))))    (T (P2 (CAR FORMS)   (IF (EQ DEST 'D-IGNORE)       DEST     'D-PDL))))  (SETQ DROPTHRU T)  (WHEN SINGLE-VALUE-RETURN     ;handle all returns as a form of mv-return    (IF (NUMBERP M-V-TARGET)(DOTIMES (I (1- M-V-TARGET))  (P2PUSH-CONSTANT (QUOTE NIL))  (INCPDLLVL))    (P2PUSH-CONSTANT 1)))  (SETQ M-V-TARGET NIL)  ;;the restart-pc now points to the %close-catch-unwind-protect  (OUTF `(RESTART-TAG ,RESTART-TAG))  (OUT-AUX '%CLOSE-CATCH-UNWIND-PROTECT)  (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE))  (OUTB `(BRANCH PUSHJ NIL NIL ,UNDO-TAG))  (IF (EQ DEST 'D-RETURN)      (PROGN(OUT-AUX '%UNWIND-PROTECT-CONTINUE)(OUT-AUX 'RETURN-N)(SETQ DROPTHRU NIL))    (PROGN      (OUT-AUX '%UNWIND-PROTECT-CONTINUE)      (UNLESS (EQ DEST 'D-IGNORE)(MOVE-RESULT-FROM-PDL DEST))))  (OUTB `(BRANCH ALWAYS NIL NIL ,EXIT-TAG))  (SETQ DROPTHRU T)  (OUTF UNDO-TAG)  ;;add a tag to call-block-pdl-levels to indicate  ;;you are in the undo forms  (NCONC (CAR CALL-BLOCK-PDL-LEVELS) '(UNDO))  ;;also now need to keep track of the pdllvl of the  ;;undo forms so that can pop any garbage off stack before  ;;doing an %unwind-protect-cleanup if there is some type of  ;;return out of the undo forms.  This is not necessary if the   ;;unwind-protect is at top level.  (WHEN PROGDESCS(SETF (PROGDESC-UNDO-PDL-LEVEL (FIRST PROGDESCS))      (CONS PDLLVL (PROGDESC-UNDO-PDL-LEVEL (FIRST PROGDESCS)))))  (INCPDLLVL)  ;;inc for the restart-macro-pc pushed on the stack by long-pushj  (DOLIST (FORM (CDR FORMS))   ;cleanup forms    (P2 FORM 'D-IGNORE))  (OUT-AUX 'POPJ)  (SETQ DROPTHRU NIL)  (OUTTAG EXIT-TAG)  ;;why does it reset the pdllvl to the original level?  ;;what about the values left on the stack  ;;i think because this hasn't broken anything it would  ;;indicate that it doesn't matter  (SETQ PDLLVL PDLLVL0)  )      ;;the vm1 version      (let ((pdllvl0 pdllvl))(LET ((CALL-BLOCK-PDL-LEVELS CALL-BLOCK-PDL-LEVELS)      (WITHIN-CATCH T))  (OUTI1    `(ADI-CALL CALL D-IGNORE (QUOTE-VECTOR (FUNCTION *CATCH))       (RESTART-PC (QUOTE-VECTOR (TAG ,RESTART-TAG))   BIND-STACK-LEVEL NIL MULTIPLE-VALUE   (QUOTE-VECTOR '4))))  (MKPDLLVL (+ PDLLVL 10))   ;4 MULTIPLE VALUE WORDS, 6 ADI WORDS  (PUSH (LIST PDLLVL 'UNWIND-PROTECT RESTART-TAG)CALL-BLOCK-PDL-LEVELS)  (MKPDLLVL (+ 4 PDLLVL))   ;4 WORDS OF CALL BLOCK  (P2 ''T 'D-PDL)   ;CATCH TAG IS T  (INCPDLLVL)  (COND    ((NUMBERP M-V-TARGET)     (WHEN (P2MV (CAR FORMS) 'D-PDL M-V-TARGET)       (PUSH-NILS (1- M-V-TARGET)))     (POPPDL M-V-TARGET (- PDLLVL PDLLVL0))     (OUTB `(BRANCH ALWAYS NIL NIL ,EXIT-TAG)))    ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST)     (IF (P2MV (CAR FORMS) 'D-PDL M-V-TARGET) (OUTI '(MISC D-LAST NCONS))       (OUTI '(MOVE D-LAST PDL-POP))))    ((OR (EQ M-V-TARGET 'THROW) (EQ M-V-TARGET 'RETURN))     (P2MV (CAR FORMS) 'D-PDL M-V-TARGET)     (OUTI '(MOVE D-LAST PDL-POP)))    (T (P2 (CAR FORMS) (IF (EQ DEST 'D-RETURN)   DEST 'D-LAST))))  (SETQ M-V-TARGET NIL)  (SETQ PDLLVL (+ PDLLVL0 4))   ;NOW HAVE JUST 4 MULTIPLE VALUES ON STACK  (SETQ DROPTHRU T)  (OUTF `(RESTART-TAG ,RESTART-TAG)))(DOLIST (FORM (CDR FORMS))   ;CLEANUP FORMS  (P2 FORM 'D-IGNORE))(SETQ PDLLVL PDLLVL0)(OUTI `(MISC ,DEST %UNWIND-PROTECT-CONTINUE))(WHEN EXIT-TAG  (OUTF EXIT-TAG))))))(DEFUN (:PROPERTY %MAKE-EXPLICIT-STACK-LIST P2) (FORMS DEST)  (ARGLOAD FORMS 'D-PDL)  (P2PUSH-CONSTANT (LENGTH FORMS))  (OUTI `(MISC ,DEST %MAKE-EXPLICIT-STACK-LIST))) (DEFUN (:PROPERTY %MAKE-EXPLICIT-STACK-LIST* P2) (FORMS DEST)  (ARGLOAD FORMS 'D-PDL)  (P2PUSH-CONSTANT (LENGTH FORMS))  (OUTI `(MISC ,DEST %MAKE-EXPLICIT-STACK-LIST*))) (DEFUN (:PROPERTY LET* P2) (ARGL DEST)  ;;  7/15/86 DNG - Add binding of CLOSURE-DISCONNECT-OFFSETS and LEXICAL-CLOSURE-COUNT.  (LET ((VARS (CADR ARGL))(CLOSURE-DISCONNECT-OFFSETS NIL)(LEXICAL-CLOSURE-COUNT LEXICAL-CLOSURE-COUNT)(KEEP-CURRENT-FRAME KEEP-CURRENT-FRAME))    (P2LET-INTERNAL VARS (P2SBIND (CAR ARGL) (CADDR ARGL) VARS) ARGL DEST)))(DEFPROP LET P2LET P2)(DEFPROP LET-FOR-LAMBDA P2LET P2)(DEFUN P2LET (ARGL DEST)  ;;  7/07/86 DNG - Use same handler for LET and LET-FOR-LAMBDA.  ;;  7/15/86 DNG - Add binding of CLOSURE-DISCONNECT-OFFSETS and LEXICAL-CLOSURE-COUNT.  (LET ((VARS (CADR ARGL))(CLOSURE-DISCONNECT-OFFSETS NIL)(LEXICAL-CLOSURE-COUNT LEXICAL-CLOSURE-COUNT)(KEEP-CURRENT-FRAME KEEP-CURRENT-FRAME))    (P2LET-INTERNAL VARS (P2PBIND (CAR ARGL) (CADDR ARGL)) ARGL DEST))) ;LET-HACK is generated by LET-INTERNAL in case of lexical closures and WITHIN-CATCH.(DEFUN (:PROPERTY LET-HACK P2) (ARGL DEST)  (LET ((VARS (CAR ARGL)))    (P2LET-INTERNAL VARS (CADR ARGL) (CADDR ARGL) DEST T))) ;Compile the body of a LET.  The variable binding has already been done;by P1PBIND or P1SBIND, which returned the number of special bindings made;which is our argument NBINDS.(DEFUN P2LET-INTERNAL (OVARS NBINDS ARGL DEST &OPTIONAL IGNORE-LEXICAL-CLOSURES)  ;;  2/06/86 DNG - Move the result value of the LET to its proper destination  ;;    after any lexical closure disconnect or unshare instructions  ;;    so that the indicators will be correct for any conditional  ;;    branch which may follow.  [SPR 1075]  ;;  5/23/86 CLM - When M-V-TARGET equals RETURN, don't issue unbind instructions.  ;;                This was causing a problem when returning the result  ;;                of a CATCH.  ;;  7/15/86 DNG - Fix to unshare variables used in lexical closures created  ;;at lower levels.  ;;  7/16/86 DNG - Fix to use D-PDL instead of D-INDS when a STACK-CLOSURE-UNSHARE  ;;is possible so the indicators don't get clobbered.  [SPR 2571]  ;;  9/02/86 DNG - For VM2, need to unbind specials even when M-V-TARGET is RETURN.  ;;  9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET.  This value  ;;                indicates that special variables should not be unbound.  ;;  9/13/86 DNG - Modify check for %BIND with multiple values to issue a warning but  ;;not do any unbinding when M-V-TARGET is RETURN.  ;; 12/15/86 DNG - Save special-pdl-index in a local variable when it can't  ;;be kept on the stack because of an unknown number of values.  (IF (AND WITHIN-CATCH   (NOT IGNORE-LEXICAL-CLOSURES)   (OR (NEQ (FIFTH ARGL) (SIXTH ARGL))       (NOT (NULL CLOSURE-DISCONNECT-OFFSETS))))      (P2F`(UNWIND-PROTECT (LET-HACK ,OVARS ,NBINDS ,ARGL)   (DISCONNECT-STACK-CLOSURES ,(FIFTH ARGL) ,(SIXTH ARGL))   (UNSHARE-STACK-CLOSURE-VARS ,VARS ,OVARS))DEST)    (LET* ((VARS (THIRD ARGL))   (IBINDP (FOURTH ARGL))   (ENTRY-LEXICAL-CLOSURE-COUNT (FIFTH ARGL))   (EXIT-LEXICAL-CLOSURE-COUNT (SIXTH ARGL))   (BDY (NTHCDR 6 ARGL))   (IDEST 'D-PDL)   NVALUES   M-V-DONE   (PROGDESCS PROGDESCS))      ;; Determine the immediate destination of returns in this prog.      (WHEN (AND (MEMBER DEST '(D-IGNORE D-INDS D-RETURN) :TEST #'EQ) (NULL M-V-TARGET) (NOT   (AND (NEQ DEST 'D-RETURN)(NOT IGNORE-LEXICAL-CLOSURES)(OR (/= ENTRY-LEXICAL-CLOSURE-COUNT EXIT-LEXICAL-CLOSURE-COUNT)    (AND TAGOUT (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES  *CURRENT-COMPILAND*)))(NOT (COMPILING-FOR-V2)))))(SETQ IDEST DEST))      ;; If BIND is used within this LET, and it's an internal LET,      ;; we must push the specpdl index at entry so we can unbind to it later.      (WHEN IBINDP   ;**** was (AND IBINDP (NOT (EQ DEST 'D-RETURN))) ****(SETQ KEEP-CURRENT-FRAME T)(OUTM '(MISC D-PDL SPECIAL-PDL-INDEX))(IF (CONSP IBINDP) ; P1LET has provided a place to save the index    (OUTI `(POP 0 ,(P2-DESTINATION IBINDP)))  ;; else leave it on the stack.  (INCPDLLVL)))      ;; Push a dummy progdesc so that GOs exiting this LET can unbind our specials.      (PUSH (MAKE-PROGDESC NAME '(LET)   PDL-LEVEL PDLLVL   NBINDS (IF IBINDP      (IF (CONSP IBINDP)  (LIST NBINDS IBINDP)(LIST NBINDS))    NBINDS))    PROGDESCS)      (WHEN (AND (EQ M-V-TARGET 'THROW) (NOT (COMPILING-FOR-V2)) IBINDP (ATOM IBINDP));; In case we are going to generate a throw from a handler invoked within the;; LET body, need to have the throw tag on top of the stack, so copy it above;; the special-pdl-index.(P2PUSH-CONSTANT 1)(OUTM '(MISC D-PDL PDL-WORD)))      ;; How many words are we supposed to leave on the stack?      (SETQ NVALUES (COND      ((NUMBERP M-V-TARGET) M-V-TARGET)      ((EQ IDEST 'D-PDL) 1)      (T 0)))      (UNLESS BDY(SETQ BDY '((QUOTE NIL))))      (DO ((TAIL BDY (CDR TAIL)))  ((NULL (CDR TAIL))   (UNLESS (P2MV (CAR TAIL) IDEST M-V-TARGET)     (SETQ M-V-DONE T)))(P2 (CAR TAIL) 'D-IGNORE))      (UNLESS M-V-DONE(SETQ NVALUES 1))      ;; If this is a top-level PROG, we just went to D-RETURN, so we are done.      (UNLESS (EQ DEST 'D-RETURN);; Unbind any locals that need to be unbound.(UNLESS IGNORE-LEXICAL-CLOSURES (LET ((CLOBBERED-INDICATORS NIL))   (WHEN (AND (OR (/= ENTRY-LEXICAL-CLOSURE-COUNT EXIT-LEXICAL-CLOSURE-COUNT)  (NOT (NULL CLOSURE-DISCONNECT-OFFSETS)))      (NOT (COMPILING-FOR-V2)))     (P2 `(DISCONNECT-STACK-CLOSURES ,ENTRY-LEXICAL-CLOSURE-COUNT     ,EXIT-LEXICAL-CLOSURE-COUNT) 'D-IGNORE)     (SETQ CLOBBERED-INDICATORS T))   (WHEN (AND TAGOUT      (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES *CURRENT-COMPILAND*))     (P2 `(UNSHARE-STACK-CLOSURE-VARS ,VARS ,OVARS) 'D-IGNORE)     (SETQ CLOBBERED-INDICATORS T))   (WHEN (AND CLOBBERED-INDICATORS      (EQ DEST IDEST)      (EQ DEST 'D-PDL)      (NOT (COMPILING-FOR-V2)))     ;; Restore the indicator value which was destroyed by the disconnect     ;; instruction in case a conditional branch comes next.  The peephole     ;; optimizer will delete this instruction if it turns out to not     ;; really be needed.     (OUTI '(MOVE D-PDL PDL-POP)) )))(WHEN (AND (EQ M-V-TARGET 'THROW) (NOT (COMPILING-FOR-V2)) IBINDP (ATOM IBINDP))  (POPPDL NVALUES 1));; Unbind any specials;; 5/23/86 (UNLESS (OR (EQ M-V-TARGET 'RETURN-CATCH)    (AND (EQ M-V-TARGET 'RETURN) (NOT (COMPILING-FOR-V2))) )  (BLOCK UNBIND    (COND ((NULL IBINDP))  ((CONSP IBINDP)   (P2PUSH IBINDP)   (OUTPUT-UNBIND-TO-INDEX 0))  (T   (UNLESS (OR (NULL M-V-TARGET)       (NUMBERP M-V-TARGET))     (IF (EQ M-V-TARGET 'RETURN) (PROGN (WARN 'LET-INTERNAL :IMPLAUSIBLE  "Warning: %BIND within form producing unknown number of values will not beunbound until returning from the function.")(RETURN-FROM UNBIND))       (WARN 'let-internal :IMPLEMENTATION-LIMIT  "The use of %BIND within a form that produces an unknown number of values iscurrently unsupported")))   (OUTPUT-UNBIND-TO-INDEX NVALUES)))    (UNBIND IDEST NBINDS) ));; Dispose of our value.(AND (NEQ DEST IDEST)     (NULL M-V-TARGET)     (MOVE-RESULT-FROM-PDL DEST));; If we produced multiple values, say we did.(WHEN M-V-DONE  (SETQ M-V-TARGET NIL))))));These two do not occur in code except as generated by P2PROG-INTERNAL.;They are almost a kind of macro for use in pass 2.(DEFUN (:PROPERTY DISCONNECT-STACK-CLOSURES P2) (ARGL IGNORE)  ;;  1/9/86 - Not applicable to VM2.  ;; 7/15/86 - Redesigned to use CLOSURE-DISCONNECT-OFFSETS. [from Compiler patch 2.6]  (UNLESS (COMPILING-FOR-V2)    (LET ((ENTRY-LEXICAL-CLOSURE-COUNT (CAR ARGL));;(EXIT-LEXICAL-CLOSURE-COUNT (CADR ARGL))  )      ;; -- new way 4/30/86 --      (DOLIST ( OFFSET (REVERSE CLOSURE-DISCONNECT-OFFSETS) )(OUTI `(,(IF (= OFFSET (+ (LENGTH (COMPILAND-LOCAL-MAP *CURRENT-COMPILAND*))  (* 4 ENTRY-LEXICAL-CLOSURE-COUNT)))     'STACK-CLOSURE-DISCONNECT-FIRST   'STACK-CLOSURE-DISCONNECT),OFFSET)))      #|  -- old way      (DO ((I ENTRY-LEXICAL-CLOSURE-COUNT (1+ I)))  ((= I EXIT-LEXICAL-CLOSURE-COUNT))(OUTI  `(,(IF (= I ENTRY-LEXICAL-CLOSURE-COUNT) 'STACK-CLOSURE-DISCONNECT-FIRST       'STACK-CLOSURE-DISCONNECT)    ,(+ (LENGTH (COMPILAND-LOCAL-MAP *CURRENT-COMPILAND*))(* 4 I))))))      |#      )))(DEFUN (:PROPERTY UNSHARE-STACK-CLOSURE-VARS P2) (ARGL IGNORE)  ;;  7/12/85 - Unshare only when there is a possibility of looping  ;;            back and binding the same variables to new values.  ;;  1/09/85 - For rel3, use LEXICAL-UNSHARE instead of STACK-CLOSURE-UNSHARE.  ;;  2/21/86 - Use LEXICAL-UNSHARE-ALL instruction.  ;;  7/07/86 - Obtain VARIABLES-USED-IN-LEXICAL-CLOSURES from *CURRENT-COMPILAND*.  ;; 11/19/86 - Pop deleted variables off OVARS so that the loop termination test  ;;(EQ VS OVARS) works properly -- they won't be in VARS if the LET  ;;that created them was completly optimized away.  (WHEN TAGOUT   ; may be within a loop    (LET ((VARS (CAR ARGL))  (OVARS (CADR ARGL))  (UNSHARE-VARS NIL))      (LOOP WHILE (EQ (VAR-KIND (FIRST OVARS)) 'FEF-ARG-DELETED)    DO (POP OVARS))      (DO ((VS VARS (CDR VS)))  ((OR (EQ VS OVARS)       (NULL VS))   (DEBUG-ASSERT (EQ VS OVARS)))(LET ((V (CAR VS)))  (WHEN (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC V) :TEST #'EQ)    (PUSH V UNSHARE-VARS))))      (UNLESS (NULL UNSHARE-VARS)(LET (( VARIABLES-USED-IN-LEXICAL-CLOSURES       (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES *CURRENT-COMPILAND*) ))  (DECLARE (UNSPECIAL VARIABLES-USED-IN-LEXICAL-CLOSURES)   (TYPE LIST VARIABLES-USED-IN-LEXICAL-CLOSURES))  (IF (AND (COMPILING-FOR-V2)   (= (LENGTH UNSHARE-VARS)      (LENGTH VARIABLES-USED-IN-LEXICAL-CLOSURES)))      (OUTI '(AUX LEXICAL-UNSHARE-ALL))    (DOLIST (V UNSHARE-VARS)      (OUTI(LIST (IF (COMPILING-FOR-V2)  'LEXICAL-UNSHARE'STACK-CLOSURE-UNSHARE)      (POSITION V (THE LIST VARIABLES-USED-IN-LEXICAL-CLOSURES):TEST #'EQ)))))))))) ;Compile a BLOCK.;A BLOCK has no user-defined GOTAGS, but it does have one tag at this level: its rettag.(DEFPROP BLOCK P2BLOCK P2) (DEFUN P2BLOCK (ARGL DEST &OPTIONAL BIND-RETPROGDESC D-INDS-LOSES)  ;;  7/03/86 DNG - Eliminate binding of RETPROGDESC since it is now handled in pass 1.  ;; 10/18/86 DNG - RETTAG is now a structure instead of a symbol; don't need GOTAGS anymore.  (DECLARE (IGNORE BIND-RETPROGDESC)) ; no longer used  (LET* ((MYGOTAGS (CAR ARGL)) (MYPROGDESC (CADR ARGL)) (BDY (CDDR ARGL)) (RETTAG (PROGDESC-RETTAG MYPROGDESC)) (PROGDESCS (CONS MYPROGDESC PROGDESCS)) )    (PROG (IDEST NVALUES)  ;; Determine the immediate destination of returns in this prog.  (SETQ IDEST 'D-PDL)  (AND (MEMBER DEST '(D-IGNORE D-INDS D-RETURN) :TEST #'EQ)       (NOT (AND (EQ DEST 'D-INDS) D-INDS-LOSES))       (NULL M-V-TARGET)       (SETQ IDEST DEST))  ;; How many words are we supposed to leave on the stack?  (SETQ NVALUES (COND  ((NUMBERP M-V-TARGET) M-V-TARGET)  ((EQ IDEST 'D-PDL) 1)  (T 0)))  (SETF (PROGDESC-IDEST MYPROGDESC) IDEST)  (SETF (PROGDESC-M-V-TARGET MYPROGDESC) M-V-TARGET)  (SETF (PROGDESC-PDL-LEVEL MYPROGDESC) PDLLVL)  (SETF (PROGDESC-NBINDS MYPROGDESC) 0)  ;; Set the GOTAG-PDL-LEVEL of each the rettag.  ;; MYGOTAGS contains the RETTAG and nothing else.  (SETF (GOTAG-PROGDESC (CAR MYGOTAGS)) (CAR PROGDESCS))  (SETF (GOTAG-PDL-LEVEL (CAR MYGOTAGS)) (+ PDLLVL NVALUES))  ;; Generate code for the body.  (IF (NULL BDY)      (P2RETURN-FROM `(,MYPROGDESC (QUOTE NIL)) 'D-IGNORE)    (DO ((TAIL BDY (CDR TAIL)))((NULL (CDR TAIL)) (P2RETURN-FROM (LIST MYPROGDESC (CAR TAIL)) 'D-IGNORE))      (P2 (CAR TAIL) 'D-IGNORE)))  ;; If this is a top-level BLOCK, we just went to D-RETURN,  ;; and nobody will use the RETTAG, so we are done.  (AND (EQ DEST 'D-RETURN)       (RETURN NIL))  ;; Otherwise, this is where RETURNs jump to.  (SETQ PDLLVL (GOTAG-PDL-LEVEL (CAR MYGOTAGS)))  (OUTTAG (GOTAG-PROG-TAG RETTAG))  ;; Store away the value if  ;; it is not supposed to be left on the stack.  (AND (NEQ DEST IDEST)       (NULL M-V-TARGET)       (MOVE-RESULT-FROM-PDL DEST))  ;; If we were supposed to produce multiple values, we did.  (SETQ M-V-TARGET NIL)))) ;; This differs from block only when DEST is D-INDS.;; In that case, this one compiles the value to the PDL,;; then moves it to D-INDS after popping off any excess pdl words;; underneath it.  BLOCK would compile the value direct to D-INDS,;; which loses if words must be popped off the stack on falling thru.;; However, that is something that cannot happen for user BLOCKs.;; It can happen only for the weird BLOCK body that WITH-STACK-LIST generates.(DEFUN (:PROPERTY BLOCK-FOR-WITH-STACK-LIST P2) (ARGL DEST)  (LET ((KEEP-CURRENT-FRAME T))    (P2BLOCK ARGL DEST NIL T))) (DEFUN (:PROPERTY BLOCK-FOR-PROG P2) (ARGL DEST)  (P2BLOCK ARGL DEST T)) ;;;  RETURN processing --;;;  pass 1 has changed all varieties of RETURN to (RETURN-FROM progdesc value);;;(DEFPROP RETURN-FROM P2RETURN-FROM P2) (DEFUN P2RETURN-FROM (ARGL IGNORE)  ;;  1/30/86 CLM - For Rel.3, modified to handle cases where there is a  ;;                return from within a CATCH or an UNWIND-PROTECT.  ;;  2/05/86 CLM - An addendum to the above modification.  This handles  ;;                returns from within the undo forms of unwind-protect's.  ;;  2/12/86 CLM - Bind pdllvl to itself upon entry.  ;;  2/12/86 DNG - Decrement PDLLVL and NPOPS by 4 for each %CLOSE-CATCH.  ;;  2/14/86 DNG - Use OUTI instead of OUTF for NCONS.  ;;  3/11/86 CLM - Added special handling for when mvtarget equals return.  ;;  5/07/86 CLM - If mvtarget equals RETURN and a single value is being  ;;                returned, push 1 on the stack to set up for a RETURN-N.  ;;  7/16/86 CLM - Use the global variable CATCH-BLOCK-SIZE.  ;;  8/28/86 CLM - Fix so that if RPDESC is null, just return from the function  ;;  9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET.  ;; 10/18/86 DNG - RETTAG is now a structure instead of a symbol.  ;; 11/17/86 CLM - Changed to handle new UNWIND-PROTECT's.  ;; 11/24/86 CLM - Fix so that a return from a block generated within the undo forms is  ;;                not treated as a return from the undo forms.  (LET ((RPDESC (FIRST ARGL))   ; prog descriptor to return from. (ARG (SECOND ARGL))   ; value to be returnedIPROGDESTMVTARGETSINGLE-VALUE-RETURNNVALUES(PDLLVL PDLLVL)(CALL-BLOCK-PDL-LEVELS CALL-BLOCK-PDL-LEVELS))    (IF (NULL RPDESC);; Only get here in case of an error which has already;;  been reported in pass 1.  Just return from the function.(SETQ IPROGDEST 'D-RETURN)      ;; Else get info for the referenced block.      (PROGN(SETQ IPROGDEST (PROGDESC-IDEST RPDESC))(SETQ MVTARGET (PROGDESC-M-V-TARGET RPDESC))))    ;; If going to throw values, things expect tag on top of stack.  So copy it to there.    (WHEN (EQ MVTARGET 'THROW)      (UNLESS (= PDLLVL (PROGDESC-PDL-LEVEL RPDESC))(P2PUSH-CONSTANT (- PDLLVL (PROGDESC-PDL-LEVEL RPDESC)))(OUTI '(MISC D-PDL PDL-WORD))(INCPDLLVL)))    ;; Compile the arg with same destination and m-v-target    ;; that the PROG we are returning from had.    ;;If there is a return from within an unwind-protect or a catch,    ;;handle it as follows.    (COND ((AND (COMPILING-FOR-V2)       (OR (AND RPDESC      (EQ IPROGDEST 'D-RETURN)      (NOT (NULL CALL-BLOCK-PDL-LEVELS))      (<= (PROGDESC-PDL-LEVEL RPDESC)  (IF (CONSP (CAR CALL-BLOCK-PDL-LEVELS))      (CAAR CALL-BLOCK-PDL-LEVELS)      (CAR CALL-BLOCK-PDL-LEVELS)))) (MEMBER MVTARGET '(RETURN RETURN-CATCH) :TEST #'EQ)  ))  (LET ((UNDO-PDL-LEVEL (PROGDESC-UNDO-PDL-LEVEL (FIRST PROGDESCS))))    ;;return-catch prevents P2LET-INTERNAL from trying to unbind    ;;special variables.    ;;    ;;new unwind-protect scheme - if within the undo forms must     ;;do an unwind-protect-cleanup before the returned form is     ;;compiled.  This requires cleaning off the stack so that    ;;the unwind-protect-cleanup works properly.    ;;UNDO-PDL-LEVEL is a list of all undo pdlplvl's processed so far.    (WHEN (AND (CONSP (CAR CALL-BLOCK-PDL-LEVELS))       (EQ (CADAR CALL-BLOCK-PDL-LEVELS) 'UNWIND-PROTECT)       (EQ (CAR (LAST (CAR CALL-BLOCK-PDL-LEVELS))) 'UNDO)       UNDO-PDL-LEVEL)(OUT-AUX 'POP-PDL (- PDLLVL     (CAR UNDO-PDL-LEVEL)))(OUT-AUX '%UNWIND-PROTECT-CLEANUP)(POP CALL-BLOCK-PDL-LEVELS)(DECF PDLLVL (- PDLLVL (CAR UNDO-PDL-LEVEL)))(POP UNDO-PDL-LEVEL))    (SETQ SINGLE-VALUE-RETURN (P2MV ARG 'D-PDL    (IF (EQ MVTARGET 'RETURN)MVTARGET 'RETURN-CATCH)))    (DO ((L CALL-BLOCK-PDL-LEVELS (CDR L)))((OR (NULL L)     (< (IF (CONSP (CAR L))    (CAAR L)    (CAR L))(PROGDESC-PDL-LEVEL RPDESC))))      ;;If within an unwind-protect,      ;;jump to the cleanup forms subr      ;;unless you're already in the cleanup forms.      ;;If you are returning completely out of the funtion,      ;;you don't have to worry about the stuff left on the      ;;stack by all the intervening %close-catch-unwind-protect's.      (IF (AND (CONSP (CAR L))       (EQ (CADAR L) 'UNWIND-PROTECT))  (UNLESS (EQ (CAR (LAST (CAR L))) 'UNDO)      (PROGN(OUT-AUX '%CLOSE-CATCH-UNWIND-PROTECT)(SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE))(OUTB `(BRANCH PUSHJ NIL NIL ,(CADDAR L)))(OUT-AUX '%UNWIND-PROTECT-CONTINUE)))  (PROGN    (OUT-AUX '%CLOSE-CATCH)    (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE))))      )    (IF (MEMBER MVTARGET '(RETURN RETURN-CATCH) :TEST #'EQ)(PROGN  (WHEN SINGLE-VALUE-RETURN;set up for an ultimate return-n(P2PUSH-CONSTANT 1))  (OUTB `(BRANCH ALWAYS NIL NIL ,(GOTAG-PROG-TAG (PROGDESC-RETTAG RPDESC)))))(PROGN  (IF SINGLE-VALUE-RETURN      ;;a single value      (OUT-AUX '(RETURN 0 PDL-POP))      ;;multiple values      (OUT-AUX 'RETURN-N))  (SETQ DROPTHRU NIL)))) )  ;;This is specifically for a return from an undo.  As above we are  ;;not concerned with items left on the stack by previous unwind-protect  ;;closes.  This means they will be left on the stack, which may present   ;;a problem.  ((AND (COMPILING-FOR-V2)(NOT (NULL CALL-BLOCK-PDL-LEVELS))(CONSP (CAR CALL-BLOCK-PDL-LEVELS))(EQ (CADAR CALL-BLOCK-PDL-LEVELS) 'UNWIND-PROTECT)(EQ (CAR (LAST (CAR CALL-BLOCK-PDL-LEVELS))) 'UNDO)(PROGDESC-UNDO-PDL-LEVEL (FIRST PROGDESCS)))   (LET* ((UNDO-PDL-LEVEL (PROGDESC-UNDO-PDL-LEVEL (FIRST PROGDESCS))) (PDLLVL-DELTA (- PDLLVL (CAR UNDO-PDL-LEVEL))))     (IF (ZEROP PDLLVL-DELTA) (OUT-AUX 'POP-PDL 1) ;haven't pushed anything on the stack but must pop the restart-macro-pc       (OUT-AUX 'POP-PDL PDLLVL-DELTA))     (OUT-AUX '%UNWIND-PROTECT-CLEANUP)     (DECF PDLLVL (IF (ZEROP PDLLVL-DELTA) 1 PDLLVL-DELTA))          (SETQ SINGLE-VALUE-RETURN (P2MV ARG IPROGDEST     MVTARGET))     (POP CALL-BLOCK-PDL-LEVELS)   ;get rid of current one          (DO ((L CALL-BLOCK-PDL-LEVELS (CDR L))) ((OR (NULL L)      (< (IF (CONSP (CAR L))     (CAAR L)     (CAR L)) (PROGDESC-PDL-LEVEL RPDESC))))       ;;if within an unwind-protect,       ;;jump to the cleanup forms subr       ;;unless you're in the cleanup forms.       (IF (AND (CONSP (CAR L))(EQ (CADAR L) 'UNWIND-PROTECT))   (UNLESS (EQ (CAR (LAST (CAR L))) 'UNDO)     (PROGN       (OUT-AUX '%CLOSE-CATCH-UNWIND-PROTECT)       (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE))       (OUTB `(BRANCH PUSHJ NIL NIL ,(CADDAR L)))       (OUT-AUX '%UNWIND-PROTECT-CONTINUE)       ))   (PROGN     (OUT-AUX '%CLOSE-CATCH)     (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE))))       (POP CALL-BLOCK-PDL-LEVELS) )     )   )     (T (SETQ SINGLE-VALUE-RETURN (P2MV ARG IPROGDEST MVTARGET))      ) )    ;; But, since a PROG has multiple returns, we can't simply    ;; pass on to the PROG's caller whether this function did or did not    ;; generate those multiple values if desired.    ;; If the function failed to, we just have to compensate here.    (AND SINGLE-VALUE-RETURN (COND   ((NUMBERP MVTARGET)    ;; If we wanted N things on the stack, we have only 1, so push N-1 NILs.    (PUSH-NILS (- MVTARGET 1)))   ((EQ MVTARGET 'MULTIPLE-VALUE-LIST)    (OUTI '(MISC D-PDL NCONS)))))    (SETQ NVALUES (COND    ((NUMBERP MVTARGET) MVTARGET)    ((EQ IPROGDEST 'D-PDL) 1)    (T 0)))    ;; Note how many things we have pushed.    (AND (EQ IPROGDEST 'D-PDL) (MKPDLLVL (+ PDLLVL NVALUES)))    ;; Jump to the prog's rettag, unless the prog is top-level (to d-return)    ;; since in that case the code just compiled will not ever drop through.    (OR (EQ IPROGDEST 'D-RETURN)(AND (COMPILING-FOR-V2)     (MEMBER MVTARGET '(RETURN RETURN-CATCH) :TEST #'EQ))(OUTBRET (PROGDESC-RETTAG RPDESC) RPDESC NVALUES))))(DEFPROP TAGBODY P2TAGBODY P2) (DEFUN P2TAGBODY (ARGL PROGDEST)  ;;  6/02/86 DNG - Bind TAGOUT to itself so that it indicates whether we  ;;are currently within a loop.  ;; 10/18/86 DNG - Now need to look up tag in MYGOTAGS before calling GTAG.  ;;Don't need GOTAGS anymore.  (LET* ((MYGOTAGS (CAR ARGL)) (BODY (CDR ARGL)) (TAGOUT TAGOUT) (MYPROGDESC (GOTAG-PROGDESC (CAR MYGOTAGS))) (PROGDESCS PROGDESCS)) ;; Remember this TAGBODY's general environment. ;; We supply as the supposed block name ;; a list that will not appear as the block name in any RETURN-FROM. ;; So we can have an entry on the PROGDESCS list to record our tags' pdllvl ;; without interfering with RETURN-FROM.    (WHEN MYGOTAGS      (SETF (PROGDESC-PDL-LEVEL MYPROGDESC) PDLLVL)      (PUSH MYPROGDESC PROGDESCS)      ;; Set the GOTAG-PDL-LEVEL of each of the tags.      (DOLIST (GOTAG MYGOTAGS)(SETF (GOTAG-PDL-LEVEL GOTAG) PDLLVL)))    (DOLIST (STMT BODY)      (COND((ATOM STMT) (UNLESS DROPTHRU (OUTF '(NO-DROP-THROUGH))) (SETQ TAGOUT (SETQ DROPTHRU T)) (OUTF (GTAG (ASSOC STMT MYGOTAGS :TEST #'EQUAL))))(T (P2 STMT 'D-IGNORE))))    (P2 '(QUOTE NIL) PROGDEST))) (DEFPROP GO P2GO P2) (DEFUN P2GO (ARGL IGNORE)  ;;  2/12/86 CLM - Bind pdllvl to itself upon entry.  ;; 10/18/86 DNG - Error checking is now done in pass 1.  (LET ((PDLLVL PDLLVL))    (OUTB1 (CAR ARGL))))(DEFUN (:PROPERTY GO-HACK P2) (ARGL IGNORE)  (OUTB `(BRANCH ALWAYS NIL NIL ,(GOTAG-LAP-TAG (CAR ARGL))))) (DEFUN (:PROPERTY *CATCH P2) (ARGL DEST)  ;;10/22/85  -  CLM  CONVERT CATCHES FROM MISC-OPS TO AUX-OPS.  ;;10/30/85  -  CLM  CHANGED FOR REL.3 TO PREVENT CATCH TAG BEING PUSHED   ;;                  AFTER THE %OPEN-CATCH(-MULTIPLE-VALUE) IS GENERATED.  ;;12/05/85  -  CLM  FOR REL.3 REMOVED ALL REFERENCES TO THE OLD ADI-LIST;  ;;                  NOW HANDLES CASES WHERE M-V-TARGET EQUALS 'THROW, 'RETURN  ;;                  AND 'MULTIPLE-VALUE-LIST OR DEST EQUALS 'D-RETURN.  ;;12/05/85  -  CLM  Modified for Rel.3 - setting the DROPTHRU flag and the PDLLVL.  ;; 2/11/86  -  CLM  Changed to not increment PDLLVL by four for a catch block.  This was  ;;                  causing POPPDL to pop too many words.  ;; 2/12/86  -  CLM  Modified last change to do the same thing in another function.  ;;                  This will solve the problem of too many close-catches being generated.  ;; 2/14/86  -  CLM  Fix to prevent extra push-constant being generated.  ;; 4/21/86  -  CLM  If DEST equals D-IGNORE then instead of an %open-catch  ;;                  generate an %open-catch-multiple-value instruction with  ;;                  an argument of 0 to indicate no values are expected.  ;; 5/07/86  -  CLM  The catch block is now 5 words long.  ;; 5/21/86  -  CLM  When compiling for Rel. 2, a catch within a multiple-value-list  ;;                  form was not being closed upon normal exit (i.e., no throw).  ;;                  This caused a problem when the multiple-value-list form was   ;;                  within an unwind-protect.  This is a fix for SPR 2257.  ;; 5/29/86  -  CLM  Use the constant CATCH-BLOCK-SIZE instead of a number.  ;; 6/06/86  -  CLM  Fixes the fix for SPR 2257.  Also, with an M-V-TARGET of   ;;                  MULTIPLE-VALUE-LIST and a form that returns a single value,  ;;                  ncons the value to create a list; previously only the value  ;;                  was returned, not a list containing the value.  ;; 6/20/86  -  CLM  Add special handling for an M-V-TARGET of MULTIPLE-VALUE-LIST to  ;;                  ensure that a single value will be returned as a list.  ;; 7/15/86  -  CLM  Add more special handling for cases where multiple-values are  ;;                  expected, but only a single value is generated.  ;; 7/16/86  -  CLM  A continuation of the previous fix.  This handles cases where  ;;                  a definite number of values is expected and there is a throw.  ;;                  Let the throw microcode handle cases where the number of values  ;;                  returned is less than expected.  ;; 9/05/86  -  CLM  Introduce a new value for M-V-TARGET: RETURN-CATCH.  This is used  ;;                  when DEST is D-RETURN, and its purpose is to prevent a possible  ;;                  attempt by P2LET-INTERNAL to unbind special variables,  ;;                  which in this situation, would result in an error.    (LET (TDEST  ;TDEST IS DESTINATION ACTUALLY TO BE COMPILED INTO CALL INSTRUCTION.(INITIAL-PDLLVL PDLLVL)RESTART-PCADI-LIST(CALL-BLOCK-PDL-LEVELS CALL-BLOCK-PDL-LEVELS)(WITHIN-CATCH T)SINGLE-VALUE-RETURN)    (UNLESS (COMPILING-FOR-V2)      (COND((NULL M-V-TARGET) (IF (EQ DEST 'D-IGNORE)     (SETQ TDEST 'D-IGNORE)   (IF (AND (EQ DEST 'D-RETURN)    (NOT GENERATING-MICRO-COMPILER-INPUT-P))       (SETQ TDEST 'D-RETURN)     (SETQ TDEST 'D-PDL))))((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST) (SETQ ADI-LIST (CONS M-V-TARGET (CONS NIL ADI-LIST))) (SETQ TDEST 'D-IGNORE))((EQ M-V-TARGET 'THROW) (SETQ ADI-LIST `(MULTIPLE-VALUE (QUOTE-VECTOR (QUOTE NIL)) ,@ADI-LIST)       TDEST 'D-PDL))((EQ M-V-TARGET 'RETURN) (SETQ ADI-LIST `(MULTIPLE-VALUE (QUOTE-VECTOR 'T) ,@ADI-LIST)       TDEST 'D-PDL))((NUMBERP M-V-TARGET) ;; M-V-TARGET IS A NUMBER => IT IS NUMBER OF VALUES, ;; JUST LEAVE THEM ON THE STACK. (SETQ ADI-LIST `(MULTIPLE-VALUE (QUOTE-VECTOR ',M-V-TARGET) ,@ADI-LIST)       TDEST 'D-IGNORE)))      (SETQ ADI-LIST    (LIST* 'RESTART-PC   `(QUOTE-VECTOR (TAG ,(SETQ RESTART-PC (GENSYM))))   'BIND-STACK-LEVEL NIL ADI-LIST)))    ;;CHANGE MADE 10/22/85 BY CLM    ;;CHANGE MADE 12/05/85 BY CLM    (IF (COMPILING-FOR-V2)(PROGN  ;;EMIT THE CATCH-TAG, THE RESTART-PC, AND IF A MV CATCH, THE NUMBER OF VALUES  (P2 (CAR ARGL)      (IF GENERATING-MICRO-COMPILER-INPUT-P  'D-NEXT'D-PDL))  (OUTI1 (LIST 'MOVE 'D-PDL `(QUOTE-VECTOR (TAG ,(SETQ RESTART-PC (GENSYM))))))   ;RESTART-PC  (COND    ((EQ DEST 'D-RETURN)     (P2PUSH-CONSTANT NIL)     (OUTF '(AUX %OPEN-CATCH-MULTIPLE-VALUE)))    ((EQ DEST 'D-IGNORE)     (P2PUSH-CONSTANT 0)     (OUT-AUX '%OPEN-CATCH-MULTIPLE-VALUE))    ((NULL M-V-TARGET) (OUTF '(AUX %OPEN-CATCH)))    ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST)     (OUTF '(AUX %OPEN-CATCH-MV-LIST)))    ((OR (EQ M-V-TARGET 'THROW) (EQ M-V-TARGET 'RETURN) (EQ M-V-TARGET 'RETURN-CATCH))     (P2PUSH-CONSTANT NIL)     (OUTF '(AUX %OPEN-CATCH-MULTIPLE-VALUE)))    ((NUMBERP M-V-TARGET)     (P2PUSH-CONSTANT M-V-TARGET)     (OUTF '(AUX %OPEN-CATCH-MULTIPLE-VALUE)))))      (OUTI1 (LIST 'ADI-CALL 'CALL TDEST '(QUOTE-VECTOR (FUNCTION *CATCH)) ADI-LIST)))    (UNLESS (COMPILING-FOR-V2)      (MKPDLLVL (+ PDLLVL (LENGTH ADI-LIST))))    ;;this may need to be redone elsewhere further down    (UNLESS (COMPILING-FOR-V2)      (COND((NULL M-V-TARGET))((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST) (INCPDLLVL))((NUMBERP M-V-TARGET) (MKPDLLVL (+ PDLLVL M-V-TARGET)))))    (PUSH PDLLVL CALL-BLOCK-PDL-LEVELS)    (MKPDLLVL (+ PDLLVL (IF (COMPILING-FOR-V2) CATCH-BLOCK-SIZE 4)))     ;;ADDED 10/30/85 BY CLM TO PREVENT CATCH TAG BEING    ;;PUSHED AFTER THE %OPEN-CATCH IS GENERATED    (UNLESS (COMPILING-FOR-V2)      (P2 (CAR ARGL) (IF GENERATING-MICRO-COMPILER-INPUT-P 'D-NEXT       'D-PDL))      (INCPDLLVL))    (IF (COMPILING-FOR-V2)(COND  ((EQ DEST 'D-RETURN)   (SETQ SINGLE-VALUE-RETURN (P2MV (CADR ARGL) 'D-PDL 'RETURN-CATCH)))  ((NULL M-V-TARGET)   (P2 (CADR ARGL) (IF (EQ DEST 'D-IGNORE)       DEST     'D-PDL)))  ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST)   (WHEN     (P2MV (CADR ARGL) 'D-PDL M-V-TARGET)     (OUTM '(MISC D-PDL NCONS)) )    ;must convert a single value into a list   )  ((NUMBERP M-V-TARGET)   (SETQ SINGLE-VALUE-RETURN   (P2MV (CADR ARGL) (IF (EQ DEST 'D-IGNORE) DEST 'D-PDL) M-V-TARGET))   (WHEN (AND SINGLE-VALUE-RETURN      (NULL DROPTHRU))    ;there has been a throw     (SETQ SINGLE-VALUE-RETURN NIL)))  (T (SETQ SINGLE-VALUE-RETURN   (P2MV (CADR ARGL) (IF (EQ DEST 'D-IGNORE) DEST 'D-PDL) M-V-TARGET))) )      (COND((EQ DEST 'D-RETURN) (P2 (CADR ARGL) 'D-RETURN))((NULL M-V-TARGET) (P2 (CADR ARGL) 'D-LAST))((EQ M-V-TARGET 'THROW) (P2PUSH-CONSTANT (- PDLLVL INITIAL-PDLLVL)) (OUTM '(MISC D-PDL PDL-WORD)) (UNLESS (P2MV (CADR ARGL) 'D-PDL M-V-TARGET)   (POPPDL 1 (- PDLLVL INITIAL-PDLLVL -1))   (SETQ M-V-TARGET NIL)));;6/06/86 - this fixes the fix for SPR 2257((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST)   (WHEN     (P2MV (CADR ARGL) 'D-PDL M-V-TARGET)     (OUTM '(MISC D-PDL NCONS)) )    ;must convert a single value into a list   (SETQ M-V-TARGET NIL)   (POPPDL 1 (- PDLLVL INITIAL-PDLLVL))   )(T (UNLESS (P2MV (CADR ARGL) 'D-PDL M-V-TARGET)   (POPPDL (IF (NUMBERP M-V-TARGET) M-V-TARGET 1)   (- PDLLVL INITIAL-PDLLVL))   (SETQ M-V-TARGET NIL)))))    ;;for those cases where the body of the catch has    ;;produced only a single value    (WHEN SINGLE-VALUE-RETURN      (IF (NUMBERP M-V-TARGET)  (DOTIMES (I (1- M-V-TARGET))        (P2PUSH-CONSTANT (QUOTE NIL))      (INCPDLLVL))(P2PUSH-CONSTANT 1)))    (UNLESS (AND (NOT (COMPILING-FOR-V2)) (EQ DEST 'D-RETURN))      (SETQ DROPTHRU T))    (OUTF (LIST 'RESTART-TAG RESTART-PC))    ;;CHANGE MADE 10/22/85 BY CLM    ;;CHANGE MADE 12/05/85 BY CLM    (WHEN (COMPILING-FOR-V2)      (IF (EQ DEST 'D-RETURN)  (PROGN    (OUTI '(AUX %CLOSE-CATCH))    (OUT-AUX 'RETURN-N)    (SETQ PDLLVL INITIAL-PDLLVL))(PROGN  (OUTI (LIST 'AUX '%CLOSE-CATCH))    (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE)))))    (WHEN (PROG1    (NULL M-V-TARGET)    (SETQ M-V-TARGET NIL))      (UNLESS (IF (COMPILING-FOR-V2)  (MEMBER DEST '(D-RETURN D-PDL D-IGNORE) :TEST #'EQ)(OR (MEMBER DEST '(D-PDL D-IGNORE) :TEST #'EQ)    (AND (EQ DEST 'D-RETURN) (EQ TDEST 'D-RETURN))))(MOVE-RESULT-FROM-PDL DEST)(WHEN (COMPILING-FOR-V2)  (SETQ PDLLVL (1- PDLLVL)))))  ));Bind a list of variables, computing initializations and binding sequentially.;VARS are the VARS outside of this binding environment.;NEWVARS are the VARS inside of it, starting with the variables in X in reverse order,;except there may be additional entries for optional-specified-flags; each one;will be on NEWVARS just before its corresponding main variable.;We have to install these variables one at a time as we go, using successive tails.(DEFUN P2SBIND (X NEWVARS VARS)  (LET ((NBINDS 0)   ;Number of (internal-aux) special bindings(NNEWVARS (LOOP FOR L ON NEWVARS UNTIL (EQ L VARS) COUNT T)))    (DO ((X X (CDR X)) (HOME))((NULL X))      (LOOP DO (SETQ HOME (NTH (SETQ NNEWVARS (1- NNEWVARS)) NEWVARS))    UNTIL (NEQ (VAR-KIND HOME) 'FEF-ARG-DELETED))      (AND (P2LMB (CAR X) HOME) (SETQ NBINDS (1+ NBINDS)))      ;; Set VARS to the tail of NEWVARS starting at the variable we just handled      ;; or its optional-specified-flag.      (AND (CDDR (VAR-INIT HOME)) (SETQ NNEWVARS (1- NNEWVARS)))      (SETQ VARS (NTHCDR NNEWVARS NEWVARS)))    (OR (ZEROP NNEWVARS)(EQ (VAR-KIND (FIRST NEWVARS)) 'FEF-ARG-DELETED)(BARF X "VARS screwed up by this binding" 'BARF))    NBINDS)) ;Output code for binding the var VARNAME as specified in its HOME.;Return T if a BIND-POP or BIND-NIL instruction was output.(DEFUN P2LMB (VARNAME HOME) ;;  8/22/85 - Support BIND-CURRENT instruction; set KEEP-CURRENT-FRAME ;;            flag when a special variable is bound. ;; 10/30/85 - Change name BINDNIL to BIND-NIL and BINDPOP to BIND-POP; ;;            implement use of BIND-T. ;; 12/07/85 - For release 3, FEF-ARG-AUX special variables are not bound on ;;            function entry; delete references to FEF-REMOTE.  (LET (INTCODEINITFORM KIND)    (BLOCK NIL      (UNLESS (ATOM VARNAME)(SETQ INITFORM (CADR VARNAME))(SETQ VARNAME (CAR VARNAME)))      (UNLESS (EQ (VAR-NAME HOME) VARNAME)(BARF VARNAME "wrong home in P2LMB" 'BARF))      (SETQ INTCODE (VAR-INIT HOME))      ;; If this variable's binding is fully taken care of by function entry,      ;; we have nothing to do here.      (UNLESS (MEMBER (CAR INTCODE) '(FEF-INI-OPT-SA FEF-INI-COMP-C) :TEST #'EQ)(RETURN NIL))      ;; Detect and handle internal special bound variables.      (SETQ KIND (VAR-KIND HOME))      (WHEN (AND (EQ (VAR-TYPE HOME) 'FEF-SPECIAL) (OR (EQ KIND 'FEF-ARG-INTERNAL-AUX)     (COMPILING-FOR-V2)));; Output BIND-NIL, or push value and BIND-POP.(COND  ((MEMBER INITFORM '(NIL (QUOTE NIL)) :TEST #'EQUAL)   (OUTIV 'BIND-NIL HOME))  ((AND (EQ INITFORM VARNAME)   ; bind to itself(INSTRUCTION-EXISTS-P 'BIND-CURRENT))   (OUTIV 'BIND-CURRENT HOME))  ((AND (EQUAL INITFORM ''T)(INSTRUCTION-EXISTS-P 'BIND-T))   (OUTIV 'BIND-T HOME))  (T (P2PUSH INITFORM)     (OUTIV 'BIND-POP HOME)))(SETQ KEEP-CURRENT-FRAME T)(RETURN T))      ;; If variable deleted by function LET-OPT, do nothing.      (WHEN (EQ KIND 'FEF-ARG-DELETED)(RETURN NIL))      ;; Otherwise, it's an internal local variable,      ;; or else a special variable already bound by entering the function.      ;; Don't bind, just init.      (COND((MEMBER INITFORM '(NIL (QUOTE NIL)) :TEST #'EQUAL) ;; if initting to NIL, then if no tags output so far (TAGOUT is NIL) ;; we can assume it is still NIL from function entry time. (WHEN (OR TAGOUT   (EQ (VAR-TYPE HOME) 'FEF-SPECIAL)   (VAR-OVERLAP-VAR HOME))   (OUTIV 'SET-NIL HOME)));; If explicitly says value does not matter, do nothing to initialize.((OR (EQUAL INITFORM '(UNDEFINED-VALUE))     #+compiler:debug ; temporary while COMPILER2 package is being used.    (EQUAL INITFORM '(COMPILER:UNDEFINED-VALUE))) NIL)((EQUAL INITFORM ''0) (OUTIV 'SET-ZERO HOME))(T (P2PUSH INITFORM)   ;;IF &OPTIONAL AND FOR MICRO-COMPILER, JUST LEAVE VARIABLE ON STACK. (IF (AND GENERATING-MICRO-COMPILER-INPUT-P  (EQ (CAR INTCODE) 'FEF-INI-OPT-SA))     NIL   (OUTIV 'POP HOME))))      ;; If there is a specified-flag variable, it was bound to T at entry.      ;; Set it to NIL here (ie, if the arg was NOT specified).      (WHEN (CDDR INTCODE)(OUTIV 'SET-NIL (CDDR INTCODE)))      (WHEN (EQ (CAR INTCODE) 'FEF-INI-OPT-SA)(SETF (GET (CADR INTCODE) 'PEEP-KEEP) T)(OUTF (CADR INTCODE)))      (RETURN NIL)))) (DEFUN OUTIV (INST VARAB &OPTIONAL ADR)  ;; 10/18/86 DNG - Modified to handle initialization of higher-context lexical  ;;variables; this is needed when EXTEND-LOCAL-VARIABLES has split the FEF.  (DECLARE (UNSPECIAL ADR))  (WHEN (NULL ADR)    (SETQ ADR (VAR-LAP-ADDRESS VARAB)))  (IF (AND (CONSP ADR)   (EQ (FIRST ADR) 'LEXICAL-REF)   (ATOM (SETQ ADR (LEX-REF-ADDRESS ADR))))      (PROGN(UNLESS (EQ INST 'POP)  (OUTI (LIST INST 0 'PDL-PUSH)))(P2PUSH-CONSTANT ADR)(NEEDPDL 1)(OUT-AUX 'STORE-IN-HIGHER-CONTEXT))    (OUTI (LIST INST 0 ADR))))#| old(DEFUN OUTIV (INST VARAB)  (OUTI (LIST INST 0 (VAR-LAP-ADDRESS VARAB)))) |#;Bind a list of variables "in parallel":  compute all values, then bind them all.;Return the number of special bindings made (BIND-POP and BIND-NIL instructions).;Note: an attempt to bind NIL is ignored at this level.;Note: if several variables have init forms of (%pop),;they are popped off the pdl LAST ONE FIRST!;The "correct" thing would be to pop the first one first,;but this would require another stack to keep them on to reverse them.(DEFUN P2PBIND (VARNAMES NEWVARS)  ;;  8/23/85 - Set KEEP-CURRENT-FRAME flag when a special variable is bound.  ;; 10/30/85 - Change instruction BINDNIL to BIND-NIL and BINDPOP to BIND-POP.  ;; 12/07/85 - For release 3, FEF-ARG-AUX special variable is not bound on function entry.  (LET ((PDLLVL PDLLVL))    (PROG (VARNAME HOME INTCODE INITFORM NBINDS)  (OR VARNAMES (RETURN 0))  (SETQ VARNAME (CAR VARNAMES)VARNAMES (CDR VARNAMES))  (UNLESS (ATOM VARNAME)    (SETQ INITFORM (CADR VARNAME))    (SETQ VARNAME (CAR VARNAME)))  ;; If trying to bind NIL, just discard the value to bind it to.  (WHEN (NULL VARNAME)    (P2 INITFORM 'D-PDL)    (RETURN (PROG1      (P2PBIND VARNAMES NEWVARS)      (OUTF '(MOVE D-IGNORE PDL-POP)))))  (WHEN (NULL (SETQ HOME (LOOKUP-VAR VARNAME NEWVARS)))    (BARF VARNAME 'NOT-ON-VARS 'BARF))  (SETQ INTCODE (VAR-INIT HOME))  ;; If this variable's binding is fully taken care of by function entry,  ;; we have nothing to do here.  (WHEN (AND (NOT (MEMBER (VAR-KIND HOME) '(FEF-ARG-INTERNAL-AUX FEF-ARG-KEY) :TEST #'EQ))     (NOT (MEMBER (CAR INTCODE) '(FEF-INI-OPT-SA FEF-INI-COMP-C) :TEST #'EQ)))    (RETURN (P2PBIND VARNAMES NEWVARS)))  ;; Detect and handle internal special bound variables.  (WHEN (AND (EQ (VAR-TYPE HOME) 'FEF-SPECIAL)     (OR (EQ (VAR-KIND HOME) 'FEF-ARG-INTERNAL-AUX) (COMPILING-FOR-V2)))    (COND      ((MEMBER INITFORM '(NIL (QUOTE NIL)) :TEST #'EQUAL)       (SETQ NBINDS (P2PBIND VARNAMES NEWVARS))       (OUTIV 'BIND-NIL HOME))      (T (P2PUSH INITFORM) (INCPDLLVL) (SETQ NBINDS (P2PBIND VARNAMES NEWVARS)) (OUTIV 'BIND-POP HOME)))    (SETQ KEEP-CURRENT-FRAME T)    (RETURN (1+ NBINDS)))  (COND    ((OR (EQUAL INITFORM '(UNDEFINED-VALUE)) #+compiler:debug ;temporary while COMPILER2 package is used (EQUAL INITFORM '(COMPILER:UNDEFINED-VALUE)))     (SETQ NBINDS (P2PBIND VARNAMES NEWVARS)))    ((MEMBER INITFORM '(NIL (QUOTE NIL)) :TEST #'EQUAL)     (SETQ NBINDS (P2PBIND VARNAMES NEWVARS))     (WHEN (OR TAGOUT       (EQ (VAR-TYPE HOME) 'FEF-SPECIAL)       (VAR-OVERLAP-VAR HOME))       (OUTIV 'SET-NIL HOME)))    ;; Special vars bound at function entry and wanting to be    ;; initted to themselves, need not be set at all.    ((AND (EQ (VAR-TYPE HOME) 'FEF-SPECIAL)  (EQ INITFORM VARNAME))     (SETQ NBINDS (P2PBIND VARNAMES NEWVARS)))    (T (P2PUSH INITFORM)       (INCPDLLVL)       (SETQ NBINDS (P2PBIND VARNAMES NEWVARS))       ;IF FOR MICRO-COMPILER AND IS OPTIONAL ARG, JUST LEAVE VARIABLE ON STACK.       (IF (AND GENERATING-MICRO-COMPILER-INPUT-P(MEMBER 'FEF-INI-OPT-SA INTCODE :TEST #'EQ))   NIL (OUTIV 'POP HOME))))  (WHEN (EQ (CAR INTCODE) 'FEF-INI-OPT-SA)    (SETF (GET (CADR INTCODE) 'PEEP-KEEP) T)    (OUTF (CADR INTCODE)))  (RETURN NBINDS)))) ;Compile code to test CONDITION and jump to tag if it is NIL;(for SENSE = TRUE) or if it is non-NIL (for SENSE = FALSE).(DEFUN BOOL1 (CONDITION SENSE TAG)  (P2BRANCH CONDITION 'D-INDS    `(BRANCH NULL ,SENSE NIL ,TAG))) ;Like P2, but also supply a "branch destination".;The branch destination (BDEST) is just a branch instruction which;could simple-mindedly be compiled right after (P2 FORM DEST),;but some forms can optimize the code produced by incorporating;the branch destination into their code.  Such forms can say that;outputting the branch at the end is superfluous by setting BDEST to NIL.;Forms which perform unconditional transfers need not worry about BDEST;since it will be output and then discarded as unreachable.;An unconditional branch destination can accompany any value of DEST.;A conditional branch should only be used with DEST = D-INDS.;This is taken to imply that the indicators are used by the branch,;not that the indicators will be correctly set up after the optimized;code is finished branching or not.  If you wish to compile something;and want the indicators correctly set up according to its value,;you should use D-INDS with no BDEST, and do your branching yourself.;Branches which pop the pdl may not be used as branch destinations.;Most people who look at BDEST don't check for them,;and the optimizations that BDEST is used for wouldn't work for them anyway.;A funny kind of branch that can be used as a destination is;(BRANCH ALWAYS NO-OP NIL tag).  It is a sort of unconditional branch,;used when the tag to be branched to is known to be right after;this expression, so that one might think that no branch is needed at all.;When OUTB is called on such a branch, it does nothing.;But some functions (such as AND and OR) can optimize these no-op branches;like any other unconditional branches.;An even funnier kind of branch destination is the return branch:;(BRANCH ALWAYS RETURN NIL tag).  This is given as the branch destination;to the last statement in a PROG, so that if the statement is a RETURN;then the implicit (RETURN NIL) at the end of the PROG can be omitted;and the RETURN at the end can just drop through to the PROG's rettag.;Return branch destinations may not be passed along to subexpressions;by AND, OR and COND.(DEFUN P2BRANCH (FORM DEST BDEST)  (AND (MEMBER DEST '(D-PDL D-NEXT) :TEST #'EQ)       (NEEDPDL 1))  (COND    ((AND BDEST (NEQ (CADR BDEST) 'ALWAYS)  (NEQ DEST 'D-INDS))     (BARF `(,DEST . ,BDEST) "BDEST is conditional and DEST is not D-INDS" 'BARF))    ;; We can optimize things like (AND 'T (GO FOO)) and (AND 'NIL (GO FOO))    ;; into an unconditional jump or into nothing at all.    ((AND (EQ (CADR BDEST) 'NULL)  (NULL (CADDDR BDEST))  (NOT (ATOM FORM))  (EQ (CAR FORM) 'QUOTE))     (AND (EQ (NULL (CADR FORM))      (EQ (CADDR BDEST) 'TRUE))  (OUTB `(BRANCH ALWAYS NIL ,@(COPY-LIST (CDDDR BDEST)))))     (SETQ BDEST NIL))    ((ADRREFP FORM)     (OR (EQ DEST 'D-IGNORE) (OUTI `(MOVE ,DEST ,(P2-SOURCE FORM DEST)))))    ((EQ (CAR FORM) 'LEXICAL-REF)     (P2 FORM DEST))    ((MEMBER (CAR FORM) '(%POP) :TEST #'EQ)     (P2 FORM DEST))    (T (LET (M-V-TARGET) (P2F FORM DEST))))  (AND BDEST (OUTB (COPY-LIST BDEST)))) #| -- this is now handled in P2F(DEFPROP ATOM P2ATOM P2) ;A call to ATOM which is then tested by a branch-if-non-nil, etc.,;can be turned into just a branch-if-atom, etc.(DEFUN P2ATOM (ARGL DEST)  (COND    ((EQ (CADR BDEST) 'NULL)     (LET ((SENSE (CADDR BDEST)))       (SETQ SENSE (OTHER SENSE))       (P2BRANCH (CAR ARGL) DEST `(BRANCH ATOM ,SENSE ,@(CDDDR BDEST))))     (SETQ BDEST NIL))    (T (P2MISC P2FN ARGL DEST 1))))  |#;NOT compiles into a misc insn normally,;but with a branch destination, it optimizes away by inverting the condition.(DEFPROP NOT P2NOT P2) (DEFUN P2NOT (ARGL DEST)  ;;  8/17/85 - For release 3, special handling of D-RETURN; allow branch  ;;            conditions other than ATOM and NULL.  ;;  9/19/85 - Use AUX RETURN-NOT-PDL-POP and PUSH-NOT instructions.  ;;  9/26/85 - Use NOT-INDICATORS instruction.  ;;  8/28/86 CLM - the call to P2ARGC no longer requires a DESC arg; just pass nil  (COND    ((/= (LENGTH ARGL) 1)     ;; Wrong number of arguments; generate call so user gets error when executed.     (P2ARGC NIL ARGL nil DEST P2FN))    ((AND BDEST (GET (CADR BDEST) 'DEF-BRANCH-OP))     (LET ((SENSE (OTHER (CADDR BDEST))))       (P2BRANCH (CAR ARGL) DEST `(BRANCH ,(CADR BDEST) ,SENSE ,@(CDDDR BDEST))))     (SETQ BDEST NIL)) #| ((AND (EQ DEST 'D-RETURN)      (COMPILING-FOR-V2)      (ADRREFP (FIRST ARGL))) (P2PUSH (FIRST ARGL)) (OUTI '(AUX RETURN-NOT-PDL-POP)) (SETQ DROPTHRU NIL) (comment ; use this if RETURN-NOT-PDL-POP is not supported.   (P2MISC P2FN ARGL 'D-PDL 1)   (MOVE-RESULT-FROM-PDL DEST)) ) |#    ((AND (COMPILING-FOR-V2)  (INSTRUCTION-EXISTS-P 'PUSH-NOT))     (LET ((ADR (P2-SOURCE (FIRST ARGL) 'D-PDL)))       (IF (EQ ADR 'PDL-POP)   (IF (EQ DEST 'D-RETURN)       (PROGN (OUTI '(AUX RETURN-NOT-PDL-POP)) (SETQ DROPTHRU NIL))     (OUTM `(MISC ,DEST ,(MISC-LAP-CODE 'NOT)))) (IF (EQ DEST 'D-PDL)     (OUTI `(PUSH-NOT 0 ,ADR))   (IF (EQ DEST 'D-RETURN)       (PROGN (OUTI `(PUSH-NOT 0 ,ADR)) (MOVE-RESULT-FROM-PDL DEST))     (P2MISC P2FN ARGL DEST 1))))))    ((MISC-LAP-CODE 'NOT-INDICATORS)     (P2 (FIRST ARGL) 'D-INDS)     (IF (EQ DEST 'D-RETURN) (OUT-AUX 'RETURN-NOT-INDS)       (OUTM `(MISC ,DEST ,(MISC-LAP-CODE 'NOT-INDICATORS)))))    (T (P2MISC P2FN ARGL DEST 1)))) (DEFUN OTHER (SENSE)  (COND    ((EQ SENSE 'TRUE) 'FALSE)    ((EQ SENSE 'FALSE) 'TRUE)    (T (BARF SENSE 'OTHER 'BARF)))) (DEFPROP AND P2ANDOR P2) (DEFPROP OR P2ANDOR P2) (DEFUN P2ANDOR (ARGL DEST)  ;;  4/10/85 DNG - Don't delete constant last argument unless the value is not used. [bug 1561]  ;;  8/04/86 CLM - Handle cases where multiple values are expected but only a single value is  ;;                returned - when M-V-TARGET is RETURN or THROW.  (PROG (TAG UNCONDITIONAL IDEST SENSE TAG1)(SETQ SENSE (IF (MEMBER P2FN '(AND :AND) :TEST #'EQ)'TRUE      'FALSE))(WHEN (MEMBER DEST '(D-INDS D-IGNORE) :TEST #'EQ)  (DO ()      ((NOT (EQUAL (CAR (LAST ARGL))   (IF (EQ SENSE 'TRUE)       ''T     '(QUOTE NIL)))))    (SETQ ARGL (BUTLAST ARGL))))(SETQ IDEST 'D-PDL);; RETURN branches can't be passed in to the last thing in an AND.(AND (EQ (CADR BDEST) 'ALWAYS)     (EQ (CADDR BDEST) 'RETURN)     (SETQ BDEST NIL));; Any non-null constant as arg in an AND is ignorable unless it is last.;; NIL as arg in an OR is always ignorable.(SETQ ARGL      (COND((EQ SENSE 'FALSE) (DELETE '(QUOTE NIL) (THE LIST ARGL) :TEST #'EQUAL))((NULL ARGL) ARGL)(T (NREVERSE   (CONS (CAR (LAST ARGL)) (DELETE NIL (THE LIST (CDR (NREVERSE ARGL))) :TEST #'(LAMBDA (IGNORE X)   (AND (NOT (ATOM X))(EQ (CAR X) 'QUOTE)(CADR X)))) ))) ) )(OR ARGL (RETURN (PROG1   (P2BRANCH `',(EQ SENSE 'TRUE) DEST BDEST)   (SETQ BDEST nil))));; If we are going to jump somewhere unconditionally after the AND,;; things which are NIL might as well jump conditionally straight there.;; But this only works if the value of the AND will be in the right place then.(COND  ((AND (EQ (CADR BDEST) 'ALWAYS)(NULL M-V-TARGET)(MEMBER DEST '(D-PDL D-INDS D-IGNORE) :TEST #'EQUAL))   (SETQ UNCONDITIONAL T)   (SETQ TAG (CAR (CDDDDR BDEST))))  (T (SETQ TAG (GENSYM))))(COND  ((AND (NULL M-V-TARGET) (EQ DEST 'D-IGNORE))   ;; Compilation strategy for AND for effect:   ;; compute each arg, using it only to jump to end if it's NIL.   ;; The last one we just ignore, but we feed it our BDEST for   ;; branch tensioning.  However, (AND form (GO tag)) can be optimized   ;; by making it a conditional jump to tag rather than a jump around a jump.   (DO ((ARGL ARGL (CDR ARGL)))       ((NULL (CDR ARGL))(P2BRANCH (CAR ARGL) DEST BDEST))     (AND (SIMPLEGOP (CADR ARGL))  (RETURN (BOOL1 (CAR ARGL) (OTHER SENSE) (GTAG (CADADR ARGL)))))     ;; If the next arg of this AND is NIL, this arg is effectively last.     ;; However, if AND has a branch destination, it must compute     ;; whether to branch based on the NIL, not on this arg.     (AND (NOT (ATOM (CADR ARGL)))  (EQ (CAADR ARGL) 'QUOTE)  (EQ (NULL (CADADR ARGL))      (EQ SENSE 'TRUE))  (RETURN (P2BRANCH (CAR ARGL) DEST BDEST)))     (BOOL1 (CAR ARGL) SENSE TAG)))  ((AND (NULL M-V-TARGET) (EQ (CADR BDEST) 'NULL))   ;; Compilation strategy for AND followed by jump if NIL:   ;; jump compute each value and jump THERE rather than to end if NIL.   ;; Compilation strategy for AND followed by jump if not NIL:   ;; put that jump if not NIL after the last thing in the AND   ;; and go to after that if anything else fails to be non-NIL.   (IF (EQ SENSE (CADDR BDEST))       (DO ((ARGL ARGL (CDR ARGL)))   ((NULL ARGL)) (P2BRANCH (CAR ARGL) DEST BDEST))     (DO ((ARGL ARGL (CDR ARGL))) ((NULL (CDR ARGL))  (P2BRANCH (CAR ARGL) DEST BDEST))       ;; If the next arg of this AND is NIL, this arg is effectively last.       ;; Also, BDEST can be flushed since it says branch if       ;; not NIL and we now know the value of the AND is always NIL.       (AND (NOT (ATOM (CADR ARGL)))    (EQ (CAADR ARGL) 'QUOTE)    (EQ (NULL (CADADR ARGL))(EQ SENSE 'TRUE))    (RETURN (P2 (CAR ARGL) DEST)))       (BOOL1 (CAR ARGL) SENSE TAG)))   (SETQ BDEST NIL))  (T   ;; Compilation strategy for AND for value   ;; (correct indicators required counts as for value):   ;; compile each arg, jumping to end if NIL.   ;; Compile them to indicators, or to pdl and pop if NIL.   ;; If compiling to indicators (no pushing), we can optimize   ;; (AND form (GO tag)) just as when we are ignoring the value.   (AND (EQ DEST 'D-INDS) (SETQ IDEST 'D-INDS))      ;; AND for multiple values is like AND for value on the stack,   ;; except that we can pass the M-V-TARGET along to the last form.   ;; Also, after the "end" where the failure branches branch to   ;; we put code to push N-1 extra NILs, or whatever.   ;; The code for the last form jumps around that, to the tag TAG1.   (AND M-V-TARGET (SETQ IDEST 'D-PDL))   (DO ((ARGL ARGL (CDR ARGL))(BRANCH `(BRANCH NULL ,SENSE ,(NEQ DEST 'D-INDS) ,TAG)))       ((NULL (CDR ARGL));; Compile the last form.  If we want multiple values;; and it handles them, then say the AND is handling them.(COND (M-V-TARGET       (WHEN (NULL (P2MV (CAR ARGL) IDEST M-V-TARGET)) (SETQ TAG1 (GENSYM))))      (UNCONDITIONAL       (P2BRANCH (CAR ARGL) DEST BDEST)       (SETQ BDEST NIL))      (T (P2 (CAR ARGL)     (IF (AND (EQ DEST 'D-RETURN)      (NOT GENERATING-MICRO-COMPILER-INPUT-P)) DEST   ;OK TO DISTRIBUTE DOWN A D-RETURN, SINCE   ; IT IS AN IMPLICT TRANSFER       IDEST)))))  ;COMPILE TO IDEST, SINCE GOING TO   ;FALL INTO COMMON POINT WHICH EXPECTS RESULT THERE     (P2 (CAR ARGL) IDEST)     (AND (EQ IDEST 'D-INDS)  (SIMPLEGOP (CADR ARGL))  (RETURN (OUTB `(BRANCH NULL ,(OTHER SENSE) NIL ,(GTAG (CADADR ARGL))))))     (OUTB (COPY-LIST BRANCH)))))(COND  (TAG1   ;; If we want multiple values, and the last form provides them,   ;; say that the AND provides them,   ;; and arrange to produce some in every other path.   (OUTB `(BRANCH ALWAYS NIL NIL ,TAG1))   ;Last form jumps around.   (OUTTAG TAG)   ;Other paths come here.   (COND     ((NUMBERP M-V-TARGET)   ;Turn single value into N values,      (PUSH-NILS (1- M-V-TARGET)))     ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST) ;or into a list of values.      (OUTF '(MISC D-PDL NCONS)))     (M-V-TARGET                   ;other cases where multiple values       (P2PUSH-CONSTANT 1))         ;were expected but a single value returned     )   (SETQ M-V-TARGET NIL)   (OUTTAG TAG1))           ;Last form jumps here.  ((NOT UNCONDITIONAL)   (OUTTAG TAG)   (OR (EQ DEST 'D-IGNORE)       (EQ DEST 'D-INDS)       (MOVE-RESULT-FROM-PDL DEST))))))(DEFUN SIMPLEGOP (FORM)  ;; Return T if given a (GO tag) which could be done with just a branch  ;; (doesn't require popping anything off the pdl).  ;;  ;;  1/22/86 DNG - Fix to check for special bindings also.  ;; 10/18/86 DNG - Use GOTAGS-SEARCH instead of ASSOC.  ;; 11/17/86 CLM - Fix to check for lexical-closures.  May have to do an  ;;                unshare, so don't return T.  ;; 12/03/86 CLM - Fix to check for lexical closures. Faulty end-test was causing  ;;                an infinite loop.  ;;  2/04/87 DNG - When LEXICAL-CLOSURE-COUNT is 0, don't bother looking for variables needing to be unshared.  (AND (NOT (ATOM FORM))       (EQ (FIRST FORM) 'GO)       (LET ((GOTAG (GOTAGS-SEARCH (SECOND FORM) T))     PD) (AND GOTAG (= PDLLVL (GOTAG-PDL-LEVEL GOTAG))      (SETQ PD (GOTAG-PROGDESC GOTAG))      (DOLIST (PROGDESC PROGDESCS T)(IF (EQ PROGDESC PD)    (RETURN T)  (UNLESS (AND (MEMBER (PROGDESC-NBINDS PROGDESC) '(0 NIL) :TEST #'EQ)       (OR (ZEROP LEXICAL-CLOSURE-COUNT)   (DO ((VS VARS (CDR VS))(OVARS (PROGDESC-VARS PROGDESC)))       ((OR (EQ VS OVARS)    (NULL VS)) T)     (LET ((V (CAR VS)))       (WHEN (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC V)     :TEST #'EQ) (RETURN NIL)))) ;DO   )        );and    (RETURN NIL))  ))))))(DEFPROP COND P2COND P2) (DEFUN P2COND (ARGL DEST)  ;; 01/09/86  CLM - Modified for Release 3 so that if the selected clause is  ;;                 the last (or only) clause and a singleton clause, then only  ;;                 a single value will be returned - when compiling for Common  ;;                 Lisp.  ;; 02/14/86  DNG - Fix for returning NIL default when last clause does a GO. [SPR 1074]  ;; 02/14/86  CLM - Handle cases where multiple values are expected but only a  ;;                 single value is produced.  ;;  9/05/86  CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET.  ;;  9/22/86  DNG - Optimize COND to use SELECT instruction.  (IF (AND (> (LENGTH ARGL) 2)   (NULL M-V-TARGET)   (COMPILING-FOR-V2)   #+(and Elroy compiler:debug) ; temporary %%%   (>= %microcode-version-number 148.)   (CONSP (CAR-SAFE (FIRST ARGL)))   (LET ((X (SECOND (FIRST (FIRST ARGL)))) (N 0))     (DOLIST (CLAUSE ARGL T)       (LET ((TEST (CAR-SAFE CLAUSE))) (WHEN (ATOM TEST) (RETURN NIL)) (UNLESS (OR (AND (EQ (FIRST TEST) 'QUOTE)  (SECOND TEST))     (AND (MEMBER (FIRST TEST) '(EQ MEMQ) :TEST #'EQ)  (QUOTEP (THIRD TEST))  (EQUAL-FORMS (SECOND TEST) X)  (OR (REST CLAUSE)      (EQ (FIRST TEST) 'EQ)      (MEMBER DEST '(D-IGNORE D-INDS)))  (NULL (NTHCDR 3 TEST))))   (RETURN NIL)) (WHEN (> (INCF N) 3)   (RETURN T)) ))))      ;; then can optimize to use SELECT or DISPATCH instruction      (P2SELECT ARGL DEST)    ;; else normal COND processing  (PROG (CLAUSE TAG TAG1 TAG2 VALF CLAUSE-LENGTH TM IDEST PRED NOFALLTHRU LAST-CLAUSE-FLAG IDEST-USED)(SETQ TAG2 (GENSYM))   ;TAG TO GO TO WITH VALUE OF COND IN DEST(SETQ TAG (GENSYM))   ;TAG TO GO TO WITH VALUE OF COND IN IDEST;; Choose an intermediate destination, depending on ultimate destination.;; The intermediate destination can match the ultimate one;; if they are D-IGNORE, D-INDS or D-PDL.;; Each COND clause can compile its value to IDEST and go to TAG;; or compile its value to DEST and go to TAG2.;; Use of TAG and IDEST assumes that multiple values were NOT generated;; whereas TAG2 and DEST assumes that they were if they are supposed to be.;; For microcompiler input, we always use TAG and IDEST unless IDEST=DEST.;; Otherwise, we usually use DEST except for clauses that are just predicates.;; IDEST-USED is T if a clause has compiled its result to IDEST.;; The code to move the value is only generated if IDEST/TAG has been used.(AND M-V-TARGET (SETQ DEST 'D-PDL))(SETQ IDEST 'D-IGNORE)(UNLESS (EQ DEST 'D-IGNORE)  (SETQ VALF T)  (SETQ IDEST 'D-PDL))(WHEN (EQ DEST 'D-INDS)  (SETQ IDEST 'D-INDS));; Compile next clause.     L1(WHEN (NULL (CDR ARGL))  (SETQ LAST-CLAUSE-FLAG T))(SETQ CLAUSE (CAR ARGL));;the following clause changed 01/09/86 by CLM;;if compiling for common-lisp, multiple values should;;not be returned if the last clause is a singleton clause.(AND (NOT COMPILING-COMMON-LISP)     LAST-CLAUSE-FLAG     (NULL (CDR CLAUSE))     (SETQ CLAUSE (CONS ''T CLAUSE)))(SETQ TAG1 (GENSYM))(SETQ PRED (CAR CLAUSE))(WHEN (AND (NOT (ATOM PRED))   (EQ (CAR PRED) 'QUOTE))  (COND    ((NULL (CADR PRED))   ;IS THE NULL CONDITION?     (AND (NOT LAST-CLAUSE-FLAG)  (GO L5)))                ;YEP.  CAN HAPPEN AS RESULT OF DO EXPANSION.    ((CDR ARGL)   ;condition always true?     (SETQ LAST-CLAUSE-FLAG T)   ;If so, discard any remaining clauses     (SETQ NOFALLTHRU T)   ;after a warning about them.;These can come from expanding DEFSUBSTs that contain CONDs, with constant arguments.;     (WARN 'UNREACHABLE-CODE ':IMPLAUSIBLE; "Some COND clauses are unreachable;; the first starts with ~S."; (CAADR ARGL))     (SETQ ARGL (LIST CLAUSE)))    (T (SETQ NOFALLTHRU T))))(SETQ CLAUSE-LENGTH (LENGTH CLAUSE));; Handle certain special cases of clauses.(COND  ((AND VALF (= 1 CLAUSE-LENGTH))   ;; Clause containing only one element, compiled for value.   ;; value of condition is also value of clause.   (P2 PRED IDEST)   (SETQ IDEST-USED T)   ;;if clause is the last of the COND, don't generate   ;;an unnecessary branch   (UNLESS LAST-CLAUSE-FLAG     (OUTB (LIST 'BRANCH 'NULL 'FALSE (EQ IDEST 'D-PDL)   ;IF SOMETHING PUSHED, POP IF TAG)))   ; THE BRANCH IS NOT TAKEN   (GO L5))  ;; Clause of one element, if value is not wanted.  ((= 1 CLAUSE-LENGTH) (BOOL1 PRED 'FALSE TAG) (GO L5))  ;; Clause is just condition followed by a GO.  ((AND (= 2 CLAUSE-LENGTH)(SIMPLEGOP (CADR CLAUSE))(NOT (AND VALF LAST-CLAUSE-FLAG)))   (BOOL1 PRED 'FALSE (GTAG (CADADR CLAUSE)))   (GO L5))  ;; Clause after this one is (T (GO ...)).  ;; Can get special handling only if the GO  ;; requires no pdl adjustment.  ((AND (NOT NOFALLTHRU)   ;ISOLATE CASE OF(NOT LAST-CLAUSE-FLAG)   ;((P1 A1) (T (GO X)))(NOT (ATOM (CAR (SETQ TM (CADR ARGL)))))(EQ (CAAR TM) 'QUOTE)(CADAR TM)(= 2 (LENGTH TM))(SIMPLEGOP (CADR TM)))   ;; In effect, we turn this into (COND ((NOT P1) (GO X)) (T A1))   (BOOL1 PRED 'TRUE (GTAG (CADADR TM)))   ;GO X DIRECTLY IF P1 FALSE   (SETQ ARGL (CONS (CONS ''T (CDR CLAUSE)) (CDDR ARGL))) (GO L1))  ((NOT NOFALLTHRU)   ;Normal COND clause.   (BOOL1 PRED 'TRUE TAG1)))   ;Jump around clause if predicate fails.;; If the COND will have to return NIL if this clause's;; condition is false, then generate a clause to return the nil.(WHEN (AND VALF LAST-CLAUSE-FLAG (NOT NOFALLTHRU))  (SETQ ARGL (LIST CLAUSE '('T (QUOTE NIL))))  (SETQ LAST-CLAUSE-FLAG NIL));; Compile the actions of the cond clause, except for the last.(DO ((ACTIONS (CDR CLAUSE) (CDR ACTIONS)))    ((NULL (CDR ACTIONS))     (SETQ CLAUSE ACTIONS))  (P2 (CAR ACTIONS) 'D-IGNORE));; Compile last action of cond clause (the value).(LET ((TO-IDEST-P;; Send value of last clause to IDEST rather than DEST;; if that means we can avoid a branch to TAG2;; that would otherwise be necessary.;; Send values of all clauses to IDEST for microcompiler input.(OR  (AND LAST-CLAUSE-FLAG       IDEST-USED       (NEQ DEST IDEST)       ;; Don't do this optimization if mult values wanted       ;; because only compilation to DEST can accept them.       (NULL M-V-TARGET)       ;; If D-RETURN, don't optimize, so it can propagate       ;; multiple values if there are any.       (NEQ DEST 'D-RETURN))  (AND GENERATING-MICRO-COMPILER-INPUT-P       (NOT (EQ DEST IDEST))))))  (COND    (TO-IDEST-P (P2 (CAR CLAUSE) IDEST))    ((EQUAL (CAR CLAUSE) '(QUOTE NIL))     ;; Avoid "Doesn't really produce multiple values"     ;; for internally generated 'NIL.     (P2 '(QUOTE NIL) DEST)     (AND M-V-TARGET (SETQ TO-IDEST-P T)))    ((P2MV (CAR CLAUSE) DEST M-V-TARGET)     ;; If value fails to generate mult vals,     ;; we must make TAG generate them and go there.     (SETQ TO-IDEST-P T)))  (COND    ((NULL TO-IDEST-P)     (WHEN (OR (NULL LAST-CLAUSE-FLAG)       ;; If last clause, and TAG isn't the same as TAG2,       ;; we must still branch to TAG2.       (AND IDEST-USED    (OR M-V-TARGET(NEQ DEST IDEST))))       (OUTB (LIST 'BRANCH 'ALWAYS NIL NIL TAG2))))    (T (SETQ IDEST-USED T)       (WHEN (NULL LAST-CLAUSE-FLAG) (OUTB (LIST 'BRANCH 'ALWAYS NIL NIL TAG))))));; Here at end of cond-clause.     L5(OUTTAG TAG1)   ;Output tag for jumps from failing predicate.(WHEN (SETQ ARGL (CDR ARGL))  (GO L1));; There are no more cond clauses!(OUTTAG TAG);;multiple values were expected but not produced(AND IDEST-USED     (COND       ((NUMBERP M-V-TARGET)(PUSH-NILS (1- M-V-TARGET)))       ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST)(OUTM '(MISC D-PDL NCONS)))       ;; 2/14/86 if mvtarget was return or throw       ;;set up for a return/throw-n of 1       ((OR (EQ M-V-TARGET 'THROW)    (EQ M-V-TARGET 'RETURN)    (EQ M-V-TARGET 'RETURN-CATCH))(P2PUSH-CONSTANT 1))       ((NEQ DEST IDEST)(MOVE-RESULT-FROM-PDL DEST))));; We have generated multiple values if necessary.(SETQ M-V-TARGET NIL)(OUTTAG TAG2)(RETURN NIL))))(DEFUN P2SELECT (ARGL DEST)  ;; Optimize a COND form to use a SELECT or DISPATCH instruction.  ;;  9/05/86 DNG - Original.  ;; 10/11/86 DNG - Can't use DISPATCH unless selector is known to be an integer.  ;; 12/23/86 DNG - Bind PDLLVL so that P2PROGN doesn't increment it for each clause.  ;; 12/31/86 DNG - Bind BDEST to NIL to prevent inappropriate optimizations. [SPR 2911]  (LET* ((VALUE-LIST NIL) (TAG-LIST NIL) (EXIT-TAG (MAKE-LAP-TAG)) (OTHERWISE-TAG NIL)  LAP-INDEX    ; array index where SELECT will be placed. (SELECTOR (SECOND (FIRST (FIRST ARGL)))) )    (P2PUSH SELECTOR)    (OUTF NIL) ; reserve space for possible ADD-IMMED before DISPATCH    (SETF LAP-INDEX (FILL-POINTER QCMP-OUTPUT))    (OUTF 'SELECT) ; reserve space for inserting SELECT or DISPATCH instruction    (SETQ DROPTHRU NIL)    (DO ((CLAUSES ARGL (CDR CLAUSES)))    ; for each COND clause((NULL CLAUSES))      (LET* ((CLAUSE (FIRST CLAUSES))     (TAG (MAKE-LAP-TAG))     (TEST (FIRST CLAUSE)))(COND ((AND (EQ (CAR-SAFE TEST) 'EQ)    (QUOTEP (THIRD TEST))    (EQUAL-FORMS (SECOND TEST) SELECTOR))       (LET (( VALUE (SECOND (THIRD TEST)) )) (UNLESS (MEMBER VALUE VALUE-LIST :TEST #'EQ)   (PUSH VALUE VALUE-LIST)   (PUSH TAG TAG-LIST))))      ((EQ (CAR-SAFE TEST) 'QUOTE)   ; otherwise case       (DEBUG-ASSERT (SECOND TEST))       (SETF OTHERWISE-TAG TAG))      ((AND (EQ (CAR-SAFE TEST) 'MEMQ)    (QUOTEP (THIRD TEST))    (EQUAL-FORMS (SECOND TEST) SELECTOR))       (DOLIST (VALUE (SECOND (THIRD TEST))) (UNLESS (MEMBER VALUE VALUE-LIST :TEST #'EQ)   (PUSH VALUE VALUE-LIST)   (PUSH TAG TAG-LIST))))      (T (SETF CLAUSE `(T (COND . ,CLAUSES))) (SETF CLAUSES NIL) (SETF OTHERWISE-TAG TAG))      )(OUTTAG-FORCED TAG)(LET ((PDLLVL PDLLVL)      (BDEST NIL))  (IF (NULL (REST CLAUSE))      (P2 '(QUOTE T) DEST)    (P2PROGN (REST CLAUSE) DEST)))(OUTB `(BRANCH ALWAYS NIL NIL ,EXIT-TAG))))   ; end of loop on COND clauses    (WHEN (NULL OTHERWISE-TAG) ; no explicit otherwise      (SETF OTHERWISE-TAG (MAKE-LAP-TAG))      (OUTTAG-FORCED OTHERWISE-TAG)      (P2 '(QUOTE NIL) DEST)      (OUTB `(BRANCH ALWAYS NIL NIL ,EXIT-TAG)))    (OUTTAG EXIT-TAG)    (LET* ((MIN (FIRST VALUE-LIST))   (MAX MIN)   (NVALUES (LENGTH VALUE-LIST)))      (IF (AND (DOLIST (VALUE VALUE-LIST T) (UNLESS (INTEGERP VALUE)   (RETURN NIL)) (IF (> VALUE MAX)     (SETF MAX VALUE)   (IF (< VALUE MIN)       (SETF MIN VALUE))))       (<= (- MAX MIN) (* NVALUES 2))       (EXPR-TYPE-P SELECTOR 'INTEGER))  ;; All of the values are integers and reasonably contiguous, so  ;; use a DISPATCH instruction instead of SELECT.  (PROGN    (IF (<= 0 MIN (OPT-SPEED OPTIMIZE-SWITCH))(SETQ MIN 0)      (SETF (AREF QCMP-OUTPUT (- LAP-INDEX 1))    `(- 0 (QUOTE-VECTOR ',MIN))))    (LET* ((TAG-TABLE (MAKE-ARRAY (+ (- MAX MIN) 1) :INITIAL-ELEMENT OTHERWISE-TAG)))      (DOLIST (VALUE VALUE-LIST)(SETF (AREF TAG-TABLE (- VALUE MIN)) (FIRST TAG-LIST))(SETF TAG-LIST (REST TAG-LIST)))      (SETF (AREF QCMP-OUTPUT LAP-INDEX)    `(DISPATCH ,OTHERWISE-TAG ,TAG-TABLE))));; Else, finish setting up the SELECT instruction.(LET ((TAG-TABLE (MAKE-ARRAY NVALUES))      (VALUE-TABLE (NREVERSE VALUE-LIST)))  (DO ((I (- NVALUES 1) (- I 1)))      ((< I 0))    (SETF (AREF TAG-TABLE I) (FIRST TAG-LIST))    (SETF TAG-LIST (REST TAG-LIST)))  (SETF (AREF QCMP-OUTPUT LAP-INDEX)`(SELECT ,OTHERWISE-TAG ,TAG-TABLE ,VALUE-TABLE)))))))(DEFUN (:PROPERTY %DISPATCH P2) (ARGL DEST)  ;;      (%DISPATCH selector max default . body)  ;;                    1      2     3      4 ...  ;; 12/07/85 DNG - Original version.  ;;  9/05/86 DNG - Don't need PEEP-KEEP property anymore.  (P2 (FIRST ARGL) 'D-PDL)   ; selector expression  (LET (TABLE   ; dispatch table(TAG NIL)END-TAG)    (LET ((OTHERWISE-TAG (MAKE-LAP-TAG)))      (SETQ TABLE (MAKE-ARRAY (+ (SECOND ARGL) 1) :INITIAL-ELEMENT OTHERWISE-TAG))      (OUTI `(DISPATCH ,OTHERWISE-TAG ,TABLE))   ; note table is filled in below.      (OUTF '(NO-DROP-THROUGH))      (IF (AND (EQ DEST 'D-IGNORE)       (NO-SIDE-EFFECTS-P (THIRD ARGL)))  (SETQ END-TAG OTHERWISE-TAG)(PROGN  (OUTF OTHERWISE-TAG)  (P2 (THIRD ARGL) DEST)   ; default action  (OUTB `(BRANCH ALWAYS NIL NIL ,(SETQ END-TAG (MAKE-LAP-TAG)))))))    (DOLIST (FORM (NTHCDR 3 ARGL))      (IF (FIXNUMP FORM)   ; value tag   (PROGN    (WHEN (NULL TAG)      (SETQ TAG (MAKE-LAP-TAG))      (UNLESS DROPTHRU(OUTF '(NO-DROP-THROUGH))(SETQ DROPTHRU T))      (OUTF TAG))    (SETF (AREF TABLE FORM) TAG))(PROGN  (SETQ TAG NIL)  (P2 FORM 'D-IGNORE))))    (P2 '(QUOTE NIL) DEST)    (OUTF END-TAG))) (DEFUN GOTAGS-SEARCH (TAG &OPTIONAL NO-ERROR TAGS-LIST)  ;;  8/28/85 - In order to avoid giving invalid code to the peephole optimizer  ;;            when the named tag is undefined, try to return some valid tag  ;;            instead of NIL.  [SPR 501]  ;; 10/18/86 - Now that GO forms contain the tag structure instead of the symbol, just return the argument.  (IGNORE NO-ERROR TAGS-LIST)  TAG  #| old way  (IF (CONSP TAG)      TAG    (OR (ASSOC TAG (OR TAGS-LIST GOTAGS) :TEST #'EQUAL)(PROGN  (WHEN NO-ERROR (RETURN-FROM GOTAGS-SEARCH NIL))  (WARN 'BAD-GO-TAG :IMPOSSIBLE"There is a GO to tag ~S but no such tag exists."TAG)  (PROGDESC-RETTAG (FIRST PROGDESCS)))(FIRST GOTAGS)))  |#  )(DEFUN GTAG (X)  (GOTAG-LAP-TAG (GOTAGS-SEARCH X))) ;Output an unconditional jump to a specified tag, popping the pdl if necessary.;Barf if the tag is not known on GOTAGS.(DEFUN OUTB1 (TAG)  (OUTBRET TAG nil 0)) ;Output an unconditional transfer to the specified prog tag,;popping the pdl the appropriate number of times to adjust the;pdl from its current level to the level required at that tag.;For handling GO, PROGDESC should be NIL and NVALUES should be 0.;When jumping to the return tag of a prog, PROGDESC should be;the desc for the prog we are returning from, and NVALUES should be;the number of things on the top of the stack which are being left;there as values to return from the prog.(DEFUN OUTBRET (TAG PROGDESC NVALUES)   ;;  11/17/86 CLM - Fix to do an unshare if in a lexical-closure.   (LET* ((EXITPROGDESC PROGDESC)  (TM (GOTAGS-SEARCH TAG)))     (UNLESS (NULL TM)     ;; If this is GO, set EXITPROGDESC to the progdesc of its containing PROG     (UNLESS PROGDESC     (SETQ EXITPROGDESC (GOTAG-PROGDESC TM)))     (POP-FRAMES EXITPROGDESC NVALUES)     ;; For a prog rettag, the pdl level should include     ;; the number of values desired on the stack.     (POPPDL NVALUES (- PDLLVL (GOTAG-PDL-LEVEL TM)))     ;;do an unshare if needed     (WHEN (> LEXICAL-CLOSURE-COUNT 0)   (P2 `(UNSHARE-STACK-CLOSURE-VARS ,VARS ,(PROGDESC-VARS EXITPROGDESC)) 'D-IGNORE))     (OUTB `(BRANCH ALWAYS NIL NIL ,(GOTAG-LAP-TAG TM)))     NIL)) )(DEFUN POP-FRAMES (EXITPROGDESC NVALUES)  ;; If we are exiting any PROGs, unwind stacks to their levels.  ;; Does not include the prog whose desc is EXITPROGDESC.  ;;  ;; 12/15/86 DNG - Update to handle special-pdl-index that has been saved in a  ;;local variable.  (LET ((N-UNBINDS 0)(LAST-VARIABLE-UNBIND-PDL-LEVEL NIL))    (DO ((L PROGDESCS (CDR L)))((EQ (CAR L) EXITPROGDESC))      (LET ((NBINDS (PROGDESC-NBINDS (CAR L))))(IF (CONSP NBINDS) ; dynamic binding    (PROGN      (SETQ LAST-VARIABLE-UNBIND-PDL-LEVEL    (OR (SECOND NBINDS) ; special-pdl-index saved in local variable(PROGDESC-PDL-LEVEL (CAR L)) ; index on stack))      (SETQ N-UNBINDS (FIRST NBINDS)) ; bindings before the index      )  (INCF N-UNBINDS NBINDS))))    (COND ((NULL LAST-VARIABLE-UNBIND-PDL-LEVEL))  ((FIXNUMP LAST-VARIABLE-UNBIND-PDL-LEVEL)   ;; LAST-VARIABLE-UNBIND-PDL-LEVEL is the level at start of PROG body,   ;; and does not include the values we want to return.   ;; PDLLVL at all times includes those values   ;; since they are already on the stack.   (POPPDL NVALUES (- PDLLVL NVALUES LAST-VARIABLE-UNBIND-PDL-LEVEL))   (OUTPUT-UNBIND-TO-INDEX NVALUES)   (SETQ PDLLVL (+ LAST-VARIABLE-UNBIND-PDL-LEVEL NVALUES -1)))  ((DEBUG-ASSERT (CONSP LAST-VARIABLE-UNBIND-PDL-LEVEL))   ;; the special-pdl-index was saved in a local variable   (P2PUSH LAST-VARIABLE-UNBIND-PDL-LEVEL)   (OUTPUT-UNBIND-TO-INDEX 0)))    (UNBIND 'D-IGNORE N-UNBINDS))) ;Pop NPOPS words off the pdl, from underneath the top NVALUES words.;We do not change PDLLVL.(DEFUN POPPDL (NVALUES NPOPS) ;;  8/10/85 DNG - Modified for release 3. ;;  9/25/85 DNG - POP-M-FROM-UNDER-N is now an AUX op; ;;                change instruction name from POPPDL to POP-PDL. ;; 12/05/85 CLM - Emit a %CLOSE-CATCH instead of POP-OPEN-CALL ;;                to pop catch blocks. ;;  1/30/86 CLM - Modified for cases where there is a return from ;;                within a CATCH or an UNWIND-PROTECT ;;  2/05/86 CLM - An addendum to the above modification.  This handles ;;                returns from within the cleanup-forms of an unwind-protect. ;;  2/12/86 CLM - Fix to prevent too many pops from taking place. ;;  5/29/86 CLM - Fix so that after a close-catch, NPOPS will be decremented ;;                by the correct number of words.  Use the constant CATCH-BLOCK-SIZE ;;                for the current number. ;; 11/17/86 CLM - Changed to handle new UNWIND-PROTECT scheme. ;; 11/24/86 CLM - For unwind-protect undo forms, make sure that the block being exited is ;;                the unwind-protect block and not a block generated within the undo forms ;;                before doing special handling.  ;(print (list 'poppdl nvalues npops))   (COND #+compiler:debug    ((MINUSP NPOPS)     (BARF NPOPS "negative number of pops" 'BARF))    ((OR (COMPILING-FOR-V2) (NOT (ZEROP NPOPS)))     ;; Output enough POP-OPEN-CALL instructions to flush     ;; any unwind protects inside the desired pdl level.     ;; For Rel. 3 use %CLOSE-CATCH.     (DO ((I 0 (1+ I))  (N 0)  (L CALL-BLOCK-PDL-LEVELS (CDR L))  (CBPL CALL-BLOCK-PDL-LEVELS)  (UNDO-PDL-LEVEL (PROGDESC-UNDO-PDL-LEVEL (FIRST PROGDESCS)))) ((OR (NULL L)      ;;making a change here----------      ;;instead of <= use < so that if the levels      ;;happen to be equal a close catch will be done      (< (IF (CONSP (CAR L))     (CAAR L)   (CAR L)) (- PDLLVL NPOPS NVALUES)))  ;; N is the number of frames we must flush  ;; to take us past all the unwind-protects.  (DOTIMES (J N)    (IF (COMPILING-FOR-V2)(PROGN  (IF (AND (CONSP (CAR CBPL))   (EQ (CADAR CBPL) 'UNWIND-PROTECT))      (IF (AND (EQ (CAR (LAST (CAR CBPL))) 'UNDO)       UNDO-PDL-LEVEL)  (LET ((PDLLVL-DELTA (- PDLLVL (CAR UNDO-PDL-LEVEL))))    (IF (ZEROP PDLLVL-DELTA)(OUT-AUX 'POP-PDL 1) ;haven't added to stack but must pop restart-macro-pc      (OUT-AUX 'POP-PDL PDLLVL-DELTA))    (OUT-AUX '%UNWIND-PROTECT-CLEANUP)    (DECF PDLLVL (IF (ZEROP PDLLVL-DELTA) 1 PDLLVL-DELTA))    (POP UNDO-PDL-LEVEL)    ;;IF EXITING THE UNDO FORMS MUST MAKE SURE ANYTHING LEFT ON THE STACK    ;;BY THE PROTECTED FORMS IS ALSO POPPED    (UNLESS (= (CAAR CBPL) PDLLVL)    (OUT-AUX 'POP-PDL (- PDLLVL (CAAR CBPL)))    (DECF PDLLVL (- PDLLVL (CAAR CBPL))))    )(PROGN  (OUT-AUX '%CLOSE-CATCH-UNWIND-PROTECT)  (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE))  (SETQ NPOPS (- NPOPS CATCH-BLOCK-SIZE))  (OUTB `(BRANCH PUSHJ NIL NIL ,(CADDAR CBPL)))  (OUT-AUX '%UNWIND-PROTECT-CONTINUE)))    (PROGN      (OUT-AUX '%CLOSE-CATCH)      (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE))      (SETQ NPOPS (- NPOPS CATCH-BLOCK-SIZE)))    )    ;(SETQ NPOPS (- NPOPS CATCH-BLOCK-SIZE))  )      (PROGN(IF (NUMBERP (CAR CALL-BLOCK-PDL-LEVELS))    (P2PUSH-CONSTANT 0)  (OUTI `(MOVE D-PDL (QUOTE-VECTOR       (TAG ,(CADDAR CALL-BLOCK-PDL-LEVELS))))))(OUTI '(MISC D-IGNORE POP-OPEN-CALL))))    (IF (COMPILING-FOR-V2)(SETQ CBPL (CDR CBPL))      (POP CALL-BLOCK-PDL-LEVELS))))       (WHEN (OR (COMPILING-FOR-V2) (AND (CONSP (CAR L))      (EQ (CADAR L) 'UNWIND-PROTECT))) (SETQ N (1+ I))))     (UNLESS (= NPOPS 0)       (COND ((> NVALUES 1)  (P2PUSH-CONSTANT NPOPS)  (P2PUSH-CONSTANT NVALUES)  (OUT-AUX 'POP-M-FROM-UNDER-N)) ((= NVALUES 1)  (P2PUSH-CONSTANT NPOPS)  (OUTI '(MISC D-PDL SHRINK-PDL-SAVE-TOP))) (T  (DO ((N 15 (+ N 15)))       ;; N is number of pops we would have done if we now do       ;; another POPPDL 17.  N-17 is number of pops so far.      ((> N NPOPS)       (UNLESS (= NPOPS (- N 15)) (OUT-AUX 'POP-PDL (- NPOPS (- N 15)))))    (OUT-AUX 'POP-PDL 15))))))))(DEFPROP LDB P2LDB P2) (DEFUN P2LDB (ARGL DEST) ;;  3/21/86 CLM - Original version - where possible use LDB-IMMED instead  ;;                the LDB misc-op. ;;  3/21/86 DNG - Don't use LDB-IMMED unless DEST is D-PDL. ;;  3/24/86 DNG - Put NO-D-RETURN around P2MISC call. ;;  8/28/86 CLM - no longer pass DESC arg to p2argc, just nil ;;  9/22/86 DNG - Don't generate LDB instruction when DEST is D-IGNORE.  (LET ((NARGS 2))    (IF (= (LENGTH ARGL) NARGS);;ldb should have two args(IF (EQ DEST 'D-IGNORE)    (ARGLOAD ARGL DEST)  (IF (AND (QUOTEP (FIRST ARGL))   (INTEGERP (SECOND (FIRST ARGL)))   (INSTRUCTION-EXISTS-P 'LDB-IMMED)   (EQ DEST 'D-PDL))      (LET ((PP (BYTE-POSITION (SECOND (FIRST ARGL))))    (SS (BYTE-SIZE (SECOND (FIRST ARGL))))    (PPSS 0))(IF (OR (> PP 31)(> SS 15))    ;;the byte specifier won't fit the 9 bit field of the    ;;immed instr    (P2MISC 'LDB ARGL DEST NARGS)  (PROGN    ;;byte will fit in 9 bit field    ;;first must reshape the ppss arg to fit into 9 bits    ;;5 bit position, 4 bit size    (SETQ PPSS  (DPB PP (BYTE 5 4) (DPB SS (BYTE 4 0) PPSS)))    (P2PUSH (SECOND ARGL))    (OUTI `(LDB-IMMED ,PPSS)))))    (NO-D-RETURN      (P2MISC 'LDB ARGL DEST NARGS))))      (P2ARGC NIL ARGL nil DEST 'LDB))))(DEFUN (:PROPERTY %LOAD-MEMORY-MAP P2) (ARGL DEST)  ;; This misc-op needs special handling because it pushes two values on the stack.  ;;  9/??/86 EPM - Original version hacked from P2FLOOR.  ;;  9/25/86 DNG - Updated for rel3 compiler.  (IF (OR (NOT (= (LENGTH ARGL) 4)) ; wrong number of arguments  (NOT (COMPILING-FOR-V2)))      (P2ARGC NIL ARGL NIL DEST '%LOAD-MEMORY-MAP)    (PROGN      (ARGLOAD ARGL 'D-PDL)      (OUTM '(MISC D-PDL %LOAD-MEMORY-MAP))      (COND ((EQ DEST 'D-RETURN)     (OUTI '(AUX RETURN-0 2))     (SETQ DROPTHRU NIL))    ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST)     (OUTM '(MISC D-PDL NCONS))     (OUTM '(MISC D-PDL CONS)))    ((EQ M-V-TARGET 'THROW)     (P2PUSH-CONSTANT 2))    ((MEMBER M-V-TARGET '(RETURN RETURN-CATCH) :TEST #'EQ)     (P2PUSH-CONSTANT 2))    ((AND (FIXNUMP M-V-TARGET)  (>= M-V-TARGET 2))     (PUSH-NILS (- M-V-TARGET 2)))    (T (WARN '%LOAD-MEMORY-MAP :IMPOSSIBLE     "~A called without accepting 2 values" '%LOAD-MEMORY-MAP)))      (SETQ M-V-TARGET NIL))))  '(CDR CDDR 1+ 1-) :TEST #'EQ)(MEMBER DEST '(D-IGNORE D-INDS) :TEST #'EQ))   (OUTI `(SETE ,(CAR VALUE) ,(P2-DESTINATION VAR))))  ((AND (COMPILING-FOR-V2)(NOT (ATOM VALUE))(CDR VALUE)(EQUAL (CADR VALUE) VAR)(SETQ INSTR (GET-FOR-TARGET (CAR VALUE) 'SETE))(MEMBER DEST '(D-IGNORE D-INDS) :TEST #'EQ))   (OUTI `(,INSTR D-INDS ,(P2-DESTINATION VAR))))  (T (P2PUSH VALUE)     (MOVEM-AND-MOVE-TO-DEST VAR DEST))))  NIL) (DEFUN (:PROPERTY PUSH-CDR-STORE-CAR-IF-CONS P2) (ARGL DEST)  ;; Used for MATCHCARCDR in file SYS:SYS2;SELEV  ;; 12/26/84 DNG - Modified to use P2-DESTINATION.  (P2PUSH (CAR ARGL))  (IF (ADRREFP (CADR ARGL))      (PROGN(OUTI `(PUSH-CDR-STORE-CAR-IF-CONS ,(P2-DESTINATION (CADR ARGL))))(UNLESS (EQ DEST 'D-INDS)  (OUTM `(MISC ,DEST ,(MISC-LAP-CODE 'INDICATORS-VALUE)))))    (LET ((TAG (GENSYM)))      (OUTM '(MISC D-INDS CONSP-OR-POP))      (OUTB `(BRANCH NULL TRUE NIL ,TAG))      (OUTM '(MISC D-PDL CARCDR))      (MOVEM-AND-MOVE-TO-DEST (CADR ARGL) 'D-IGNORE)      (OUTTAG TAG)      (UNLESS (EQ DEST 'D-INDS)(OUTM `(MISC ,DEST ,(MISC-LAP-CODE 'INDICATORS-VALUE)))))))(DEFUN (:PROPERTY PUSH-CDR-IF-CAR-EQUAL P2) (ARGL DEST)  ;; Used by P1 handler for SI:MATCHCARCDR  ;; 12/04/85 DNG - Modified to not use P2NODEST.  (P2 (CAR ARGL) 'D-PDL)  (OUTI `(PUSH-CDR-IF-CAR-EQUAL 0 ,(P2-SOURCE (CADR ARGL) 'D-INDS)))  (UNLESS (EQ DEST 'D-INDS)    (OUTM `(MISC ,DEST ,(MISC-LAP-CODE 'INDICATORS-VALUE)))))(DEFUN (:PROPERTY %DOLIST P2) (ARGL DEST)  ;; %DOLIST is used in optimizer which expands DOLIST  ;; 12/26/84 DNG - Use P2-DESTINATION instead of P2-SOURCE.  ;;  4/09/85 DNG - Set TAGOUT to T.  ;;  6/02/86 DNG - Bind TAGOUT to T instead of just SETQing it.  (IGNORE DEST)  (LET ((TOP-TAG (GENSYM))(BOTTOM-TAG (GENSYM))(PDLLVL PDLLVL))    (P2PUSH (SECOND ARGL))    (INCPDLLVL)    (OUTB `(BRANCH ALWAYS NIL NIL ,TOP-TAG))    (OUTTAG TOP-TAG)    (LET ((TAGOUT T))      (OUTI `(PUSH-CDR-STORE-CAR-IF-CONS       ,(P2-DESTINATION (FIRST ARGL))))      (OUTB `(BRANCH NULL TRUE NIL ,BOTTOM-TAG))      (P2 (THIRD ARGL) 'D-IGNORE)      (OUTB `(BRANCH ALWAYS NIL NIL ,TOP-TAG))      (OUTTAG BOTTOM-TAG) )))(DEFUN (:PROPERTY THE-EXPR P2) (ARGL DEST)  ;; THE-EXPR forms are generated by P1-WITH-ANNOTATION.  ;; 1/28/85 -Original version.  ;; 3/11/86 - Call P2 instead of P2F if FORM is a variable [ADRREFP true].  ;;12/09/86 - Call P2 instead of P2F if FORM is a LEXICAL-REF.  (LET* ((THE-FORM (CONS 'THE-EXPR ARGL)) (OPTIMIZE-SWITCH (EXPR-OPTIMIZE THE-FORM)) (FORM (EXPR-FORM THE-FORM)))    (IF (OR (ATOM FORM)    (MEMBER (CAR FORM) '(QUOTE LOCAL-REF SELF-REF LEXICAL-REF FUNCTION BREAKOFF-FUNCTION %POP)    :TEST #'EQ)) ; special forms handled directly by P2(P2 FORM DEST)      (P2F FORM DEST) ) )) (DEFUN (:PROPERTY PROGN-WITH-DECLARATIONS P2) (ARGL DEST)  (LET ((VARS (CAR ARGL)))    (P2PROGN (CDR ARGL) DEST))) (DEFPROP PROGN P2PROGN P2) (DEFPROP DONT-OPTIMIZE P2PROGN P2) (DEFUN P2PROGN (ARGL DEST)  (P2PROG12N (LENGTH ARGL) DEST ARGL)) (DEFUN (:PROPERTY PROG1 P2) (ARGL DEST)  (P2PROG12N 1 DEST ARGL)) (DEFPROP PROG2 P2PROG2 P2) (DEFUN P2PROG2 (ARGL DEST)  (P2PROG12N 2 DEST ARGL)) ;Compile a PROGN or PROG2, etc.  ARGL is the list of argument expressions.;N says which arg is to be returned as the value of the PROGN or PROG2;(equals the length of ARGL for PROGN, or 2 for PROG2, etc.).(DEFUN P2PROG12N (N DEST ARGL)  (PROG ((IDEST DEST))(WHEN (AND (NOT (EQ DEST 'D-IGNORE))   (< N (LENGTH ARGL)))  (SETQ IDEST 'D-PDL))   ;MIGHT COMPILE TEST ON RESULT INDICATORS(SETQ N (1- N))   ;Convert to origin 0.;; Compile the args before the one whose value we want.(DOTIMES (I N)  (P2 (OR (CAR ARGL) '(QUOTE NIL)) 'D-IGNORE)  (POP ARGL));; Compile the arg whose value we want.;; If it's the last arg (this is PROGN),;; make sure to pass along any multiple value target that the PROGN has,;; and to report back how many args were actually pushed.(COND ((AND (NULL (CDR ARGL)) M-V-TARGET)       (COND ((P2MV (OR (CAR ARGL) '(QUOTE NIL)) IDEST M-V-TARGET)      (INCPDLLVL))     ((NUMBERP M-V-TARGET)      (MKPDLLVL (+ PDLLVL M-V-TARGET))      (SETQ M-V-TARGET NIL))     (T (INCPDLLVL)   ;target was THROW, RETURN or MULTIPLE-VALUE-LIST(SETQ M-V-TARGET NIL))))      ((AND (NULL (CDR ARGL)) BDEST)       (P2BRANCH (OR (CAR ARGL) '(QUOTE NIL)) IDEST BDEST)       (SETQ BDEST NIL)       (WHEN (EQ IDEST 'D-PDL) (INCPDLLVL)))      (T (P2 (OR (CAR ARGL) '(QUOTE NIL)) IDEST) (WHEN (EQ IDEST 'D-PDL)   (INCPDLLVL))))(OR (CDR ARGL) (RETURN NIL));; Compile the remaining args.(DOLIST (ARG (CDR ARGL))  (P2 ARG 'D-IGNORE))(COND  ((NOT (EQ IDEST DEST))   (MOVE-RESULT-FROM-PDL DEST))  ((NOT (EQ DEST 'D-IGNORE))   (OUTF '(MOVE D-PDL PDL-POP))))));Make sure it's really in indicators              ; if IDEST and DEST both D-PDL(DEFUN PUSH-NILS (COUNT) ;;  9/30/85 DNG - Use P2PUSH-CONSTANT.  (DOTIMES (I COUNT)    (P2PUSH-CONSTANT (QUOTE NIL)))) ;;; Functions to gobble multiple values.(DEFPROP MULTIPLE-VALUE-BIND P2MULTIPLE-VALUE-BIND P2) (DEFUN P2MULTIPLE-VALUE-BIND (TAIL DEST)  ;; 01/14/86 DNG - Move the binding of PDLLVL so that it is restored  ;;                after the call to P2PBIND.  This is so that a RETURN out of  ;;                the body won't pop values that have already been %POPped.  ;;  1/22/86 DNG - Fix to unbind special variables.  ;;  8/19/86 DNG - Use PUSH-NILS instead of a DO loop generating MOVEs.  (LET ((VLIST (CAR TAIL))NBINDS)    (LET ((PDLLVL PDLLVL)  (MVTARGET (LENGTH VLIST))  (VARS (SECOND TAIL))  (MVFORM (FOURTH TAIL)))      ;; Compile the form to leave N things on the stack.      ;; If it fails to do so, then it left only one, so push the other N-1.      (MKPDLLVL (+ PDLLVL MVTARGET))      (AND (P2MV MVFORM 'D-PDL MVTARGET)   (PUSH-NILS (- MVTARGET 1)))      ;; Now pop them off, binding the variables to them.      ;; Note that the vlist contains the variables      ;; in the original order,      ;; each with an initialization of (%POP).      (SETQ NBINDS (P2PBIND VLIST (THIRD TAIL))))    (LET ((VARS (THIRD TAIL))  (BODY (CDDDDR TAIL))  (PROGDESCS PROGDESCS))      (UNLESS (ZEROP NBINDS);; Push a dummy progdesc so that GOs exiting this form can unbind our specials.(PUSH (MAKE-PROGDESC NAME '(LET)     PDL-LEVEL PDLLVL     NBINDS NBINDS)      PROGDESCS))      (P2PROG12N (LENGTH BODY) DEST BODY))    (UNBIND DEST NBINDS)))(DEFUN (:PROPERTY NTH-VALUE P2) (TAIL DEST)  ;; 10/17/86 DNG - Use NTH instead of ELT so args are not evaled in reverse order.  (IF (AND (QUOTEP (CAR TAIL))   (TYPEP (CADR (CAR TAIL)) '(INTEGER 0)))      (IF (ZEROP (CADR (CAR TAIL)))  (P2 `(VALUES ,(CADR TAIL)) DEST)(PROGN  (P2MV (CADR TAIL) 'D-PDL (1+ (CADR (CAR TAIL))))  (POPPDL 1 (CADR (CAR TAIL)))  (MOVE-RESULT-FROM-PDL DEST)))    (P2 `(NTH ,(CAR TAIL)      (MULTIPLE-VALUE-LIST ,(CADR TAIL)))DEST)))(DEFPROP MULTIPLE-VALUE P2MULTIPLE-VALUE P2) (DEFUN P2MULTIPLE-VALUE (TAIL DEST)  ;;  1/29/86 CLM - Modified for Rel.3 so that if DEST equals d-ignore and  ;;                the first element in variable list is nil, a complex-call-to push  ;;                will be generated instead of a c-c-to-inds  (LET* ((VARIABLES (CAR TAIL)) (DEST1   (IF (AND (NOT (COMPILING-FOR-V2)) (EQ DEST 'D-IGNORE) (NULL (CAR VARIABLES)))       'D-IGNORE     'D-PDL)))    (BLOCK NIL      (COND ((P2MV (CADR TAIL) DEST1 (LENGTH VARIABLES)); NIL if it actually pushes N values.     ;; It didn't push them.  Set the other variables to NIL.     (DOLIST (VAR (CDR VARIABLES))       (AND VAR (P2SETQ-1 VAR '(QUOTE NIL) 'D-IGNORE)))     ;; If the single value was discarded, nothing remains to be done.     (AND (EQ DEST1 'D-IGNORE) (RETURN NIL)))    (T     ;; It really did push N values on the stack.  Pop all but the first off.     (DOLIST (VAR (REVERSE (CDR VARIABLES)))       (IF VAR   (MOVEM-AND-MOVE-TO-DEST VAR 'D-IGNORE) (OUTF '(MOVE D-IGNORE PDL-POP))))))      ;; Now there is only one thing on the stack, which is the value      ;; of the first variable, and the value to be returned by      ;; the call to MULTIPLE-VALUE.      (IF (CAR VARIABLES)  (MOVEM-AND-MOVE-TO-DEST (CAR VARIABLES) DEST)(MOVE-RESULT-FROM-PDL DEST))      NIL))) (DEFPROP MULTIPLE-VALUE-PROG1 P2MULTIPLE-VALUE-PROG1 P2) (DEFUN P2MULTIPLE-VALUE-PROG1 (TAIL DEST)  ;;  4/21/86 CLM - Fix to prevent superfluous RETURN instruction  ;;                from being generated.  ;; 10/08/86 DNG - Fix to not use RETURN-N when only a single value pushed.  ;; 01/16/87 CLM - Fix to handle unbinding of special variables if within a  ;;                CATCH.  (LET (SINGLE-VALUE-RETURN)    (COND ((OR (EQ DEST 'D-RETURN)       (EQ M-V-TARGET 'RETURN-CATCH))   (SETQ SINGLE-VALUE-RETURN (P2MV (CAR TAIL) 'D-PDL 'RETURN))   (UNLESS SINGLE-VALUE-RETURN     (SETQ M-V-TARGET NIL)) )  (M-V-TARGET   (UNLESS (P2MV (CAR TAIL) DEST M-V-TARGET)     (SETQ M-V-TARGET nil)))  (T (P2 (CAR TAIL) (IF (EQ DEST 'D-LAST)     'D-PDL   DEST))))    (DOLIST (FORM (CDR TAIL))      (P2 FORM 'D-IGNORE))    (IF (AND (COMPILING-FOR-V2)     (EQ DEST 'D-RETURN)     (NOT SINGLE-VALUE-RETURN))(OUT-AUX 'RETURN-N)      (WHEN (MEMBER DEST '(D-RETURN D-LAST) :TEST #'EQ)(MOVE-RESULT-FROM-PDL DEST)))));; Note that we make no provision for the possibility;; than anything might want to optimize being compiled;; for multiple-value-list by storing the list directly;; to a destination other than D-PDL.(DEFPROP MULTIPLE-VALUE-LIST P2MULTIPLE-VALUE-LIST P2) (DEFUN P2MULTIPLE-VALUE-LIST (TAIL DEST)  ;;  2/14/86 DNG - Use OUTI instead of OUTF for NCONS.  (IF (P2MV (CAR TAIL) 'D-PDL 'MULTIPLE-VALUE-LIST)      (NO-D-RETURN (OUTM `(MISC ,DEST ,(MISC-LAP-CODE 'NCONS))))    (MOVE-RESULT-FROM-PDL DEST))) (DEFPROP MULTIPLE-VALUE-CALL P2MULTIPLE-VALUE-CALL P2)(DEFUN P2MULTIPLE-VALUE-CALL (FORM DEST)  ;;  9/05/86 CLM - Original.  If there still is a multiple-value-call   ;;                at this point, then there is only a single form in  ;;                the arglist.  Call P2MV with this form and a DEST  ;;                D-PDL and an M-V-TARGET of RETURN so that the values  ;;                returned will be pushed on the stack followed by the  ;;                count.  This sets things up for a CALL-N to the function.  ;; 10/01/86 CLM - Use a CALL-1 instruction for cases where there is only a  ;;                single value returned from P2MV.  ;; 10/20/86 CLM - Undo the previous change; the conversion to CALL-1 is now  ;;                done in PEEP.  (LET (SINGLE-VALUE-RETURN)    (SETQ SINGLE-VALUE-RETURN  (P2MV (SECOND FORM) 'D-PDL 'RETURN))    (WHEN SINGLE-VALUE-RETURN      (P2PUSH-CONSTANT 1))    (OUTI (LIST 'CALL-N DEST (P2-SOURCE (CAR FORM) 'D-PDL)))    ))(DEFPROP *THROW P2THROW P2) (DEFPROP THROW P2THROW P2) (DEFUN P2THROW (TAIL IGNORE)  ;; 10/28/85 CLM - Changed to generate Rel.3 aux-ops %THROW and  ;;                %THROW-N instead of misc-op *THROW.  ;;  2/07/86 CLM - Modified to emit a %close-catch if the throw is  ;;                from within the undo forms of an unwind protect.  ;; 11/17/86 CLM - Increment the pdllvl after pushing the tag so that we  ;;                know it's been pushed in case we exit before the throw  ;;                and have to pop the tag off the stack.  (P2PUSH (CAR TAIL))   ;Compute and push the tag.  (INCPDLLVL)  (IF (COMPILING-FOR-V2)      (LET (SINGLE-VALUE-RETURN)(SETQ SINGLE-VALUE-RETURN      (P2MV (CADR TAIL) 'D-PDL 'THROW))(IF SINGLE-VALUE-RETURN    (OUTI '(AUX %THROW))  (OUTI '(AUX %THROW-N))))    (PROGN      (P2MV (CADR TAIL) 'D-PDL 'THROW)      (OUTI '(MISC D-IGNORE *THROW))))  (SETQ DROPTHRU NIL)) (DEF MULTIPLE-VALUE-PUSH)(DEFPROP MULTIPLE-VALUE-PUSH (&QUOTE NUMBER-OF-VALUES &EVAL EXPRESSION) ARGLIST)(DEFUN (:PROPERTY MULTIPLE-VALUE-PUSH P2) (TAIL DEST)  (DECLARE (IGNORE DEST))  (WHEN (P2MV (CADR TAIL) 'D-PDL (CAR TAIL))   ; NIL if it actually pushes N values.    ;; It didn't push them.  Push extra NILs.    (PUSH-NILS (1- (CAR TAIL))))  (MKPDLLVL (+ PDLLVL (CAR TAIL)))) ;Functions to generate multiple values.(DEFPROP VALUES P2VALUES P2) (DEFUN P2VALUES (ARGL DEST)  ;;  8/21/85 - Use OUT-AUX.  ;;  9/07/85 - Use main-op form of RETURN-2 and RETURN-3.  ;;  9/25/85 - AUX RETURN-0 etc.  ;; 10/28/85 - CLM  Changed to generate Rel.3 aux-ops %THROW  ;;            and %THROW-N instead of misc-ops THROW-N and *THROW.  ;; 12/18/85 - CLM  For rel. 3, modified so that when M-V-TARGET equals  ;;            RETURN the RETURN-N-KEEP-CONTROL misc-op is no longer  ;;            emitted; values and count are pushed on the stack.  ;;  2/17/86 DNG - Use LAP-VALUE instead of GET-FOR-TARGET.  ;;  7/16/86 CLM - No longer generate a throw here; this was causing too  ;;                many throws when there was an intervening CATCH between  ;;                the THROW and its target.  ALSO , when M-V-TARGET is RETURN  ;;                and only one item is in the argl, do not set M-V-TARGET to  ;;                nil; this signals that a single value is being returned.  ;;  9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET.    (BLOCK NIL    ;; Handle returning from the top level of a function.    (WHEN (EQ DEST 'D-RETURN)   (LET ((NARGS (LENGTH ARGL)))     (WHEN (= NARGS 1)       ;; DON'T change this to (P2 ... 'D-RETURN)       ;; because we want to make sure to pass only one value.       (P2 (CAR ARGL) 'D-PDL)       (MOVE-RESULT-FROM-PDL 'D-RETURN)       (RETURN))     (IF (COMPILING-FOR-V2) (COND ((AND (LAP-VALUE 'RETURN-0)     (<= NARGS 63))(ARGLOAD ARGL 'D-PDL)(OUT-AUX 'RETURN-0 NARGS))   ((= NARGS 2)    (P2PUSH (FIRST ARGL))    (LET ((ADR (P2-SOURCE (SECOND ARGL) 'D-PDL)))      (IF (EQ ADR 'PDL-POP)  (OUT-AUX '%RETURN-2)(OUTI `(RETURN-2 0 ,ADR)))))   ((= NARGS 3)    (P2PUSH (FIRST ARGL))    (P2PUSH (SECOND ARGL))    (LET ((ADR (P2-SOURCE (THIRD ARGL) 'D-PDL)))      (IF (EQ ADR 'PDL-POP)  (OUT-AUX '%RETURN-3)(OUTI `(RETURN-3 0 ,ADR)))))   ((ZEROP NARGS)    (P2VALUES-LIST '((QUOTE NIL)) DEST))   (T (ARGLOAD ARGL 'D-PDL)      (P2PUSH-CONSTANT NARGS)      (OUT-AUX '%RETURN-N)))       (PROGN (ARGLOAD ARGL 'D-PDL) (COND ((= NARGS 2) (OUT-AUX '%RETURN-2))       ((= NARGS 3) (OUT-AUX '%RETURN-3))       ((ZEROP NARGS)(P2VALUES-LIST '((QUOTE NIL)) DEST))       (T (P2PUSH-CONSTANT NARGS)  (OUT-AUX '%RETURN-N)))))     (SETQ DROPTHRU NIL)   ;Above MISC RETURN instructions return     (RETURN NIL)))    (COND ((NUMBERP M-V-TARGET)   ;; If we want N values on the stack,   ;; then eval all the args to return   ;; and save exactly N things on the stack.   (DO ((VALS ARGL (CDR VALS))(I 0 (1+ I)))       ((AND (NULL VALS) (>= I M-V-TARGET)))     (P2 (OR (CAR VALS) '(QUOTE NIL)) (IF (>= I M-V-TARGET)     'D-IGNORE   'D-PDL))))  ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST)   (P2 `(LIST . ,ARGL) DEST))  ((EQ M-V-TARGET 'THROW)   (DOLIST (ELT ARGL)     (P2PUSH ELT))   (IF (= (LENGTH ARGL) 1)       (UNLESS (COMPILING-FOR-V2) (OUTM '(MISC D-IGNORE *THROW)) (SETQ DROPTHRU NIL))     (PROGN       (P2PUSH-CONSTANT (LENGTH ARGL))       (UNLESS (COMPILING-FOR-V2) (OUTM '(MISC D-IGNORE THROW-N)) (SETQ DROPTHRU NIL)))     ))  ((MEMBER M-V-TARGET '(RETURN RETURN-CATCH) :TEST #'EQ)   (DOLIST (ELT ARGL)     (P2PUSH ELT))   (IF (= (LENGTH ARGL) 1)       (RETURN)     (P2PUSH-CONSTANT (LENGTH ARGL))))  ((NULL M-V-TARGET)   (LET ((PDLLVL PDLLVL))     (P2PROG12N 1 DEST ARGL))))    (SETQ M-V-TARGET NIL)    NIL))(DEFPROP VALUES-LIST P2VALUES-LIST P2) (DEFUN P2VALUES-LIST (ARGL DEST)  ;;  8/21/85 - For release 3, RETURN-LIST is an Aux-op.  ;;  1/16/86 - CLM For release 3, no longer uses the obsolete  ;;            THROW-SPREAD. Use %SPREAD and then push length   ;;            of the list on the stack.  ;;  1/20/86 - CLM For release 3, no longer uses the obsolete  ;;            %SPREAD-N.  Call P2ARGC with VALUES-LIST as the  ;;            function argument.  ;;  3/19/86 - CLM When M-V-TARGET equals RETURN, spread the ARGL  ;;            and set up for a RETURN-N; no longer uses RETURN-SPREAD-  ;;            KEEP-CONTROL.  ;;  9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET.  (PROG (ARG)(SETQ ARG (CAR ARGL))(COND ((EQ DEST 'D-RETURN)       (IF (COMPILING-FOR-V2)   (PROGN     (P2PUSH ARG)     (OUT-AUX 'RETURN-LIST)     (SETQ DROPTHRU NIL)) (P2MISC 'RETURN-LIST ARGL 'D-RETURN 1)))      ((NULL M-V-TARGET)       (P2 `(CAR ,ARG) DEST))      ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST)       (P2 ARG DEST))      ((EQ M-V-TARGET 'THROW)       ;;added 1/16/86 by CLM       (IF (COMPILING-FOR-V2)   (PROGN     #+compiler:debug     (ASSERT (TRIVIAL-FORM-P ARG) ()     "A NON-TRIVIAL ARG WAS PASSED TO P2VALUES-LIST")     (P2PUSH ARG)     (OUT-AUX '%SPREAD)     (P2PUSH ARG)     (OUTM '(MISC D-PDL LENGTH)))  ;STACK IS SET FOR A THROW-N (PROGN   (P2PUSH ARG)   (OUTM '(MISC D-IGNORE THROW-SPREAD)))))      ((MEMBER M-V-TARGET '(RETURN RETURN-CATCH) :TEST #'EQ)       (IF (COMPILING-FOR-V2)   (PROGN     #+compiler:debug     (ASSERT (TRIVIAL-FORM-P ARG) ()     "A NON-TRIVIAL ARG WAS PASSED TO P2VALUES-LIST")     (P2PUSH ARG)     (OUT-AUX '%SPREAD)     (P2PUSH ARG)     (OUTM '(MISC D-PDL LENGTH)))  ;STACK SET FOR A RETURN-N (PROGN   (P2PUSH ARG)   (OUTM '(MISC D-IGNORE RETURN-SPREAD-KEEP-CONTROL)))))      ((NUMBERP M-V-TARGET)       ;;added 1/20/86 by CLM       (IF (COMPILING-FOR-V2)   (P2ARGC NIL ARGL NIL DEST 'VALUES-LIST) (PROGN   (NEEDPDL 2)   (P2PUSH ARG)   (P2PUSH-CONSTANT M-V-TARGET)   (OUTF '(MISC D-PDL %SPREAD-N))))))(SETQ M-V-TARGET NIL)))(DEFUN (:PROPERTY UNWIND-PROTECT P2) (FORMS DEST)  ;;  11/17/85 CLM - MODIFIED FOR REL. 3.  NOW EMITS AUX-OPS  ;;                 %OPEN-CATCH, %OPEN-CATCH-MULTIPLE-VALUE  ;;                 AND %CLOSE-CATCH INSTEAD OF FORMER MISC-OPS  ;;                 TO CREATE AND THEN REMOVE A CATCH BLOCK.  ;;  12/05/85 CLM - MODIFIED FOR REL.3 TO HANDLE CASES WHERE  ;;                 M-V-TARGET EQUALS 'THROW, 'RETURN OR 'MULTIPLE-  ;;                 VALUE-LIST, AND THOSE CASES WHERE DEST EQUALS  ;;                 'D-RETURN.  ;;   1/30/86 CLM - For Rel.3, modified to handle cases where there  ;;                 is a return from within an unwind-protect.  Cleanup  ;;                 forms are now handled as a subroutine using the  ;;                 LONG-PUSHJ and POPJ instructions.  ;;   2/05/86 CLM - An addendum to the above modification.  This handles  ;;                 returns from within the cleanup-forms, and has the  ;;                 restart-pc point to a pushj to the undo-forms.  ;;   4/21/86 CLM - If DEST equals D-IGNORE then instead of an %open-catch  ;;                 generate an %open-catch-multiple-value instruction with  ;;                 an argument of 0 to indicate no values are expected.  ;;   5/07/86 CLM - In the case where only a single value is to be returned,  ;;                 do a multiple-value return with 1 as the number values.  ;;                 Also, the catch-block is now 5 words long.  ;;   5/29/86 CLM - Use the constant CATCH-BLOCK-SIZE instead of the number 5.  ;;   6/20/86 CLM - Add special handling for an M-V-TARGET of MULTIPLE-VALUE-LIST.  ;;                 Also, fix to reset PDLLVL after the clean-up forms, instead  ;;                 of before.  This was causing problems when there was a return   ;;                 from within the clean-up forms  ;;   7/15/86 CLM - Add more special handling for cases where multiple-values are  ;;                 expected, but only a single value is generated.  ;;   9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET.  ;;  11/17/86 CLM - Changed to handle the new microcode scheme for Unwind-protects.  ;;                 There are now separate mcr funtions to open and close an unwind-  ;;                 protects.  We now also take special note of the pdllvl upon  ;;                 entry to the undo forms to handle exits from them.  (LET ((RESTART-TAG (GENSYM))(UNDO-TAG (GENSYM))(EXIT-TAG (WHEN (OR (COMPILING-FOR-V2)    M-V-TARGET)    (GENSYM)))(PDLLVL0 PDLLVL)SINGLE-VALUE-RETURN)    (IF (COMPILING-FOR-V2)(LET ((CALL-BLOCK-PDL-LEVELS CALL-BLOCK-PDL-LEVELS)      (WITHIN-CATCH T))  (P2PUSH-CONSTANT T)   ;CATCH-TAG  (OUTI1 (LIST 'MOVE 'D-PDL   ;RESTART-PC       `(QUOTE-VECTOR (TAG ,RESTART-TAG))))  (COND    ((EQ DEST 'D-RETURN)     (P2PUSH-CONSTANT NIL)     (OUTF '(AUX %OPEN-CATCH-MULTIPLE-VALUE)))    ((EQ DEST 'D-IGNORE)     (P2PUSH-CONSTANT 0)     (OUT-AUX '%OPEN-CATCH-MULTIPLE-VALUE))    ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST)     (OUTF '(AUX %OPEN-CATCH-MV-LIST)))    ((OR (EQ M-V-TARGET 'THROW) (EQ M-V-TARGET 'RETURN) (EQ M-V-TARGET 'RETURN-CATCH))     (P2PUSH-CONSTANT NIL)     (OUTF '(AUX %OPEN-CATCH-MULTIPLE-VALUE)))    ((NUMBERP M-V-TARGET)     (P2PUSH-CONSTANT M-V-TARGET)     (OUTF '(AUX %OPEN-CATCH-MULTIPLE-VALUE)))    (T (OUTF '(AUX %OPEN-CATCH))))  ;;This causes a problem in the new scheme, so it has been  ;;removed.  So far its removal has caused no problems.  #|(COND    ((NULL M-V-TARGET))    ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST)     (INCPDLLVL))    ((NUMBERP M-V-TARGET)     (MKPDLLVL (+ PDLLVL M-V-TARGET))))          |#  (PUSH (LIST PDLLVL 'UNWIND-PROTECT UNDO-TAG)CALL-BLOCK-PDL-LEVELS)  (MKPDLLVL (+ CATCH-BLOCK-SIZE PDLLVL))      ;words of call block  (COND    ((EQ DEST 'D-RETURN)     (SETQ SINGLE-VALUE-RETURN (P2MV (CAR FORMS) 'D-PDL 'RETURN)))    ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST)     (WHEN       (P2MV (CAR FORMS) 'D-PDL M-V-TARGET)       (OUTI '(MISC D-PDL NCONS)) )   ;must convert a single value into a list     )    (M-V-TARGET      (SETQ SINGLE-VALUE-RETURN   (P2MV (CAR FORMS) (IF (EQ DEST 'D-IGNORE)     DEST     'D-PDL) (IF (EQ M-V-TARGET 'RETURN-CATCH)     'RETURN M-V-TARGET))))    (T (P2 (CAR FORMS)   (IF (EQ DEST 'D-IGNORE)       DEST     'D-PDL))))  (SETQ DROPTHRU T)  (WHEN SINGLE-VALUE-RETURN     ;handle all returns as a form of mv-return    (IF (NUMBERP M-V-TARGET)(DOTIMES (I (1- M-V-TARGET))  (P2PUSH-CONSTANT (QUOTE NIL))  (INCPDLLVL))    (P2PUSH-CONSTANT 1)))  (SETQ M-V-TARGET NIL)  ;;the restart-pc now points to the %close-catch-unwind-protect  (OUTF `(RESTART-TAG ,RESTART-TAG))  (OUT-AUX '%CLOSE-CATCH-UNWIND-PROTECT)  (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE))  (OUTB `(BRANCH PUSHJ NIL NIL ,UNDO-TAG))  (IF (EQ DEST 'D-RETURN)      (PROGN(OUT-AUX '%UNWIND-PROTECT-CONTINUE)(OUT-AUX 'RETURN-N)(SETQ DROPTHRU NIL))    (PROGN      (OUT-AUX '%UNWIND-PROTECT-CONTINUE)      (UNLESS (EQ DEST 'D-IGNORE)(MOVE-RESULT-FROM-PDL DEST))))  (OUTB `(BRANCH ALWAYS NIL NIL ,EXIT-TAG))  (SETQ DROPTHRU T)  (OUTF UNDO-TAG)  ;;add a tag to call-block-pdl-levels to indicate  ;;you are in the undo forms  (NCONC (CAR CALL-BLOCK-PDL-LEVELS) '(UNDO))  ;;also now need to keep track of the pdllvl of the  ;;undo forms so that can pop any garbage off stack before  ;;doing an %unwind-protect-cleanup if there is some type of  ;;return out of the undo forms.  This is not necessary if the   ;;unwind-protect is at top level.  (WHEN PROGDESCS(SETF (PROGDESC-UNDO-PDL-LEVEL (FIRST PROGDESCS))      (CONS PDLLVL (PROGDESC-UNDO-PDL-LEVEL (FIRST PROGDESCS)))))  (INCPDLLVL)  ;;inc for the restart-macro-pc pushed on the stack by long-pushj  (DOLIST (FORM (CDR FORMS))   ;cleanup forms    (P2 FORM 'D-IGNORE))  (OUT-AUX 'POPJ)  (SETQ DROPTHRU NIL)  (OUTTAG EXIT-TAG)  ;;why does it reset the pdllvl to the original level?  ;;what about the values left on the stack  ;;i think because this hasn't broken anything it would  ;;indicate that it doesn't matter  (SETQ PDLLVL PDLLVL0)  )      ;;the vm1 version      (let ((pdllvl0 pdllvl))(LET ((CALL-BLOCK-PDL-LEVELS CALL-BLOCK-PDL-LEVELS)      (WITHIN-CATCH T))  (OUTI1    `(ADI-CALL CALL D-IGNORE (QUOTE-VECTOR (FUNCTION *CATCH))       (RESTART-PC (QUOTE-VECTOR (TAG ,RESTART-TAG))   BIND-STACK-LEVEL NIL MULTIPLE-VALUE   (QUOTE-VECTOR '4))))  (MKPDLLVL (+ PDLLVL 10))   ;4 MULTIPLE VALUE WORDS, 6 ADI WORDS  (PUSH (LIST PDLLVL 'UNWIND-PROTECT RESTART-TAG)CALL-BLOCK-PDL-LEVELS)  (MKPDLLVL (+ 4 PDLLVL))   ;4 WORDS OF CALL BLOCK  (P2 ''T 'D-PDL)   ;CATCH TAG IS T  (INCPDLLVL)  (COND    ((NUMBERP M-V-TARGET)     (WHEN (P2MV (CAR FORMS) 'D-PDL M-V-TARGET)       (PUSH-NILS (1- M-V-TARGET)))     (POPPDL M-V-TARGET (- PDLLVL PDLLVL0))     (OUTB `(BRANCH ALWAYS NIL NIL ,EXIT-TAG)))    ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST)     (IF (P2MV (CAR FORMS) 'D-PDL M-V-TARGET) (OUTI '(MISC D-LAST NCONS))       (OUTI '(MOVE D-LAST PDL-POP))))    ((OR (EQ M-V-TARGET 'THROW) (EQ M-V-TARGET 'RETURN))     (P2MV (CAR FORMS) 'D-PDL M-V-TARGET)     (OUTI '(MOVE D-LAST PDL-POP)))    (T (P2 (CAR FORMS) (IF (EQ DEST 'D-RETURN)   DEST 'D-LAST))))  (SETQ M-V-TARGET NIL)  (SETQ PDLLVL (+ PDLLVL0 4))   ;NOW HAVE JUST 4 MULTIPLE VALUES ON STACK  (SETQ DROPTHRU T)  (OUTF `(RESTART-TAG ,RESTART-TAG)))(DOLIST (FORM (CDR FORMS))   ;CLEANUP FORMS  (P2 FORM 'D-IGNORE))(SETQ PDLLVL PDLLVL0)(OUTI `(MISC ,DEST %UNWIND-PROTECT-CONTINUE))(WHEN EXIT-TAG  (OUTF EXIT-TAG))))))(DEFUN (:PROPERTY %MAKE-EXPLICIT-STACK-LIST P2) (FORMS DEST)  (ARGLOAD FORMS 'D-PDL)  (P2PUSH-CONSTANT (LENGTH FORMS))  (OUTI `(MISC ,DEST %MAKE-EXPLICIT-STACK-LIST))) (DEFUN (:PROPERTY %MAKE-EXPLICIT-STACK-LIST* P2) (FORMS DEST)  (ARGLOAD FORMS 'D-PDL)  (P2PUSH-CONSTANT (LENGTH FORMS))  (OUTI `(MISC ,DEST %MAKE-EXPLICIT-STACK-LIST*))) (DEFUN (:PROPERTY LET* P2) (ARGL DEST)  ;;  7/15/86 DNG - Add binding of CLOSURE-DISCONNECT-OFFSETS and LEXICAL-CLOSURE-COUNT.  (LET ((VARS (CADR ARGL))(CLOSURE-DISCONNECT-OFFSETS NIL)(LEXICAL-CLOSURE-COUNT LEXICAL-CLOSURE-COUNT)(KEEP-CURRENT-FRAME KEEP-CURRENT-FRAME))    (P2LET-INTERNAL VARS (P2SBIND (CAR ARGL) (CADDR ARGL) VARS) ARGL DEST)))(DEFPROP LET P2LET P2)(DEFPROP LET-FOR-LAMBDA P2LET P2)(DEFUN P2LET (ARGL DEST)  ;;  7/07/86 DNG - Use same handler for LET and LET-FOR-LAMBDA.  ;;  7/15/86 DNG - Add binding of CLOSURE-DISCONNECT-OFFSETS and LEXICAL-CLOSURE-COUNT.  (LET ((VARS (CADR ARGL))(CLOSURE-DISCONNECT-OFFSETS NIL)(LEXICAL-CLOSURE-COUNT LEXICAL-CLOSURE-COUNT)(KEEP-CURRENT-FRAME KEEP-CURRENT-FRAME))    (P2LET-INTERNAL VARS (P2PBIND (CAR ARGL) (CADDR ARGL)) ARGL DEST))) ;LET-HACK is generated by LET-INTERNAL in case of lexical closures and WITHIN-CATCH.(DEFUN (:PROPERTY LET-HACK P2) (ARGL DEST)  (LET ((VARS (CAR ARGL)))    (P2LET-INTERNAL VARS (CADR ARGL) (CADDR ARGL) DEST T))) ;Compile the body of a LET.  The variable binding has already been done;by P1PBIND or P1SBIND, which returned the number of special bindings made;which is our argument NBINDS.(DEFUN P2LET-INTERNAL (OVARS NBINDS ARGL DEST &OPTIONAL IGNORE-LEXICAL-CLOSURES)  ;;  2/06/86 DNG - Move the result value of the LET to its proper destination  ;;    after any lexical closure disconnect or unshare instructions  ;;    so that the indicators will be correct for any conditional  ;;    branch which may follow.  [SPR 1075]  ;;  5/23/86 CLM - When M-V-TARGET equals RETURN, don't issue unbind instructions.  ;;                This was causing a problem when returning the result  ;;                of a CATCH.  ;;  7/15/86 DNG - Fix to unshare variables used in lexical closures created  ;;at lower levels.  ;;  7/16/86 DNG - Fix to use D-PDL instead of D-INDS when a STACK-CLOSURE-UNSHARE  ;;is possible so the indicators don't get clobbered.  [SPR 2571]  ;;  9/02/86 DNG - For VM2, need to unbind specials even when M-V-TARGET is RETURN.  ;;  9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET.  This value  ;;                indicates that special variables should not be unbound.  ;;  9/13/86 DNG - Modify check for %BIND with multiple values to issue a warning but  ;;not do any unbinding when M-V-TARGET is RETURN.  ;; 12/15/86 DNG - Save special-pdl-index in a local variable when it can't  ;;be kept on the stack because of an unknown number of values.  (IF (AND WITHIN-CATCH   (NOT IGNORE-LEXICAL-CLOSURES)   (OR (NEQ (FIFTH ARGL) (SIXTH ARGL))       (NOT (NULL CLOSURE-DISCONNECT-OFFSETS))))      (P2F`(UNWIND-PROTECT (LET-HACK ,OVARS ,NBINDS ,ARGL)   (DISCONNECT-STACK-CLOSURES ,(FIFTH ARGL) ,(SIXTH ARGL))   (UNSHARE-STACK-CLOSURE-VARS ,VARS ,OVARS))DEST)    (LET* ((VARS (THIRD ARGL))   (IBINDP (FOURTH ARGL))   (ENTRY-LEXICAL-CLOSURE-COUNT (FIFTH ARGL))   (EXIT-LEXICAL-CLOSURE-COUNT (SIXTH ARGL))   (BDY (NTHCDR 6 ARGL))   (IDEST 'D-PDL)   NVALUES   M-V-DONE   (PROGDESCS PROGDESCS))      ;; Determine the immediate destination of returns in this prog.      (WHEN (AND (MEMBER DEST '(D-IGNORE D-INDS D-RETURN) :TEST #'EQ) (NULL M-V-TARGET) (NOT   (AND (NEQ DEST 'D-RETURN)(NOT IGNORE-LEXICAL-CLOSURES)(OR (/= ENTRY-LEXICAL-CLOSURE-COUNT EXIT-LEXICAL-CLOSURE-COUNT)    (AND TAGOUT (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES  *CURRENT-COMPILAND*)))(NOT (COMPILING-FOR-V2)))))(SETQ IDEST DEST))      ;; If BIND is used within this LET, and it's an internal LET,      ;; we must push the specpdl index at entry so we can unbind to it later.      (WHEN IBINDP   ;**** was (AND IBINDP (NOT (EQ DEST 'D-RETURN))) ****(SETQ KEEP-CURRENT-FRAME T)(OUTM '(MISC D-PDL SPECIAL-PDL-INDEX))(IF (CONSP IBINDP) ; P1LET has provided a place to save the index    (OUTI `(POP 0 ,(P2-DESTINATION IBINDP)))  ;; else leave it on the stack.  (INCPDLLVL)))      ;; Push a dummy progdesc so that GOs exiting this LET can unbind our specials.      (PUSH (MAKE-PROGDESC NAME '(LET)   PDL-LEVEL PDLLVL   NBINDS (IF IBINDP      (IF (CONSP IBINDP)  (LIST NBINDS IBINDP)(LIST NBINDS))    NBINDS))    PROGDESCS)      (WHEN (AND (EQ M-V-TARGET 'THROW) (NOT (COMPILING-FOR-V2)) IBINDP (ATOM IBINDP));; In case we are going to generate a throw from a handler invoked within the;; LET body, need to have the throw tag on top of the stack, so copy it above;; the special-pdl-index.(P2PUSH-CONSTANT 1)(OUTM '(MISC D-PDL PDL-WORD)))      ;; How many words are we supposed to leave on the stack?      (SETQ NVALUES (COND      ((NUMBERP M-V-TARGET) M-V-TARGET)      ((EQ IDEST 'D-PDL) 1)      (T 0)))      (UNLESS BDY(SETQ BDY '((QUOTE NIL))))      (DO ((TAIL BDY (CDR TAIL)))  ((NULL (CDR TAIL))   (UNLESS (P2MV (CAR TAIL) IDEST M-V-TARGET)     (SETQ M-V-DONE T)))(P2 (CAR TAIL) 'D-IGNORE))      (UNLESS M-V-DONE(SETQ NVALUES 1))      ;; If this is a top-level PROG, we just went to D-RETURN, so we are done.      (UNLESS (EQ DEST 'D-RETURN);; Unbind any locals that need to be unbound.(UNLESS IGNORE-LEXICAL-CLOSURES (LET ((CLOBBERED-INDICATORS NIL))   (WHEN (AND (OR (/= ENTRY-LEXICAL-CLOSURE-COUNT EXIT-LEXICAL-CLOSURE-COUNT)  (NOT (NULL CLOSURE-DISCONNECT-OFFSETS)))      (NOT (COMPILING-FOR-V2)))     (P2 `(DISCONNECT-STACK-CLOSURES ,ENTRY-LEXICAL-CLOSURE-COUNT     ,EXIT-LEXICAL-CLOSURE-COUNT) 'D-IGNORE)     (SETQ CLOBBERED-INDICATORS T))   (WHEN (AND TAGOUT      (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES *CURRENT-COMPILAND*))     (P2 `(UNSHARE-STACK-CLOSURE-VARS ,VARS ,OVARS) 'D-IGNORE)     (SETQ CLOBBERED-INDICATORS T))   (WHEN (AND CLOBBERED-INDICATORS      (EQ DEST IDEST)      (EQ DEST 'D-PDL)      (NOT (COMPILING-FOR-V2)))     ;; Restore the indicator value which was destroyed by the disconnect     ;; instruction in case a conditional branch comes next.  The peephole     ;; optimizer will delete this instruction if it turns out to not     ;; really be needed.     (OUTI '(MOVE D-PDL PDL-POP)) )))(WHEN (AND (EQ M-V-TARGET 'THROW) (NOT (COMPILING-FOR-V2)) IBINDP (ATOM IBINDP))  (POPPDL NVALUES 1));; Unbind any specials;; 5/23/86 (UNLESS (OR (EQ M-V-TARGET 'RETURN-CATCH)    (AND (EQ M-V-TARGET 'RETURN) (NOT (COMPILING-FOR-V2))) )  (BLOCK UNBIND    (COND ((NULL IBINDP))  ((CONSP IBINDP)   (P2PUSH IBINDP)   (OUTPUT-UNBIND-TO-INDEX 0))  (T   (UNLESS (OR (NULL M-V-TARGET)       (NUMBERP M-V-TARGET))     (IF (EQ M-V-TARGET 'RETURN) (PROGN (WARN 'LET-INTERNAL :IMPLAUSIBLE  "Warning: %BIND within form producing unknown number of values will not beunbound until returning from the function.")(RETURN-FROM UNBIND))       (WARN 'let-internal :IMPLEMENTATION-LIMIT  "The use of %BIND within a form that produces an unknown number of values iscurrently unsupported")))   (OUTPUT-UNBIND-TO-INDEX NVALUES)))    (UNBIND IDEST NBINDS) ));; Dispose of our value.(AND (NEQ DEST IDEST)     (NULL M-V-TARGET)     (MOVE-RESULT-FROM-PDL DEST));; If we produced multiple values, say we did.(WHEN M-V-DONE  (SETQ M-V-TARGET NIL))))));These two do not occur in code except as generated by P2PROG-INTERNAL.;They are almost a kind of macro for use in pass 2.(DEFUN (:PROPERTY DISCONNECT-STACK-CLOSURES P2) (ARGL IGNORE)  ;;  1/9/86 - Not applicable to VM2.  ;; 7/15/86 - Redesigned to use CLOSURE-DISCONNECT-OFFSETS. [from Compiler patch 2.6]  (UNLESS (COMPILING-FOR-V2)    (LET ((ENTRY-LEXICAL-CLOSURE-COUNT (CAR ARGL));;(EXIT-LEXICAL-CLOSURE-COUNT (CADR ARGL))  )      ;; -- new way 4/30/86 --      (DOLIST ( OFFSET (REVERSE CLOSURE-DISCONNECT-OFFSETS) )(OUTI `(,(IF (= OFFSET (+ (LENGTH (COMPILAND-LOCAL-MAP *CURRENT-COMPILAND*))  (* 4 ENTRY-LEXICAL-CLOSURE-COUNT)))     'STACK-CLOSURE-DISCONNECT-FIRST   'STACK-CLOSURE-DISCONNECT),OFFSET)))      #|  -- old way      (DO ((I ENTRY-LEXICAL-CLOSURE-COUNT (1+ I)))  ((= I EXIT-LEXICAL-CLOSURE-COUNT))(OUTI  `(,(IF (= I ENTRY-LEXICAL-CLOSURE-COUNT) 'STACK-CLOSURE-DISCONNECT-FIRST       'STACK-CLOSURE-DISCONNECT)    ,(+ (LENGTH (COMPILAND-LOCAL-MAP *CURRENT-COMPILAND*))(* 4 I))))))      |#      )))(DEFUN (:PROPERTY UNSHARE-STACK-CLOSURE-VARS P2) (ARGL IGNORE)  ;;  7/12/85 - Unshare only when there is a possibility of looping  ;;            back and binding the same variables to new values.  ;;  1/09/85 - For rel3, use LEXICAL-UNSHARE instead of STACK-CLOSURE-UNSHARE.  ;;  2/21/86 - Use LEXICAL-UNSHARE-ALL instruction.  ;;  7/07/86 - Obtain VARIABLES-USED-IN-LEXICAL-CLOSURES from *CURRENT-COMPILAND*.  ;; 11/19/86 - Pop deleted variables off OVARS so that the loop termination test  ;;(EQ VS OVARS) works properly -- they won't be in VARS if the LET  ;;that created them was completly optimized away.  (WHEN TAGOUT   ; may be within a loop    (LET ((VARS (CAR ARGL))  (OVARS (CADR ARGL))  (UNSHARE-VARS NIL))      (LOOP WHILE (EQ (VAR-KIND (FIRST OVARS)) 'FEF-ARG-DELETED)    DO (POP OVARS))      (DO ((VS VARS (CDR VS)))  ((OR (EQ VS OVARS)       (NULL VS))   (DEBUG-ASSERT (EQ VS OVARS)))(LET ((V (CAR VS)))  (WHEN (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC V) :TEST #'EQ)    (PUSH V UNSHARE-VARS))))      (UNLESS (NULL UNSHARE-VARS)(LET (( VARIABLES-USED-IN-LEXICAL-CLOSURES       (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES *CURRENT-COMPILAND*) ))  (DECLARE (UNSPECIAL VARIABLES-USED-IN-LEXICAL-CLOSURES)   (TYPE LIST VARIABLES-USED-IN-LEXICAL-CLOSURES))  (IF (AND (COMPILING-FOR-V2)   (= (LENGTH UNSHARE-VARS)      (LENGTH VARIABLES-USED-IN-LEXICAL-CLOSURES)))      (OUTI '(AUX LEXICAL-UNSHARE-ALL))    (DOLIST (V UNSHARE-VARS)      (OUTI(LIST (IF (COMPILING-FOR-V2)  'LEXICAL-UNSHARE'STACK-CLOSURE-UNSHARE)      (POSITION V (THE LIST VARIABLES-USED-IN-LEXICAL-CLOSURES):TEST #'EQ)))))))))) ;Compile a BLOCK.;A BLOCK has no user-defined GOTAGS, but it does have one tag at this level: its rettag.(DEFPROP BLOCK P2BLOCK P2) (DEFUN P2BLOCK (ARGL DEST &OPTIONAL BIND-RETPROGDESC D-INDS-LOSES)  ;;  7/03/86 DNG - Eliminate binding of RETPROGDESC since it is now handled in pass 1.  ;; 10/18/86 DNG - RETTAG is now a structure instead of a symbol; don't need GOTAGS anymore.  (DECLARE (IGNORE BIND-RETPROGDESC)) ; no longer used  (LET* ((MYGOTAGS (CAR ARGL)) (MYPROGDESC (CADR ARGL)) (BDY (CDDR ARGL)) (RETTAG (PROGDESC-RETTAG MYPROGDESC)) (PROGDESCS (CONS MYPROGDESC PROGDESCS)) )    (PROG (IDEST NVALUES)  ;; Determine the immediate destination of returns in this prog.  (SETQ IDEST 'D-PDL)  (AND (MEMBER DEST '(D-IGNORE D-INDS D-RETURN) :TEST #'EQ)       (NOT (AND (EQ DEST 'D-INDS) D-INDS-LOSES))       (NULL M-V-TARGET)       (SETQ IDEST DEST))  ;; How many words are we supposed to leave on the stack?  (SETQ NVALUES (COND  ((NUMBERP M-V-TARGET) M-V-TARGET)  ((EQ IDEST 'D-PDL) 1)  (T 0)))  (SETF (PROGDESC-IDEST MYPROGDESC) IDEST)  (SETF (PROGDESC-M-V-TARGET MYPROGDESC) M-V-TARGET)  (SETF (PROGDESC-PDL-LEVEL MYPROGDESC) PDLLVL)  (SETF (PROGDESC-NBINDS MYPROGDESC) 0)  ;; Set the GOTAG-PDL-LEVEL of each the rettag.  ;; MYGOTAGS contains the RETTAG and nothing else.  (SETF (GOTAG-PROGDESC (CAR MYGOTAGS)) (CAR PROGDESCS))  (SETF (GOTAG-PDL-LEVEL (CAR MYGOTAGS)) (+ PDLLVL NVALUES))  ;; Generate code for the body.  (IF (NULL BDY)      (P2RETURN-FROM `(,MYPROGDESC (QUOTE NIL)) 'D-IGNORE)    (DO ((TAIL BDY (CDR TAIL)))((NULL (CDR TAIL)) (P2RETURN-FROM (LIST MYPROGDESC (CAR TAIL)) 'D-IGNORE))      (P2 (CAR TAIL) 'D-IGNORE)))  ;; If this is a top-level BLOCK, we just went to D-RETURN,  ;; and nobody will use the RETTAG, so we are done.  (AND (EQ DEST 'D-RETURN)       (RETURN NIL))  ;; Otherwise, this is where RETURNs jump to.  (SETQ PDLLVL (GOTAG-PDL-LEVEL (CAR MYGOTAGS)))  (OUTTAG (GOTAG-PROG-TAG RETTAG))  ;; Store away the value if  ;; it is not supposed to be left on the stack.  (AND (NEQ DEST IDEST)       (NULL M-V-TARGET)       (MOVE-RESULT-FROM-PDL DEST))  ;; If we were supposed to produce multiple values, we did.  (SETQ M-V-TARGET NIL)))) ;; This differs from block only when DEST is D-INDS.;; In that case, this one compiles the value to the PDL,;; then moves it to D-INDS after popping off any excess pdl words;; underneath it.  BLOCK would compile the value direct to D-INDS,;; which loses if words must be popped off the stack on falling thru.;; However, that is something that cannot happen for user BLOCKs.;; It can happen only for the weird BLOCK body that WITH-STACK-LIST generates.(DEFUN (:PROPERTY BLOCK-FOR-WITH-STACK-LIST P2) (ARGL DEST)  (LET ((KEEP-CURRENT-FRAME T))    (P2BLOCK ARGL DEST NIL T))) (DEFUN (:PROPERTY BLOCK-FOR-PROG P2) (ARGL DEST)  (P2BLOCK ARGL DEST T)) ;;;  RETURN processing --;;;  pass 1 has changed all varieties of RETURN to (RETURN-FROM progdesc value);;;(DEFPROP RETURN-FROM P2RETURN-FROM P2) (DEFUN P2RETURN-FROM (ARGL IGNORE)  ;;  1/30/86 CLM - For Rel.3, modified to handle cases where there is a  ;;                return from within a CATCH or an UNWIND-PROTECT.  ;;  2/05/86 CLM - An addendum to the above modification.  This handles  ;;                returns from within the undo forms of unwind-protect's.  ;;  2/12/86 CLM - Bind pdllvl to itself upon entry.  ;;  2/12/86 DNG - Decrement PDLLVL and NPOPS by 4 for each %CLOSE-CATCH.  ;;  2/14/86 DNG - Use OUTI instead of OUTF for NCONS.  ;;  3/11/86 CLM - Added special handling for when mvtarget equals return.  ;;  5/07/86 CLM - If mvtarget equals RETURN and a single value is being  ;;                returned, push 1 on the stack to set up for a RETURN-N.  ;;  7/16/86 CLM - Use the global variable CATCH-BLOCK-SIZE.  ;;  8/28/86 CLM - Fix so that if RPDESC is null, just return from the function  ;;  9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET.  ;; 10/18/86 DNG - RETTAG is now a structure instead of a symbol.  ;; 11/17/86 CLM - Changed to handle new UNWIND-PROTECT's.  ;; 11/24/86 CLM - Fix so that a return from a block generated within the undo forms is  ;;                not treated as a return from the undo forms.  (LET ((RPDESC (FIRST ARGL))   ; prog descriptor to return from. (ARG (SECOND ARGL))   ; value to be returnedIPROGDESTMVTARGETSINGLE-VALUE-RETURNNVALUES(PDLLVL PDLLVL)(CALL-BLOCK-PDL-LEVELS CALL-BLOCK-PDL-LEVELS))    (IF (NULL RPDESC);; Only get here in case of an error which has already;;  been reported in pass 1.  Just return from the function.(SETQ IPROGDEST 'D-RETURN)      ;; Else get info for the referenced block.      (PROGN(SETQ IPROGDEST (PROGDESC-IDEST RPDESC))(SETQ MVTARGET (PROGDESC-M-V-TARGET RPDESC))))    ;; If going to throw values, things expect tag on top of stack.  So copy it to there.    (WHEN (EQ MVTARGET 'THROW)      (UNLESS (= PDLLVL (PROGDESC-PDL-LEVEL RPDESC))(P2PUSH-CONSTANT (- PDLLVL (PROGDESC-PDL-LEVEL RPDESC)))(OUTI '(MISC D-PDL PDL-WORD))(INCPDLLVL)))    ;; Compile the arg with same destination and m-v-target    ;; that the PROG we are returning from had.    ;;If there is a return from within an unwind-protect or a catch,    ;;handle it as follows.    (COND ((AND (COMPILING-FOR-V2)       (OR (AND RPDESC      (EQ IPROGDEST 'D-RETURN)      (NOT (NULL CALL-BLOCK-PDL-LEVELS))      (<= (PROGDESC-PDL-LEVEL RPDESC)  (IF (CONSP (CAR CALL-BLOCK-PDL-LEVELS))      (CAAR CALL-BLOCK-PDL-LEVELS)      (CAR CALL-BLOCK-PDL-LEVELS)))) (MEMBER MVTARGET '(RETURN RETURN-CATCH) :TEST #'EQ)  ))  (LET ((UNDO-PDL-LEVEL (PROGDESC-UNDO-PDL-LEVEL (FIRST PROGDESCS))))    ;;return-catch prevents P2LET-INTERNAL from trying to unbind    ;;special variables.    ;;    ;;new unwind-protect scheme - if within the undo forms must     ;;do an unwind-protect-cleanup before the returned form is     ;;compiled.  This requires cleaning off the stack so that    ;;the unwind-protect-cleanup works properly.    ;;UNDO-PDL-LEVEL is a list of all undo pdlplvl's processed so far.    (WHEN (AND (CONSP (CAR CALL-BLOCK-PDL-LEVELS))       (EQ (CADAR CALL-BLOCK-PDL-LEVELS) 'UNWIND-PROTECT)       (EQ (CAR (LAST (CAR CALL-BLOCK-PDL-LEVELS))) 'UNDO)       UNDO-PDL-LEVEL)(OUT-AUX 'POP-PDL (- PDLLVL     (CAR UNDO-PDL-LEVEL)))(OUT-AUX '%UNWIND-PROTECT-CLEANUP)(POP CALL-BLOCK-PDL-LEVELS)(DECF PDLLVL (- PDLLVL (CAR UNDO-PDL-LEVEL)))(POP UNDO-PDL-LEVEL))    (SETQ SINGLE-VALUE-RETURN (P2MV ARG 'D-PDL    (IF (EQ MVTARGET 'RETURN)MVTARGET 'RETURN-CATCH)))    (DO ((L CALL-BLOCK-PDL-LEVELS (CDR L)))((OR (NULL L)     (< (IF (CONSP (CAR L))    (CAAR L)    (CAR L))(PROGDESC-PDL-LEVEL RPDESC))))      ;;If within an unwind-protect,      ;;jump to the cleanup forms subr      ;;unless you're already in the cleanup forms.      ;;If you are returning completely out of the funtion,      ;;you don't have to worry about the stuff left on the      ;;stack by all the intervening %close-catch-unwind-protect's.      (IF (AND (CONSP (CAR L))       (EQ (CADAR L) 'UNWIND-PROTECT))  (UNLESS (EQ (CAR (LAST (CAR L))) 'UNDO)      (PROGN(OUT-AUX '%CLOSE-CATCH-UNWIND-PROTECT)(SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE))(OUTB `(BRANCH PUSHJ NIL NIL ,(CADDAR L)))(OUT-AUX '%UNWIND-PROTECT-CONTINUE)))  (PROGN    (OUT-AUX '%CLOSE-CATCH)    (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE))))      )    (IF (MEMBER MVTARGET '(RETURN RETURN-CATCH) :TEST #'EQ)(PROGN  (WHEN SINGLE-VALUE-RETURN;set up for an ultimate return-n(P2PUSH-CONSTANT 1))  (OUTB `(BRANCH ALWAYS NIL NIL ,(GOTAG-PROG-TAG (PROGDESC-RETTAG RPDESC)))))(PROGN  (IF SINGLE-VALUE-RETURN      ;;a single value      (OUT-AUX '(RETURN 0 PDL-POP))      ;;multiple values      (OUT-AUX 'RETURN-N))  (SETQ DROPTHRU NIL)))) )  ;;This is specifically for a return from an undo.  As above we are  ;;not concerned with items left on the stack by previous unwind-protect  ;;closes.  This means they will be left on the stack, which may present   ;;a problem.  ((AND (COMPILING-FOR-V2)(NOT (NULL CALL-BLOCK-PDL-LEVELS))(CONSP (CAR CALL-BLOCK-PDL-LEVELS))(EQ (CADAR CALL-BLOCK-PDL-LEVELS) 'UNWIND-PROTECT)(EQ (CAR (LAST (CAR CALL-BLOCK-PDL-LEVELS))) 'UNDO)(PROGDESC-UNDO-PDL-LEVEL (FIRST PROGDESCS)))   (LET* ((UNDO-PDL-LEVEL (PROGDESC-UNDO-PDL-LEVEL (FIRST PROGDESCS))) (PDLLVL-DELTA (- PDLLVL (CAR UNDO-PDL-LEVEL))))     (IF (ZEROP PDLLVL-DELTA) (OUT-AUX 'POP-PDL 1) ;haven't pushed anything on the stack but must pop the restart-macro-pc       (OUT-AUX 'POP-PDL PDLLVL-DELTA))     (OUT-AUX '%UNWIND-PROTECT-CLEANUP)     (DECF PDLLVL (IF (ZEROP PDLLVL-DELTA) 1 PDLLVL-DELTA))          (SETQ SINGLE-VALUE-RETURN (P2MV ARG IPROGDEST     MVTARGET))     (POP CALL-BLOCK-PDL-LEVELS)   ;get rid of current one          (DO ((L CALL-BLOCK-PDL-LEVELS (CDR L))) ((OR (NULL L)      (< (IF (CONSP (CAR L))     (CAAR L)     (CAR L)) (PROGDESC-PDL-LEVEL RPDESC))))       ;;if within an unwind-protect,       ;;jump to the cleanup forms subr       ;;unless you're in the cleanup forms.       (IF (AND (CONSP (CAR L))(EQ (CADAR L) 'UNWIND-PROTECT))   (UNLESS (EQ (CAR (LAST (CAR L))) 'UNDO)     (PROGN       (OUT-AUX '%CLOSE-CATCH-UNWIND-PROTECT)       (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE))       (OUTB `(BRANCH PUSHJ NIL NIL ,(CADDAR L)))       (OUT-AUX '%UNWIND-PROTECT-CONTINUE)       ))   (PROGN     (OUT-AUX '%CLOSE-CATCH)     (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE))))       (POP CALL-BLOCK-PDL-LEVELS) )     )   )     (T (SETQ SINGLE-VALUE-RETURN (P2MV ARG IPROGDEST MVTARGET))      ) )    ;; But, since a PROG has multiple returns, we can't simply    ;; pass on to the PROG's caller whether this function did or did not    ;; generate those multiple values if desired.    ;; If the function failed to, we just have to compensate here.    (AND SINGLE-VALUE-RETURN (COND   ((NUMBERP MVTARGET)    ;; If we wanted N things on the stack, we have only 1, so push N-1 NILs.    (PUSH-NILS (- MVTARGET 1)))   ((EQ MVTARGET 'MULTIPLE-VALUE-LIST)    (OUTI '(MISC D-PDL NCONS)))))    (SETQ NVALUES (COND    ((NUMBERP MVTARGET) MVTARGET)    ((EQ IPROGDEST 'D-PDL) 1)    (T 0)))    ;; Note how many things we have pushed.    (AND (EQ IPROGDEST 'D-PDL) (MKPDLLVL (+ PDLLVL NVALUES)))    ;; Jump to the prog's rettag, unless the prog is top-level (to d-return)    ;; since in that case the code just compiled will not ever drop through.    (OR (EQ IPROGDEST 'D-RETURN)(AND (COMPILING-FOR-V2)     (MEMBER MVTARGET '(RETURN RETURN-CATCH) :TEST #'EQ))(OUTBRET (PROGDESC-RETTAG RPDESC) RPDESC NVALUES))))(DEFPROP TAGBODY P2TAGBODY P2) (DEFUN P2TAGBODY (ARGL PROGDEST)  ;;  6/02/86 DNG - Bind TAGOUT to itself so that it indicates whether we  ;;are currently within a loop.  ;; 10/18/86 DNG - Now need to look up tag in MYGOTAGS before calling GTAG.  ;;Don't need GOTAGS anymore.  (LET* ((MYGOTAGS (CAR ARGL)) (BODY (CDR ARGL)) (TAGOUT TAGOUT) (MYPROGDESC (GOTAG-PROGDESC (CAR MYGOTAGS))) (PROGDESCS PROGDESCS)) ;; Remember this TAGBODY's general environment. ;; We supply as the supposed block name ;; a list that will not appear as the block name in any RETURN-FROM. ;; So we can have an entry on the PROGDESCS list to record our tags' pdllvl ;; without interfering with RETURN-FROM.    (WHEN MYGOTAGS      (SETF (PROGDESC-PDL-LEVEL MYPROGDESC) PDLLVL)      (PUSH MYPROGDESC PROGDESCS)      ;; Set the GOTAG-PDL-LEVEL of each of the tags.      (DOLIST (GOTAG MYGOTAGS)(SETF (GOTAG-PDL-LEVEL GOTAG) PDLLVL)))    (DOLIST (STMT BODY)      (COND((ATOM STMT) (UNLESS DROPTHRU (OUTF '(NO-DROP-THROUGH))) (SETQ TAGOUT (SETQ DROPTHRU T)) (OUTF (GTAG (ASSOC STMT MYGOTAGS :TEST #'EQUAL))))(T (P2 STMT 'D-IGNORE))))    (P2 '(QUOTE NIL) PROGDEST))) (DEFPROP GO P2GO P2) (DEFUN P2GO (ARGL IGNORE)  ;;  2/12/86 CLM - Bind pdllvl to itself upon entry.  ;; 10/18/86 DNG - Error checking is now done in pass 1.  (LET ((PDLLVL PDLLVL))    (OUTB1 (CAR ARGL))))(DEFUN (:PROPERTY GO-HACK P2) (ARGL IGNORE)  (OUTB `(BRANCH ALWAYS NIL NIL ,(GOTAG-LAP-TAG (CAR ARGL))))) (DEFUN (:PROPERTY *CATCH P2) (ARGL DEST)  ;;10/22/85  -  CLM  CONVERT CATCHES FROM MISC-OPS TO AUX-OPS.  ;;10/30/85  -  CLM  CHANGED FOR REL.3 TO PREVENT CATCH TAG BEING PUSHED   ;;                  AFTER THE %OPEN-CATCH(-MULTIPLE-VALUE) IS GENERATED.  ;;12/05/85  -  CLM  FOR REL.3 REMOVED ALL REFERENCES TO THE OLD ADI-LIST;  ;;                  NOW HANDLES CASES WHERE M-V-TARGET EQUALS 'THROW, 'RETURN  ;;                  AND 'MULTIPLE-VALUE-LIST OR DEST EQUALS 'D-RETURN.  ;;12/05/85  -  CLM  Modified for Rel.3 - setting the DROPTHRU flag and the PDLLVL.  ;; 2/11/86  -  CLM  Changed to not increment PDLLVL by four for a catch block.  This was  ;;                  causing POPPDL to pop too many words.  ;; 2/12/86  -  CLM  Modified last change to do the same thing in another function.  ;;                  This will solve the problem of too many close-catches being generated.  ;; 2/14/86  -  CLM  Fix to prevent extra push-constant being generated.  ;; 4/21/86  -  CLM  If DEST equals D-IGNORE then instead of an %open-catch  ;;                  generate an %open-catch-multiple-value instruction with  ;;                  an argument of 0 to indicate no values are expected.  ;; 5/07/86  -  CLM  The catch block is now 5 words long.  ;; 5/21/86  -  CLM  When compiling for Rel. 2, a catch within a multiple-value-list  ;;                  form was not being closed upon normal exit (i.e., no throw).  ;;                  This caused a problem when the multiple-value-list form was   ;;                  within an unwind-protect.  This is a fix for SPR 2257.  ;; 5/29/86  -  CLM  Use the constant CATCH-BLOCK-SIZE instead of a number.  ;; 6/06/86  -  CLM  Fixes the fix for SPR 2257.  Also, with an M-V-TARGET of   ;;                  MULTIPLE-VALUE-LIST and a form that returns a single value,  ;;                  ncons the value to create a list; previously only the value  ;;                  was returned, not a list containing the value.  ;; 6/20/86  -  CLM  Add special handling for an M-V-TARGET of MULTIPLE-VALUE-LIST to  ;;                  ensure that a single value will be returned as a list.  ;; 7/15/86  -  CLM  Add more special handling for cases where multiple-values are  ;;                  expected, but only a single value is generated.  ;; 7/16/86  -  CLM  A continuation of the previous fix.  This handles cases where  ;;                  a definite number of values is expected and there is a throw.  ;;                  Let the throw microcode handle cases where the number of values  ;;                  returned is less than expected.  ;; 9/05/86  -  CLM  Introduce a new value for M-V-TARGET: RETURN-CATCH.  This is used  ;;                  when DEST is D-RETURN, and its purpose is to prevent a possible  ;;                  attempt by P2LET-INTERNAL to unbind special variables,  ;;                  which in this situation, would result in an error.    (LET (TDEST  ;TDEST IS DESTINATION ACTUALLY TO BE COMPILED INTO CALL INSTRUCTION.(INITIAL-PDLLVL PDLLVL)RESTART-PCADI-LIST(CALL-BLOCK-PDL-LEVELS CALL-BLOCK-PDL-LEVELS)(WITHIN-CATCH T)SINGLE-VALUE-RETURN)    (UNLESS (COMPILING-FOR-V2)      (COND((NULL M-V-TARGET) (IF (EQ DEST 'D-IGNORE)     (SETQ TDEST 'D-IGNORE)   (IF (AND (EQ DEST 'D-RETURN)    (NOT GENERATING-MICRO-COMPILER-INPUT-P))       (SETQ TDEST 'D-RETURN)     (SETQ TDEST 'D-PDL))))((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST) (SETQ ADI-LIST (CONS M-V-TARGET (CONS NIL ADI-LIST))) (SETQ TDEST 'D-IGNORE))((EQ M-V-TARGET 'THROW) (SETQ ADI-LIST `(MULTIPLE-VALUE (QUOTE-VECTOR (QUOTE NIL)) ,@ADI-LIST)       TDEST 'D-PDL))((EQ M-V-TARGET 'RETURN) (SETQ ADI-LIST `(MULTIPLE-VALUE (QUOTE-VECTOR 'T) ,@ADI-LIST)       TDEST 'D-PDL))((NUMBERP M-V-TARGET) ;; M-V-TARGET IS A NUMBER => IT IS NUMBER OF VALUES, ;; JUST LEAVE THEM ON THE STACK. (SETQ ADI-LIST `(MULTIPLE-VALUE (QUOTE-VECTOR ',M-V-TARGET) ,@ADI-LIST)       TDEST 'D-IGNORE)))      (SETQ ADI-LIST    (LIST* 'RESTART-PC   `(QUOTE-VECTOR (TAG ,(SETQ RESTART-PC (GENSYM))))   'BIND-STACK-LEVEL NIL ADI-LIST)))    ;;CHANGE MADE 10/22/85 BY CLM    ;;CHANGE MADE 12/05/85 BY CLM    (IF (COMPILING-FOR-V2)(PROGN  ;;EMIT THE CATCH-TAG, THE RESTART-PC, AND IF A MV CATCH, THE NUMBER OF VALUES  (P2 (CAR ARGL)      (IF GENERATING-MICRO-COMPILER-INPUT-P  'D-NEXT'D-PDL))  (OUTI1 (LIST 'MOVE 'D-PDL `(QUOTE-VECTOR (TAG ,(SETQ RESTART-PC (GENSYM))))))   ;RESTART-PC  (COND    ((EQ DEST 'D-RETURN)     (P2PUSH-CONSTANT NIL)     (OUTF '(AUX %OPEN-CATCH-MULTIPLE-VALUE)))    ((EQ DEST 'D-IGNORE)     (P2PUSH-CONSTANT 0)     (OUT-AUX '%OPEN-CATCH-MULTIPLE-VALUE))    ((NULL M-V-TARGET) (OUTF '(AUX %OPEN-CATCH)))    ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST)     (OUTF '(AUX %OPEN-CATCH-MV-LIST)))    ((OR (EQ M-V-TARGET 'THROW) (EQ M-V-TARGET 'RETURN) (EQ M-V-TARGET 'RETURN-CATCH))     (P2PUSH-CONSTANT NIL)     (OUTF '(AUX %OPEN-CATCH-MULTIPLE-VALUE)))    ((NUMBERP M-V-TARGET)     (P2PUSH-CONSTANT M-V-TARGET)     (OUTF '(AUX %OPEN-CATCH-MULTIPLE-VALUE)))))      (OUTI1 (LIST 'ADI-CALL 'CALL TDEST '(QUOTE-VECTOR (FUNCTION *CATCH)) ADI-LIST)))    (UNLESS (COMPILING-FOR-V2)      (MKPDLLVL (+ PDLLVL (LENGTH ADI-LIST))))    ;;this may need to be redone elsewhere further down    (UNLESS (COMPILING-FOR-V2)      (COND((NULL M-V-TARGET))((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST) (INCPDLLVL))((NUMBERP M-V-TARGET) (MKPDLLVL (+ PDLLVL M-V-TARGET)))))    (PUSH PDLLVL CALL-BLOCK-PDL-LEVELS)    (MKPDLLVL (+ PDLLVL (IF (COMPILING-FOR-V2) CATCH-BLOCK-SIZE 4)))     ;;ADDED 10/30/85 BY CLM TO PREVENT CATCH TAG BEING    ;;PUSHED AFTER THE %OPEN-CATCH IS GENERATED    (UNLESS (COMPILING-FOR-V2)      (P2 (CAR ARGL) (IF GENERATING-MICRO-COMPILER-INPUT-P 'D-NEXT       'D-PDL))      (INCPDLLVL))    (IF (COMPILING-FOR-V2)(COND  ((EQ DEST 'D-RETURN)   (SETQ SINGLE-VALUE-RETURN (P2MV (CADR ARGL) 'D-PDL 'RETURN-CATCH)))  ((NULL M-V-TARGET)   (P2 (CADR ARGL) (IF (EQ DEST 'D-IGNORE)       DEST     'D-PDL)))  ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST)   (WHEN     (P2MV (CADR ARGL) 'D-PDL M-V-TARGET)     (OUTM '(MISC D-PDL NCONS)) )    ;must convert a single value into a list   )  ((NUMBERP M-V-TARGET)   (SETQ SINGLE-VALUE-RETURN   (P2MV (CADR ARGL) (IF (EQ DEST 'D-IGNORE) DEST 'D-PDL) M-V-TARGET))   (WHEN (AND SINGLE-VALUE-RETURN      (NULL DROPTHRU))    ;there has been a throw     (SETQ SINGLE-VALUE-RETURN NIL)))  (T (SETQ SINGLE-VALUE-RETURN   (P2MV (CADR ARGL) (IF (EQ DEST 'D-IGNORE) DEST 'D-PDL) M-V-TARGET))) )      (COND((EQ DEST 'D-RETURN) (P2 (CADR ARGL) 'D-RETURN))((NULL M-V-TARGET) (P2 (CADR ARGL) 'D-LAST))((EQ M-V-TARGET 'THROW) (P2PUSH-CONSTANT (- PDLLVL INITIAL-PDLLVL)) (OUTM '(MISC D-PDL PDL-WORD)) (UNLESS (P2MV (CADR ARGL) 'D-PDL M-V-TARGET)   (POPPDL 1 (- PDLLVL INITIAL-PDLLVL -1))   (SETQ M-V-TARGET NIL)));;6/06/86 - this fixes the fix for SPR 2257((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST)   (WHEN     (P2MV (CADR ARGL) 'D-PDL M-V-TARGET)     (OUTM '(MISC D-PDL NCONS)) )    ;must convert a single value into a list   (SETQ M-V-TARGET NIL)   (POPPDL 1 (- PDLLVL INITIAL-PDLLVL))   )(T (UNLESS (P2MV (CADR ARGL) 'D-PDL M-V-TARGET)   (POPPDL (IF (NUMBERP M-V-TARGET) M-V-TARGET 1)   (- PDLLVL INITIAL-PDLLVL))   (SETQ M-V-TARGET NIL)))))    ;;for those cases where the body of the catch has    ;;produced only a single value    (WHEN SINGLE-VALUE-RETURN      (IF (NUMBERP M-V-TARGET)  (DOTIMES (I (1- M-V-TARGET))        (P2PUSH-CONSTANT (QUOTE NIL))      (INCPDLLVL))(P2PUSH-CONSTANT 1)))    (UNLESS (AND (NOT (COMPILING-FOR-V2)) (EQ DEST 'D-RETURN))      (SETQ DROPTHRU T))    (OUTF (LIST 'RESTART-TAG RESTART-PC))    ;;CHANGE MADE 10/22/85 BY CLM    ;;CHANGE MADE 12/05/85 BY CLM    (WHEN (COMPILING-FOR-V2)      (IF (EQ DEST 'D-RETURN)  (PROGN    (OUTI '(AUX %CLOSE-CATCH))    (OUT-AUX 'RETURN-N)    (SETQ PDLLVL INITIAL-PDLLVL))(PROGN  (OUTI (LIST 'AUX '%CLOSE-CATCH))    (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE)))))    (WHEN (PROG1    (NULL M-V-TARGET)    (SETQ M-V-TARGET NIL))      (UNLESS (IF (COMPILING-FOR-V2)  (MEMBER DEST '(D-RETURN D-PDL D-IGNORE) :TEST #'EQ)(OR (MEMBER DEST '(D-PDL D-IGNORE) :TEST #'EQ)    (AND (EQ DEST 'D-RETURN) (EQ TDEST 'D-RETURN))))(MOVE-RESULT-FROM-PDL DEST)(WHEN (COMPILING-FOR-V2)  (SETQ PDLLVL (1- PDLLVL)))))  ));Bind a list of variables, computing initializations and binding sequentially.;VARS are the VARS outside of this binding environment.;NEWVARS are the VARS inside of it, starting with the variables in X in reverse order,;except there may be additional entries for optional-specified-flags; each one;will be on NEWVARS just before its corresponding main variable.;We have to install these variables one at a time as we go, using successive tails.(DEFUN P2SBIND (X NEWVARS VARS)  (LET ((NBINDS 0)   ;Number of (internal-aux) special bindings(NNEWVARS (LOOP FOR L ON NEWVARS UNTIL (EQ L VARS) COUNT T)))    (DO ((X X (CDR X)) (HOME))((NULL X))      (LOOP DO (SETQ HOME (NTH (SETQ NNEWVARS (1- NNEWVARS)) NEWVARS))    UNTIL (NEQ (VAR-KIND HOME) 'FEF-ARG-DELETED))      (AND (P2LMB (CAR X) HOME) (SETQ NBINDS (1+ NBINDS)))      ;; Set VARS to the tail of NEWVARS starting at the variable we just handled      ;; or its optional-specified-flag.      (AND (CDDR (VAR-INIT HOME)) (SETQ NNEWVARS (1- NNEWVARS)))      (SETQ VARS (NTHCDR NNEWVARS NEWVARS)))    (OR (ZEROP NNEWVARS)(EQ (VAR-KIND (FIRST NEWVARS)) 'FEF-ARG-DELETED)(BARF X "VARS screwed up by this binding" 'BARF))    NBINDS)) ;Output code for binding the var VARNAME as specified in its HOME.;Return T if a BIND-POP or BIND-NIL instruction was output.(DEFUN P2LMB (VARNAME HOME) ;;  8/22/85 - Support BIND-CURRENT instruction; set KEEP-CURRENT-FRAME ;;            flag when a special variable is bound. ;; 10/30/85 - Change name BINDNIL to BIND-NIL and BINDPOP to BIND-POP; ;;            implement use of BIND-T. ;; 12/07/85 - For release 3, FEF-ARG-AUX special variables are not bound on ;;            function entry; delete references to FEF-REMOTE.  (LET (INTCODEINITFORM KIND)    (BLOCK NIL      (UNLESS (ATOM VARNAME)(SETQ INITFORM (CADR VARNAME))(SETQ VARNAME (CAR VARNAME)))      (UNLESS (EQ (VAR-NAME HOME) VARNAME)(BARF VARNAME "wrong home in P2LMB" 'BARF))      (SETQ INTCODE (VAR-INIT HOME))      ;; If this variable's binding is fully taken care of by function entry,      ;; we have nothing to do here.      (UNLESS (MEMBER (CAR INTCODE) '(FEF-INI-OPT-SA FEF-INI-COMP-C) :TEST #'EQ)(RETURN NIL))      ;; Detect and handle internal special bound variables.      (SETQ KIND (VAR-KIND HOME))      (WHEN (AND (EQ (VAR-TYPE HOME) 'FEF-SPECIAL) (OR (EQ KIND 'FEF-ARG-INTERNAL-AUX)     (COMPILING-FOR-V2)));; Output BIND-NIL, or push value and BIND-POP.(COND  ((MEMBER INITFORM '(NIL (QUOTE NIL)) :TEST #'EQUAL)   (OUTIV 'BIND-NIL HOME))  ((AND (EQ INITFORM VARNAME)   ; bind to itself(INSTRUCTION-EXISTS-P 'BIND-CURRENT))   (OUTIV 'BIND-CURRENT HOME))  ((AND (EQUAL INITFORM ''T)(INSTRUCTION-EXISTS-P 'BIND-T))   (OUTIV 'BIND-T HOME))  (T (P2PUSH INITFORM)     (OUTIV 'BIND-POP HOME)))(SETQ KEEP-CURRENT-FRAME T)(RETURN T))      ;; If variable deleted by function LET-OPT, do nothing.      (WHEN (EQ KIND 'FEF-ARG-DELETED)(RETURN NIL))      ;; Otherwise, it's an internal local variable,      ;; or else a special variable already bound by entering the function.      ;; Don't bind, just init.      (COND((MEMBER INITFORM '(NIL (QUOTE NIL)) :TEST #'EQUAL) ;; if initting to NIL, then if no tags output so far (TAGOUT is NIL) ;; we can assume it is still NIL from function entry time. (WHEN (OR TAGOUT   (EQ (VAR-TYPE HOME) 'FEF-SPECIAL)   (VAR-OVERLAP-VAR HOME))   (OUTIV 'SET-NIL HOME)));; If explicitly says value does not matter, do nothing to initialize.((OR (EQUAL INITFORM '(UNDEFINED-VALUE))     #+compiler:debug ; temporary while COMPILER2 package is being used.    (EQUAL INITFORM '(COMPILER:UNDEFINED-VALUE))) NIL)((EQUAL INITFORM ''0) (OUTIV 'SET-ZERO HOME))(T (P2PUSH INITFORM)   ;;IF &OPTIONAL AND FOR MICRO-COMPILER, JUST LEAVE VARIABLE ON STACK. (IF (AND GENERATING-MICRO-COMPILER-INPUT-P  (EQ (CAR INTCODE) 'FEF-INI-OPT-SA))     NIL   (OUTIV 'POP HOME))))      ;; If there is a specified-flag variable, it was bound to T at entry.      ;; Set it to NIL here (ie, if the arg was NOT specified).      (WHEN (CDDR INTCODE)(OUTIV 'SET-NIL (CDDR INTCODE)))      (WHEN (EQ (CAR INTCODE) 'FEF-INI-OPT-SA)(SETF (GET (CADR INTCODE) 'PEEP-KEEP) T)(OUTF (CADR INTCODE)))      (RETURN NIL)))) (DEFUN OUTIV (INST VARAB &OPTIONAL ADR)  ;; 10/18/86 DNG - Modified to handle initialization of higher-context lexical  ;;variables; this is needed when EXTEND-LOCAL-VARIABLES has split the FEF.  (DECLARE (UNSPECIAL ADR))  (WHEN (NULL ADR)    (SETQ ADR (VAR-LAP-ADDRESS VARAB)))  (IF (AND (CONSP ADR)   (EQ (FIRST ADR) 'LEXICAL-REF)   (ATOM (SETQ ADR (LEX-REF-ADDRESS ADR))))      (PROGN(UNLESS (EQ INST 'POP)  (OUTI (LIST INST 0 'PDL-PUSH)))(P2PUSH-CONSTANT ADR)(NEEDPDL 1)(OUT-AUX 'STORE-IN-HIGHER-CONTEXT))    (OUTI (LIST INST 0 ADR))))#| old(DEFUN OUTIV (INST VARAB)  (OUTI (LIST INST 0 (VAR-LAP-ADDRESS VARAB)))) |#;Bind a list of variables "in parallel":  compute all values, then bind them all.;Return the number of special bindings made (BIND-POP and BIND-NIL instructions).;Note: an attempt to bind NIL is ignored at this level.;Note: if several variables have init forms of (%pop),;they are popped off the pdl LAST ONE FIRST!;The "correct" thing would be to pop the first one first,;but this would require another stack to keep them on to reverse them.(DEFUN P2PBIND (VARNAMES NEWVARS)  ;;  8/23/85 - Set KEEP-CURRENT-FRAME flag when a special variable is bound.  ;; 10/30/85 - Change instruction BINDNIL to BIND-NIL and BINDPOP to BIND-POP.  ;; 12/07/85 - For release 3, FEF-ARG-AUX special variable is not bound on function entry.  (LET ((PDLLVL PDLLVL))    (PROG (VARNAME HOME INTCODE INITFORM NBINDS)  (OR VARNAMES (RETURN 0))  (SETQ VARNAME (CAR VARNAMES)VARNAMES (CDR VARNAMES))  (UNLESS (ATOM VARNAME)    (SETQ INITFORM (CADR VARNAME))    (SETQ VARNAME (CAR VARNAME)))  ;; If trying to bind NIL, just discard the value to bind it to.  (WHEN (NULL VARNAME)    (P2 INITFORM 'D-PDL)    (RETURN (PROG1      (P2PBIND VARNAMES NEWVARS)      (OUTF '(MOVE D-IGNORE PDL-POP)))))  (WHEN (NULL (SETQ HOME (LOOKUP-VAR VARNAME NEWVARS)))    (BARF VARNAME 'NOT-ON-VARS 'BARF))  (SETQ INTCODE (VAR-INIT HOME))  ;; If this variable's binding is fully taken care of by function entry,  ;; we have nothing to do here.  (WHEN (AND (NOT (MEMBER (VAR-KIND HOME) '(FEF-ARG-INTERNAL-AUX FEF-ARG-KEY) :TEST #'EQ))     (NOT (MEMBER (CAR INTCODE) '(FEF-INI-OPT-SA FEF-INI-COMP-C) :TEST #'EQ)))    (RETURN (P2PBIND VARNAMES NEWVARS)))  ;; Detect and handle internal special bound variables.  (WHEN (AND (EQ (VAR-TYPE HOME) 'FEF-SPECIAL)     (OR (EQ (VAR-KIND HOME) 'FEF-ARG-INTERNAL-AUX) (COMPILING-FOR-V2)))    (COND      ((MEMBER INITFORM '(NIL (QUOTE NIL)) :TEST #'EQUAL)       (SETQ NBINDS (P2PBIND VARNAMES NEWVARS))       (OUTIV 'BIND-NIL HOME))      (T (P2PUSH INITFORM) (INCPDLLVL) (SETQ NBINDS (P2PBIND VARNAMES NEWVARS)) (OUTIV 'BIND-POP HOME)))    (SETQ KEEP-CURRENT-FRAME T)    (RETURN (1+ NBINDS)))  (COND    ((OR (EQUAL INITFORM '(UNDEFINED-VALUE)) #+compiler:debug ;temporary while COMPILER2 package is used (EQUAL INITFORM '(COMPILER:UNDEFINED-VALUE)))     (SETQ NBINDS (P2PBIND VARNAMES NEWVARS)))    ((MEMBER INITFORM '(NIL (QUOTE NIL)) :TEST #'EQUAL)     (SETQ NBINDS (P2PBIND VARNAMES NEWVARS))     (WHEN (OR TAGOUT       (EQ (VAR-TYPE HOME) 'FEF-SPECIAL)       (VAR-OVERLAP-VAR HOME))       (OUTIV 'SET-NIL HOME)))    ;; Special vars bound at function entry and wanting to be    ;; initted to themselves, need not be set at all.    ((AND (EQ (VAR-TYPE HOME) 'FEF-SPECIAL)  (EQ INITFORM VARNAME))     (SETQ NBINDS (P2PBIND VARNAMES NEWVARS)))    (T (P2PUSH INITFORM)       (INCPDLLVL)       (SETQ NBINDS (P2PBIND VARNAMES NEWVARS))       ;IF FOR MICRO-COMPILER AND IS OPTIONAL ARG, JUST LEAVE VARIABLE ON STACK.       (IF (AND GENERATING-MICRO-COMPILER-INPUT-P(MEMBER 'FEF-INI-OPT-SA INTCODE :TEST #'EQ))   NIL (OUTIV 'POP HOME))))  (WHEN (EQ (CAR INTCODE) 'FEF-INI-OPT-SA)    (SETF (GET (CADR INTCODE) 'PEEP-KEEP) T)    (OUTF (CADR INTCODE)))  (RETURN NBINDS)))) ;Compile code to test CONDITION and jump to tag if it is NIL;(for SENSE = TRUE) or if it is non-NIL (for SENSE = FALSE).(DEFUN BOOL1 (CONDITION SENSE TAG)  (P2BRANCH CONDITION 'D-INDS    `(BRANCH NULL ,SENSE NIL ,TAG))) ;Like P2, but also supply a "branch destination".;The branch destination (BDEST) is just a branch instruction which;could simple-mindedly be compiled right after (P2 FORM DEST),;but some forms can optimize the code produced by incorporating;the branch destination into their code.  Such forms can say that;outputting the branch at the end is superfluous by setting BDEST to NIL.;Forms which perform unconditional transfers need not worry about BDEST;since it will be output and then discarded as unreachable.;An unconditional branch destination can accompany any value of DEST.;A conditional branch should only be used with DEST = D-INDS.;This is taken to imply that the indicators are used by the branch,;not that the indicators will be correctly set up after the optimized;code is finished branching or not.  If you wish to compile something;and want the indicators correctly set up according to its value,;you should use D-INDS with no BDEST, and do your branching yourself.;Branches which pop the pdl may not be used as branch destinations.;Most people who look at BDEST don't check for them,;and the optimizations that BDEST is used for wouldn't work for them anyway.;A funny kind of branch that can be used as a destination is;(BRANCH ALWAYS NO-OP NIL tag).  It is a sort of unconditional branch,;used when the tag to be branched to is known to be right after;this expression, so that one might think that no branch is needed at all.;When OUTB is called on such a branch, it does nothing.;But some functions (such as AND and OR) can optimize these no-op branches;like any other unconditional branches.;An even funnier kind of branch destination is the return branch:;(BRANCH ALWAYS RETURN NIL tag).  This is given as the branch destination;to the last statement in a PROG, so that if the statement is a RETURN;then the implicit (RETURN NIL) at the end of the PROG can be omitted;and the RETURN at the end can just drop through to the PROG's rettag.;Return branch destinations may not be passed along to subexpressions;by AND, OR and COND.(DEFUN P2BRANCH (FORM DEST BDEST)  (AND (MEMBER DEST '(D-PDL D-NEXT) :TEST #'EQ)       (NEEDPDL 1))  (COND    ((AND BDEST (NEQ (CADR BDEST) 'ALWAYS)  (NEQ DEST 'D-INDS))     (BARF `(,DEST . ,BDEST) "BDEST is conditional and DEST is not D-INDS" 'BARF))    ;; We can optimize things like (AND 'T (GO FOO)) and (AND 'NIL (GO FOO))    ;; into an unconditional jump or into nothing at all.    ((AND (EQ (CADR BDEST) 'NULL)  (NULL (CADDDR BDEST))  (NOT (ATOM FORM))  (EQ (CAR FORM) 'QUOTE))     (AND (EQ (NULL (CADR FORM))      (EQ (CADDR BDEST) 'TRUE))  (OUTB `(BRANCH ALWAYS NIL ,@(COPY-LIST (CDDDR BDEST)))))     (SETQ BDEST NIL))    ((ADRREFP FORM)     (OR (EQ DEST 'D-IGNORE) (OUTI `(MOVE ,DEST ,(P2-SOURCE FORM DEST)))))    ((EQ (CAR FORM) 'LEXICAL-REF)     (P2 FORM DEST))    ((MEMBER (CAR FORM) '(%POP) :TEST #'EQ)     (P2 FORM DEST))    (T (LET (M-V-TARGET) (P2F FORM DEST))))  (AND BDEST (OUTB (COPY-LIST BDEST)))) #| -- this is now handled in P2F(DEFPROP ATOM P2ATOM P2) ;A call to ATOM which is then tested by a branch-if-non-nil, etc.,;can be turned into just a branch-if-atom, etc.(DEFUN P2ATOM (ARGL DEST)  (COND    ((EQ (CADR BDEST) 'NULL)     (LET ((SENSE (CADDR BDEST)))       (SETQ SENSE (OTHER SENSE))       (P2BRANCH (CAR ARGL) DEST `(BRANCH ATOM ,SENSE ,@(CDDDR BDEST))))     (SETQ BDEST NIL))    (T (P2MISC P2FN ARGL DEST 1))))  |#;NOT compiles into a misc insn normally,;but with a branch destination, it optimizes away by inverting the condition.(DEFPROP NOT P2NOT P2) (DEFUN P2NOT (ARGL DEST)  ;;  8/17/85 - For release 3, special handling of D-RETURN; allow branch  ;;            conditions other than ATOM and NULL.  ;;  9/19/85 - Use AUX RETURN-NOT-PDL-POP and PUSH-NOT instructions.  ;;  9/26/85 - Use NOT-INDICATORS instruction.  ;;  8/28/86 CLM - the call to P2ARGC no longer requires a DESC arg; just pass nil  (COND    ((/= (LENGTH ARGL) 1)     ;; Wrong number of arguments; generate call so user gets error when executed.     (P2ARGC NIL ARGL nil DEST P2FN))    ((AND BDEST (GET (CADR BDEST) 'DEF-BRANCH-OP))     (LET ((SENSE (OTHER (CADDR BDEST))))       (P2BRANCH (CAR ARGL) DEST `(BRANCH ,(CADR BDEST) ,SENSE ,@(CDDDR BDEST))))     (SETQ BDEST NIL)) #| ((AND (EQ DEST 'D-RETURN)      (COMPILING-FOR-V2)      (ADRREFP (FIRST ARGL))) (P2PUSH (FIRST ARGL)) (OUTI '(AUX RETURN-NOT-PDL-POP)) (SETQ DROPTHRU NIL) (comment ; use this if RETURN-NOT-PDL-POP is not supported.   (P2MISC P2FN ARGL 'D-PDL 1)   (MOVE-RESULT-FROM-PDL DEST)) ) |#    ((AND (COMPILING-FOR-V2)  (INSTRUCTION-EXISTS-P 'PUSH-NOT))     (LET ((ADR (P2-SOURCE (FIRST ARGL) 'D-PDL)))       (IF (EQ ADR 'PDL-POP)   (IF (EQ DEST 'D-RETURN)       (PROGN (OUTI '(AUX RETURN-NOT-PDL-POP)) (SETQ DROPTHRU NIL))     (OUTM `(MISC ,DEST ,(MISC-LAP-CODE 'NOT)))) (IF (EQ DEST 'D-PDL)     (OUTI `(PUSH-NOT 0 ,ADR))   (IF (EQ DEST 'D-RETURN)       (PROGN (OUTI `(PUSH-NOT 0 ,ADR)) (MOVE-RESULT-FROM-PDL DEST))     (P2MISC P2FN ARGL DEST 1))))))    ((MISC-LAP-CODE 'NOT-INDICATORS)     (P2 (FIRST ARGL) 'D-INDS)     (IF (EQ DEST 'D-RETURN) (OUT-AUX 'RETURN-NOT-INDS)       (OUTM `(MISC ,DEST ,(MISC-LAP-CODE 'NOT-INDICATORS)))))    (T (P2MISC P2FN ARGL DEST 1)))) (DEFUN OTHER (SENSE)  (COND    ((EQ SENSE 'TRUE) 'FALSE)    ((EQ SENSE 'FALSE) 'TRUE)    (T (BARF SENSE 'OTHER 'BARF)))) (DEFPROP AND P2ANDOR P2) (DEFPROP OR P2ANDOR P2) (DEFUN P2ANDOR (ARGL DEST)  ;;  4/10/85 DNG - Don't delete constant last argument unless the value is not used. [bug 1561]  ;;  8/04/86 CLM - Handle cases where multiple values are expected but only a single value is  ;;                returned - when M-V-TARGET is RETURN or THROW.  (PROG (TAG UNCONDITIONAL IDEST SENSE TAG1)(SETQ SENSE (IF (MEMBER P2FN '(AND :AND) :TEST #'EQ)'TRUE      'FALSE))(WHEN (MEMBER DEST '(D-INDS D-IGNORE) :TEST #'EQ)  (DO ()      ((NOT (EQUAL (CAR (LAST ARGL))   (IF (EQ SENSE 'TRUE)       ''T     '(QUOTE NIL)))))    (SETQ ARGL (BUTLAST ARGL))))(SETQ IDEST 'D-PDL);; RETURN branches can't be passed in to the last thing in an AND.(AND (EQ (CADR BDEST) 'ALWAYS)     (EQ (CADDR BDEST) 'RETURN)     (SETQ BDEST NIL));; Any non-null constant as arg in an AND is ignorable unless it is last.;; NIL as arg in an OR is always ignorable.(SETQ ARGL      (COND((EQ SENSE 'FALSE) (DELETE '(QUOTE NIL) (THE LIST ARGL) :TEST #'EQUAL))((NULL ARGL) ARGL)(T (NREVERSE   (CONS (CAR (LAST ARGL)) (DELETE NIL (THE LIST (CDR (NREVERSE ARGL))) :TEST #'(LAMBDA (IGNORE X)   (AND (NOT (ATOM X))(EQ (CAR X) 'QUOTE)(CADR X)))) ))) ) )(OR ARGL (RETURN (PROG1   (P2BRANCH `',(EQ SENSE 'TRUE) DEST BDEST)   (SETQ BDEST nil))));; If we are going to jump somewhere unconditionally after the AND,;; things which are NIL might as well jump conditionally straight there.;; But this only works if the value of the AND will be in the right place then.(COND  ((AND (EQ (CADR BDEST) 'ALWAYS)(NULL M-V-TARGET)(MEMBER DEST '(D-PDL D-INDS D-IGNORE) :TEST #'EQUAL))   (SETQ UNCONDITIONAL T)   (SETQ TAG (CAR (CDDDDR BDEST))))  (T (SETQ TAG (GENSYM))))(COND  ((AND (NULL M-V-TARGET) (EQ DEST 'D-IGNORE))   ;; Compilation strategy for AND for effect:   ;; compute each arg, using it only to jump to end if it's NIL.   ;; The last one we just ignore, but we feed it our BDEST for   ;; branch tensioning.  However, (AND form (GO tag)) can be optimized   ;; by making it a conditional jump to tag rather than a jump around a jump.   (DO ((ARGL ARGL (CDR ARGL)))       ((NULL (CDR ARGL))(P2BRANCH (CAR ARGL) DEST BDEST))     (AND (SIMPLEGOP (CADR ARGL))  (RETURN (BOOL1 (CAR ARGL) (OTHER SENSE) (GTAG (CADADR ARGL)))))     ;; If the next arg of this AND is NIL, this arg is effectively last.     ;; However, if AND has a branch destination, it must compute     ;; whether to branch based on the NIL, not on this arg.     (AND (NOT (ATOM (CADR ARGL)))  (EQ (CAADR ARGL) 'QUOTE)  (EQ (NULL (CADADR ARGL))      (EQ SENSE 'TRUE))  (RETURN (P2BRANCH (CAR ARGL) DEST BDEST)))     (BOOL1 (CAR ARGL) SENSE TAG)))  ((AND (NULL M-V-TARGET) (EQ (CADR BDEST) 'NULL))   ;; Compilation strategy for AND followed by jump if NIL:   ;; jump compute each value and jump THERE rather than to end if NIL.   ;; Compilation strategy for AND followed by jump if not NIL:   ;; put that jump if not NIL after the last thing in the AND   ;; and go to after that if anything else fails to be non-NIL.   (IF (EQ SENSE (CADDR BDEST))       (DO ((ARGL ARGL (CDR ARGL)))   ((NULL ARGL)) (P2BRANCH (CAR ARGL) DEST BDEST))     (DO ((ARGL ARGL (CDR ARGL))) ((NULL (CDR ARGL))  (P2BRANCH (CAR ARGL) DEST BDEST))       ;; If the next arg of this AND is NIL, this arg is effectively last.       ;; Also, BDEST can be flushed since it says branch if       ;; not NIL and we now know the value of the AND is always NIL.       (AND (NOT (ATOM (CADR ARGL)))    (EQ (CAADR ARGL) 'QUOTE)    (EQ (NULL (CADADR ARGL))(EQ SENSE 'TRUE))    (RETURN (P2 (CAR ARGL) DEST)))       (BOOL1 (CAR ARGL) SENSE TAG)))   (SETQ BDEST NIL))  (T   ;; Compilation strategy for AND for value   ;; (correct indicators required counts as for value):   ;; compile each arg, jumping to end if NIL.   ;; Compile them to indicators, or to pdl and pop if NIL.   ;; If compiling to indicators (no pushing), we can optimize   ;; (AND form (GO tag)) just as when we are ignoring the value.   (AND (EQ DEST 'D-INDS) (SETQ IDEST 'D-INDS))      ;; AND for multiple values is like AND for value on the stack,   ;; except that we can pass the M-V-TARGET along to the last form.   ;; Also, after the "end" where the failure branches branch to   ;; we put code to push N-1 extra NILs, or whatever.   ;; The code for the last form jumps around that, to the tag TAG1.   (AND M-V-TARGET (SETQ IDEST 'D-PDL))   (DO ((ARGL ARGL (CDR ARGL))(BRANCH `(BRANCH NULL ,SENSE ,(NEQ DEST 'D-INDS) ,TAG)))       ((NULL (CDR ARGL));; Compile the last form.  If we want multiple values;; and it handles them, then say the AND is handling them.(COND (M-V-TARGET       (WHEN (NULL (P2MV (CAR ARGL) IDEST M-V-TARGET)) (SETQ TAG1 (GENSYM))))      (UNCONDITIONAL       (P2BRANCH (CAR ARGL) DEST BDEST)       (SETQ BDEST NIL))      (T (P2 (CAR ARGL)     (IF (AND (EQ DEST 'D-RETURN)      (NOT GENERATING-MICRO-COMPILER-INPUT-P)) DEST   ;OK TO DISTRIBUTE DOWN A D-RETURN, SINCE   ; IT IS AN IMPLICT TRANSFER       IDEST)))))  ;COMPILE TO IDEST, SINCE GOING TO   ;FALL INTO COMMON POINT WHICH EXPECTS RESULT THERE     (P2 (CAR ARGL) IDEST)     (AND (EQ IDEST 'D-INDS)  (SIMPLEGOP (CADR ARGL))  (RETURN (OUTB `(BRANCH NULL ,(OTHER SENSE) NIL ,(GTAG (CADADR ARGL))))))     (OUTB (COPY-LIST BRANCH)))))(COND  (TAG1   ;; If we want multiple values, and the last form provides them,   ;; say that the AND provides them,   ;; and arrange to produce some in every other path.   (OUTB `(BRANCH ALWAYS NIL NIL ,TAG1))   ;Last form jumps around.   (OUTTAG TAG)   ;Other paths come here.   (COND     ((NUMBERP M-V-TARGET)   ;Turn single value into N values,      (PUSH-NILS (1- M-V-TARGET)))     ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST) ;or into a list of values.      (OUTF '(MISC D-PDL NCONS)))     (M-V-TARGET                   ;other cases where multiple values       (P2PUSH-CONSTANT 1))         ;were expected but a single value returned     )   (SETQ M-V-TARGET NIL)   (OUTTAG TAG1))           ;Last form jumps here.  ((NOT UNCONDITIONAL)   (OUTTAG TAG)   (OR (EQ DEST 'D-IGNORE)       (EQ DEST 'D-INDS)       (MOVE-RESULT-FROM-PDL DEST))))))(DEFUN SIMPLEGOP (FORM)  ;; Return T if given a (GO tag) which could be done with just a branch  ;; (doesn't require popping anything off the pdl).  ;;  ;;  1/22/86 DNG - Fix to check for special bindings also.  ;; 10/18/86 DNG - Use GOTAGS-SEARCH instead of ASSOC.  ;; 11/17/86 CLM - Fix to check for lexical-closures.  May have to do an  ;;                unshare, so don't return T.  ;; 12/03/86 CLM - Fix to check for lexical closures. Faulty end-test was causing  ;;                an infinite loop.  ;;  2/04/87 DNG - When LEXICAL-CLOSURE-COUNT is 0, don't bother looking for variables needing to be unshared.  (AND (NOT (ATOM FORM))       (EQ (FIRST FORM) 'GO)       (LET ((GOTAG (GOTAGS-SEARCH (SECOND FORM) T))     PD) (AND GOTAG (= PDLLVL (GOTAG-PDL-LEVEL GOTAG))      (SETQ PD (GOTAG-PROGDESC GOTAG))      (DOLIST (PROGDESC PROGDESCS T)(IF (EQ PROGDESC PD)    (RETURN T)  (UNLESS (AND (MEMBER (PROGDESC-NBINDS PROGDESC) '(0 NIL) :TEST #'EQ)       (OR (ZEROP LEXICAL-CLOSURE-COUNT)   (DO ((VS VARS (CDR VS))(OVARS (PROGDESC-VARS PROGDESC)))       ((OR (EQ VS OVARS)    (NULL VS)) T)     (LET ((V (CAR VS)))       (WHEN (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC V)     :TEST #'EQ) (RETURN NIL)))) ;DO   )        );and    (RETURN NIL))  ))))))(DEFPROP COND P2COND P2) (DEFUN P2COND (ARGL DEST)  ;; 01/09/86  CLM - Modified for Release 3 so that if the selected clause is  ;;                 the last (or only) clause and a singleton clause, then only  ;;                 a single value will be returned - when compiling for Common  ;;                 Lisp.  ;; 02/14/86  DNG - Fix for returning NIL default when last clause does a GO. [SPR 1074]  ;; 02/14/86  CLM - Handle cases where multiple values are expected but only a  ;;                 single value is produced.  ;;  9/05/86  CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET.  ;;  9/22/86  DNG - Optimize COND to use SELECT instruction.  (IF (AND (> (LENGTH ARGL) 2)   (NULL M-V-TARGET)   (COMPILING-FOR-V2)   #+(and Elroy compiler:debug) ; temporary %%%   (>= %microcode-version-number 148.)   (CONSP (CAR-SAFE (FIRST ARGL)))   (LET ((X (SECOND (FIRST (FIRST ARGL)))) (N 0))     (DOLIST (CLAUSE ARGL T)       (LET ((TEST (CAR-SAFE CLAUSE))) (WHEN (ATOM TEST) (RETURN NIL)) (UNLESS (OR (AND (EQ (FIRST TEST) 'QUOTE)  (SECOND TEST))     (AND (MEMBER (FIRST TEST) '(EQ MEMQ) :TEST #'EQ)  (QUOTEP (THIRD TEST))  (EQUAL-FORMS (SECOND TEST) X)  (OR (REST CLAUSE)      (EQ (FIRST TEST) 'EQ)      (MEMBER DEST '(D-IGNORE D-INDS)))  (NULL (NTHCDR 3 TEST))))   (RETURN NIL)) (WHEN (> (INCF N) 3)   (RETURN T)) ))))      ;; then can optimize to use SELECT or DISPATCH instruction      (P2SELECT ARGL DEST)    ;; else normal COND processing  (PROG (CLAUSE TAG TAG1 TAG2 VALF CLAUSE-LENGTH TM IDEST PRED NOFALLTHRU LAST-CLAUSE-FLAG IDEST-USED)(SETQ TAG2 (GENSYM))   ;TAG TO GO TO WITH VALUE OF COND IN DEST(SETQ TAG (GENSYM))   ;TAG TO GO TO WITH VALUE OF COND IN IDEST;; Choose an intermediate destination, depending on ultimate destination.;; The intermediate destination can match the ultimate one;; if they are D-IGNORE, D-INDS or D-PDL.;; Each COND clause can compile its value to IDEST and go to TAG;; or compile its value to DEST and go to TAG2.;; Use of TAG and IDEST assumes that multiple values were NOT generated;; whereas TAG2 and DEST assumes that they were if they are supposed to be.;; For microcompiler input, we always use TAG and IDEST unless IDEST=DEST.;; Otherwise, we usually use DEST except for clauses that are just predicates.;; IDEST-USED is T if a clause has compiled its result to IDEST.;; The code to move the value is only generated if IDEST/TAG has been used.(AND M-V-TARGET (SETQ DEST 'D-PDL))(SETQ IDEST 'D-IGNORE)(UNLESS (EQ DEST 'D-IGNORE)  (SETQ VALF T)  (SETQ IDEST 'D-PDL))(WHEN (EQ DEST 'D-INDS)  (SETQ IDEST 'D-INDS));; Compile next clause.     L1(WHEN (NULL (CDR ARGL))  (SETQ LAST-CLAUSE-FLAG T))(SETQ CLAUSE (CAR ARGL));;the following clause changed 01/09/86 by CLM;;if compiling for common-lisp, multiple values should;;not be returned if the last clause is a singleton clause.(AND (NOT COMPILING-COMMON-LISP)     LAST-CLAUSE-FLAG     (NULL (CDR CLAUSE))     (SETQ CLAUSE (CONS ''T CLAUSE)))(SETQ TAG1 (GENSYM))(SETQ PRED (CAR CLAUSE))(WHEN (AND (NOT (ATOM PRED))   (EQ (CAR PRED) 'QUOTE))  (COND    ((NULL (CADR PRED))   ;IS THE NULL CONDITION?     (AND (NOT LAST-CLAUSE-FLAG)  (GO L5)))                ;YEP.  CAN HAPPEN AS RESULT OF DO EXPANSION.    ((CDR ARGL)   ;condition always true?     (SETQ LAST-CLAUSE-FLAG T)   ;If so, discard any remaining clauses     (SETQ NOFALLTHRU T)   ;after a warning about them.;These can come from expanding DEFSUBSTs that contain CONDs, with constant arguments.;     (WARN 'UNREACHABLE-CODE ':IMPLAUSIBLE; "Some COND clauses are unreachable;; the first starts with ~S."; (CAADR ARGL))     (SETQ ARGL (LIST CLAUSE)))    (T (SETQ NOFALLTHRU T))))(SETQ CLAUSE-LENGTH (LENGTH CLAUSE));; Handle certain special cases of clauses.(COND  ((AND VALF (= 1 CLAUSE-LENGTH))   ;; Clause containing only one element, compiled for value.   ;; value of condition is also value of clause.   (P2 PRED IDEST)   (SETQ IDEST-USED T)   ;;if clause is the last of the COND, don't generate   ;;an unnecessary branch   (UNLESS LAST-CLAUSE-FLAG     (OUTB (LIST 'BRANCH 'NULL 'FALSE (EQ IDEST 'D-PDL)   ;IF SOMETHING PUSHED, POP IF TAG)))   ; THE BRANCH IS NOT TAKEN   (GO L5))  ;; Clause of one element, if value is not wanted.  ((= 1 CLAUSE-LENGTH) (BOOL1 PRED 'FALSE TAG) (GO L5))  ;; Clause is just condition followed by a GO.  ((AND (= 2 CLAUSE-LENGTH)(SIMPLEGOP (CADR CLAUSE))(NOT (AND VALF LAST-CLAUSE-FLAG)))   (BOOL1 PRED 'FALSE (GTAG (CADADR CLAUSE)))   (GO L5))  ;; Clause after this one is (T (GO ...)).  ;; Can get special handling only if the GO  ;; requires no pdl adjustment