LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760030378. :SYSTEM-TYPE :LOGICAL :VERSION 14. :TYPE "LISP" :NAME "P1OPT" :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 2758302800. :AUTHOR "REL3" :LENGTH-IN-BYTES 144206. :LENGTH-IN-BLOCKS 141. :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) 1985,1987 Texas Instruments Incorporated. All rights reserved.;;; Copyright (C) 1980, Massachusetts Institute of Technology;;;;   *-----------------------------------------------------------*;;;;   |   --  TI Explorer Lisp Compiler  --   |;;;;   |  This file contains the source-level optimizers for       |;;;;   |  pass 1, except those for numbers and characters which    |;;;;   |  are in a separate file, NUMOPT.      |;;;;   *-----------------------------------------------------------*;;; Feb. 1984 - Version 98 from MIT via LMI.  [file "SYS;QCOPT"];;; July 1984 - TI modifications to do constant folding bottom-up (i.e., ;;;  after P1 instead of before), to do folding on conditional;;;  expressions, and various other improvements.  ;;;  Also fixed bug 585 - warning on DECLARE inside DO.;;; 07/25/84 - From MIT patch 98.33, fix CALL-TO-MULTIPLE-VALUE-LIST to recognize CLI:LAMBDA.;;; 07/31/84 DNG - Added function EQUAL-FORMS to prevent endless recursion;;;when comparing expressions for EQUAL.;;; 08/01/84 DNG - From MIT patch 98.40, fix to optimize CLI:// and CLI:ATAN.;;; 08/06/84 DNG - From MIT patch 98.44, change INVARIABLE-FORM-P to substitute;;;CONSTANTP, and modify EQ-TYPEP-1 to use predicate LISTP instead;;;of CONSP for type :LIST [I don't know why; currently they give;;;the same result but CONSP is more efficient].;;; 08/06/84 DNG - From MIT patch 98.47, add MAKE-OBSOLETE of CATCH and THROW,;;;optimize CLI:CATCH to *CATCH and CLI:THROW to *THROW, fix ;;;optimization of relational with one argument to evaluate the;;;argument for side-effects, add new functions EQL-EQ and;;;MEMBER-EQL-MEMQ, replace TRY-TO-USE-SIMPLE-MAKE-ARRAY, add;;;style checkers for APPEND and SUBST.;;; 08/07/84 DNG - From MIT patch 98.57, add optimizer for MAKE-STRING,;;;update FLOAT-OPTIMIZER, and modify MEMQ-EQ.;;; 08/23/84 DNG - Modify BLOCK-OPT for cancelling out adjacent BLOCK/RETURN.;;; 09/05/84 DNG - Assorted improvements.;;; 09/25/84 DNG - Fix VARS-USED-1 so that special variables used in a CLOSURE;;;are not deleted.;;; 10/10/84 DNG - Fix DOLIST-EXPANDER for iteration variable with the same;;;name as a variable in the list expression.;;; 10/29/84 DNG - Disable DOLIST-EXPANDER because of problems when %PUSH in loop.;;; 12/27/84 DNG - Created new functions ARGS-SAME and LOGAND-OPT; use SI:EVAL1;;;   instead of EVAL to fix LET-IF in Common Lisp mode.;;; 12/28/84 DNG - New function DISCARD to decrement EXPRESSION-SIZE;;;;   added TRY-INLINE declarations; added optimization to AND-OPT;;;   to use CAR-SAFE instruction.;;; 12/29/84 DNG - New optimizations for LIST, etc.;;;  1/04/85 DNG - More on CLI:MEMBER; optimize (LENGTH (LIST ...));;;;use %DUP for multiply by 2 or exponent 2.;;;  1/25/85 DNG - Value propagation over TAGBODY; re-instated DOLIST-EXPANDER;;;   since the problem case is now handled in QCP1.;;;  1/29/85 DNG - Created new function ALWAYS-TRUE.;;;  2/05/85 DNG - Created new function INC-VAR-USE.;;;  2/06/85 DNG - Provide for constant folding on some more functions;;;;   update NO-SIDE-EFFECTS-P.;;;  2/22/85 DNG - Fix PSETQ optimization for flavor instance variables.;;;  3/07/85 DNG - Updates to INTERNAL-=-OPTIMIZER, INC-VAR-USE, and ADD-1-OPT.;;;  3/23/85 DNG - Fix a problem in PROPAGATE-VALUES.;;;  4/04/85 DNG - Fix optimization of FUNCALL of LAMBDA expression.;;;  4/12/85 DNG - Fix numeric optimizations for bugs [1223] and [1185].;;;  4/23/85 DNG - Fix a few more cases of bugs [1185] and [1574].;;;  4/26/85 DNG - Fix optimization of Common Lisp array references. [1136];;;  4/30/85 DNG - Add optimizers for TIME and BREAK.;;;------------------ The following done after Explorer release 1.0 ------;;;  6/25/85 DNG - Fix to optimize CHAR< etc. like their numeric counterparts;;;;   optimize comparison with three arbitrary arguments;;;;   change 2-argument NCONC to *NCONC and APPEND to *APPEND.;;;  6/26/85 DNG - Expand TRIVIAL-FORM-P inline in NO-SIDE-EFFECTS-P.;;;  7/26/85 DNG - For release 3, split file QCOPT into P1OPT, P1STYLE, and MACLISP.;;;   Removed support for function names in keyword package.;;;  8/17/85 DNG - Moved *LEXPR, *EXPR, and *FEXPR to MACLISP file.;;;  8/19/85 DNG - New functions INDEPENDENT-EXPRESSIONS-P and STORE-TO-SET.;;; 11/12/85 DNG - Separated file NUMOPT from this one.;;; 12/02/85 DNG - Modify NO-SIDE-EFFECTS-P to return false for a BREAKOFF-FUNCTION.;;; 12/20/85 DNG - Assorted improvements to comparison optimizations.;;;  1/14/86 DNG - New functions ARRAY-TYPE-OPT and SEARCH-EMPTY-LIST.;;;  2/25/86 DNG - Moved some handling of obsolete forms to file ZETALISP.;;;  4/02/86 DNG - Converted from Zetalisp to Common Lisp.;;;  4/21/86 DNG - Add optimization for ASSOC and RASSOC.;;;  4/24/86 DNG - Eliminate use of ARGS-INFO for VM2.;;;  5/10/86 DNG - Some re-arrangement for simplicity.;;;  5/12/86 DNG - New function FOLD-TYPE-PREDICATE.;;;  8/09/86 DNG - Deleted BOOLEAN-FUNCTIONS [use FUNCTION-RESULT-TYPE property instead].;;;  8/15/86 DNG - Functions DOEXPANDER, MAPEXPAND, and SUBSET-EXPAND deleted;;;and replaced by functions P1DO, P1MAPX, and P1SUBSET in file P1HAND.;;;Also replaced PROGV-EXPAND, PROGW-EXPAND, LET-IF-EXPAND, and;;;CALL-TO-MULTIPLE-VALUE-LIST by P1 handlers.  These were not really;;;optimizations, but rather the way of compiling these special forms.;;;  9/05/86 CLM - Add optimizer for MULTIPLE-VALUE-CALL's with only one form in the ;;;             arglist.;;;  9/16/86 DNG - Update use count of breakoff compilands.;;;  9/23/86 CLM - Add generic sequence optimizations.;;; 10/01/86 DNG - Moved INVULNERABLE-EXPRESSION-P to file P1DEFS.;;; 10/21/86 DNG - Eliminated use of REST1, REST2, REST3, and REST4.;;; 11/14/86 DNG - Add optimizer for SI:DISPLACED to fix SPR 2796.;;; 11/21/86 DNG - Optimize ASSOC and POSITION with a constant list.;;; 12/03/86 DNG - Fix MEMBER-EQL-MEMQ to not optimize POSITION when second arg is not a list.;;; 12/10/86 DNG - Enable constant folding for LISP:ELT [was SYS:COMMON-LISP-ELT].;;;  1/09/87 DNG - Modify FUNCALL-OPT to not use FUNCALL-SELF macro.;;;  2/09/87 DNG - Fix SYMEVAL-OPT for NIL argument.;;;  2/18/87 DNG - Enable folding of SI:STRING-EQUAL* and SI:STRING=* .;;;  2/23/87 DNG - Fixed STRING-SEARCH-STRING-SEARCH-CHAR to handle CONSIDER-CASE option correctly.;;;  3/12/87 DNG - Fix REFORM-ARG-LIST to default :START arg to 0.;;;  3/13/87 DNG - Added optimization for SEARCH.;; The following functions will be optimized by using an in-line expansion;; if value propagation and dead code elimination cut it down to be no ;; longer than the original call.(PROCLAIM '(TRY-INLINE GLOBAL:STRING GLOBAL:CHARACTER CHARACTER      SI::MEMBER-1 SI::ASSOC-1 SI::RASSOC-1 MAKE-SEQUENCE SUBSEQ      STATUS SI::RETURN-STATUS DEFPROP));Convenient way of computing function to expand into from original function.(DEFUN TRANSLATED-FUNCTION (FORM FUNCTION-ALIST)  (CDR (ASSOC (CAR FORM) FUNCTION-ALIST :TEST #'EQ)))(DEFUN FOLD-CONSTANTS (FORM)  "Replace an expression by its value...if it evaluates ok."  ;; 10/17/86 DNG - Use WARN-ON-ERRORS for consistency with other error messages.  ;;Use EVAL-FOR-TARGET instead of EVAL1.  (LET ((RESULT FORM))    (WARN-ON-ERRORS ('FOLD-CONSTANTS     "Error during constant-folding on ~S" FORM)      (LET ((VALUES (MULTIPLE-VALUE-LIST      (IF (WHEN-SUPPORTING-CROSS-COMPILATION T)  (EVAL-FOR-TARGET FORM)(SI:EVAL1 FORM)))))(SETQ RESULT      (IF (= (LENGTH VALUES) 1)  `(QUOTE ,(FIRST VALUES))(CONS 'VALUES (MAPCAR #'(LAMBDA (ELT) `(QUOTE ,ELT))      VALUES)))) ))    RESULT))#| old way(DEFUN FOLD-CONSTANTS (FORM)  "Replace an expression by its value...if it evaluates ok."  (LET (VALUE ERRORFLAG)    (SETF (VALUES VALUE ERRORFLAG)  (CATCH-ERROR (MULTIPLE-VALUE-LIST (SI:EVAL1 FORM))))    (COND (ERRORFLAG   (WARN 'CONSTANT-FOLDING :ERROR "Error during constant-folding on expression ~S" FORM)   FORM)  (T (IF (= (LENGTH VALUE) 1) `',(FIRST VALUE)       (CONS 'VALUES (MAPCAR #'(LAMBDA (ELT) `',ELT)     VALUE)))))))  ; Get multiple-values |#(DEFUN QUOTES-ANY-ARGS (FNAME)  ;; Given a function name, FNAME, returns true if the function is known to not  ;; evaluate all of its arguments in normal left-to-right order.  ;; This is similar in concept to function SPECIAL-FORM-P, but has   ;; the following differences:  ;;   * Since this is used during optimizations after P1, any &QUOTEd arguments  ;;     to otherwise normal functions have already been turned into QUOTE  ;;     forms, so they are of no concern here.  We only care about forms that  ;;     have special P2 handling rather than just being a function call or  ;;     a macro-instruction.  ;;   * Some functions such as PROGN which are implemented as  ;;     special forms are considered normal functions for our  ;;     purposes here.  ;;   * Since this is used during optimizations after P1, it   ;;     needs to recognize some internally-generated forms that  ;;     are special to P2 but are not defined outside the compiler.  ;;   * We don't need to check for macros because they will already  ;;     have been expanded.  ;; 2/13/85 - Return false for %DUP.  ;; 2/19/85 - Return false for *THROW and MULTIPLE-VALUE-PROG1.  ;; 3/07/85 - Return false for PROG2; remove use of #. to avoid  ;;           cross-compilation problem.  ;; 9/28/85 - Return false for VALUES and ARRAY-LEADER.  ;; 1/07/86 - Return false for %MAKE-EXPLICIT-STACK-LIST[*], MULTIPLE-VALUE-PROG1,  ;;           MULTIPLE-VALUE-LIST, VALUES-LIST, DONT-OPTIMIZE, NTH-VALUE,  ;;           and [LEXPR-]FUNCALL-WITH-MAPPING-TABLE-INTERNAL.  ;; 3/25/86 - Return false for LDB.  ;; 4/16/86 - Fix to return false for *THROW.  ;; 4/24/86 - Don't use %ARGS-INFO for VM2.  ;; 9/10/86 - Return false for %ASSURE-PDL-ROOM.  ;; 9/19/86 - Don't check function definition, just P2 property.  ;;10/13/86 - Return false for MULTIPLE-VALUE-CALL and %PUSH-VALUES-AND-COUNT.  (LET ((HANDLER (GET FNAME 'P2)))    (AND HANDLER (NOT (MEMBER HANDLER '(P2-AR-1 P2-SET-AR-1 P2DEST) :TEST #'EQ)) (NOT (MEMBER FNAME      '(PROGN PROG1 PROG2 FUNCALL LEXPR-FUNCALL APPLY ATOM NOT%PUSH %POP %DUP %CALL %PUSH-VALUES-AND-COUNT LDB%MAKE-EXPLICIT-STACK-LIST %MAKE-EXPLICIT-STACK-LIST*FLOOR CEILING TRUNCATE ROUND MOD REMVALUES VALUES-LIST %ASSURE-PDL-ROOM MULTIPLE-VALUE-CALL MULTIPLE-VALUE-PROG1 MULTIPLE-VALUE-LIST DONT-OPTIMIZE NTH-VALUEFUNCALL-WITH-MAPPING-TABLE-INTERNALLEXPR-FUNCALL-WITH-MAPPING-TABLE-INTERNAL *THROW THROW)      :TEST #'EQ)))));;;;        ==================================;;;;           Bookkeeping utilities;;;;        ==================================(DEFUN DISCARD (FORM &AUX TAG) ;; This function is applied to a Lisp form that been processed ;; by P1 but is now being deleted ;; by optimization; it performs any bookkeeping needed. ;; 12/29/84 DNG - Original. ;;  1/23/85 DNG - Decrement tag use count when GO or RETURN deleted. ;;  1/26/85 DNG - Handle some special forms. ;;  9/09/86 DNG - Decrement use count of BREAKOFF-FUNCTION. ;;  9/30/86 DNG - Don't decrement EXPRESSION-SIZE for (UNDEFINED-VALUE).  (DECLARE (SPECIAL EXPRESSION-SIZE 1-IF-LIVE-CODE)) ; declared in QCP1  (UNLESS (ZEROP 1-IF-LIVE-CODE); unless this was dead code to begin with    (WHEN (EQUAL FORM '(UNDEFINED-VALUE))      ;; doesn't generate any code so not counted in expression size.      (RETURN-FROM DISCARD))    (DEBUG-ASSERT (< 0 EXPRESSION-SIZE))    (WHEN (EQ (CAR-SAFE FORM) 'THE-EXPR)      (RETURN-FROM DISCARD (DISCARD (EXPR-FORM FORM))))    (DECF EXPRESSION-SIZE 1)    (COND      ((TRIVIAL-FORM-P FORM)       (COND ((ATOM FORM))     ((EQ (CAR FORM) 'LOCAL-REF)      (DEBUG-ASSERT (< 0 (VAR-USE-COUNT (SECOND FORM))))      (DECF (VAR-USE-COUNT (SECOND FORM)) 1))     ((EQ (CAR FORM) 'BREAKOFF-FUNCTION)      (DEBUG-ASSERT (< 0 (COMPILAND-USE-COUNT (SECOND FORM))))      (DECF (COMPILAND-USE-COUNT (SECOND FORM)) 1))))      ((EQ (FIRST FORM) 'GO)       (SETQ TAG (SECOND FORM)))      ((EQ (FIRST FORM) 'RETURN-FROM)       (SETQ TAG (PROGDESC-RETTAG (SECOND FORM)))       (DISCARD (THIRD FORM)))      ((NULL (REST FORM)))      ((> (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH)  (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)))      ((MEMBER (FIRST FORM) '(LET LET* LET-FOR-LAMBDA)       :TEST #'EQ)       (DISCARD-FORMS (NTHCDR 7 FORM)) ; discard the body forms       ;; call LET-OPT to clean up initialization forms       (LET-OPT (LIST (FIRST FORM); LET      (SECOND FORM); lambda list      (THIRD FORM); outer vars      (FOURTH FORM); inner vars      NIL; bindp      0 0; lexical breakoff counts      ) ; empty bodyT)) ; delete all      ((MEMBER (FIRST FORM) '(BLOCK BLOCK-FOR-PROG       BLOCK-FOR-WITH-STACK-LIST)       :TEST #'EQ)       (DISCARD-FORMS (CDDDR FORM)))      ((EQ (FIRST FORM) 'TAGBODY)       (DOLIST (ARG (CDDR FORM)) (UNLESS (ATOM ARG)   (DISCARD ARG))))      ((EQ (FIRST FORM) 'COND)       (DOLIST (CLAUSE (REST FORM)) (DISCARD-FORMS CLAUSE)))      ((AND (NOT (MEMBER (FIRST FORM) '(SETQ INTERNAL-PSETQ AND OR) :TEST #'EQ))  (QUOTES-ANY-ARGS (FIRST FORM))))      ((NULL (CDDR FORM))       (RETURN-FROM DISCARD (DISCARD (SECOND FORM))))      (T (DISCARD-FORMS (REST FORM))))    (UNLESS (NULL TAG)      (LET ((GOTAG (GOTAGS-SEARCH TAG T)))(UNLESS (NULL GOTAG) ; won't find it when whole TAGBODY is being discarded  (DEBUG-ASSERT (> (GOTAG-USE-COUNT GOTAG) 0))  (DECF (GOTAG-USE-COUNT GOTAG))))))  NIL)(DEFUN DISCARD-FORMS (FORMS-LIST) ;; 12/28/84 DNG - Original.  (DOLIST (FORM FORMS-LIST)    (DISCARD FORM)))(DEFUN INC-VAR-USE (VAR-FORM) ;; Increment the use count of a variable.  This needs to be used ;; when an optimization creates an additional reference. ;; The argument form is returned as the value. ;; 2/5/85 DNG - Original. ;; 3/6/85 DNG - Increment EXPRESSION-SIZE also. ;; 9/16/86 - Handle BREAKOFF-FUNCTION.  (DECLARE (SPECIAL EXPRESSION-SIZE 1-IF-LIVE-CODE)) ; declared in QCP1  (DEBUG-ASSERT (TRIVIAL-FORM-P VAR-FORM)) ; recursive traversal not needed  (COND ((ATOM VAR-FORM))((EQ (CAR VAR-FORM) 'LOCAL-REF) (INCF (VAR-USE-COUNT (SECOND VAR-FORM)) 1))((EQ (CAR VAR-FORM) 'BREAKOFF-FUNCTION) (INCF (COMPILAND-USE-COUNT (SECOND VAR-FORM)) 1)))  (INCF EXPRESSION-SIZE 1-IF-LIVE-CODE)  VAR-FORM);;;;        ==================================;;;;           Constant folding;;;;        ==================================(ADD-POST-OPTIMIZER EQUALARITH-OPT-NON-ASSOCIATIVE)(ADD-POST-OPTIMIZER EQLARITH-OPT-NON-ASSOCIATIVE)(ADD-POST-OPTIMIZER EQUALPARITH-OPT-NON-ASSOCIATIVE)(ADD-POST-OPTIMIZER MEMQARITH-OPT-NON-ASSOCIATIVE)(ADD-POST-OPTIMIZER ASSQARITH-OPT-NON-ASSOCIATIVE)(ADD-POST-OPTIMIZER RASSQARITH-OPT-NON-ASSOCIATIVE)(ADD-POST-OPTIMIZER REMQARITH-OPT-NON-ASSOCIATIVE)(ADD-POST-OPTIMIZER NOTFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CAAAARFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CAAADRFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CAADARFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CAADDRFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CADAARFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CADADRFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CADDARFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CADDDRFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CDAAARFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CDAADRFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CDADARFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CDADDRFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CDDAARFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CDDADRFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CDDDARFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CDDDDRFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CDDDDR-SAFEFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CAR-SAFEFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CDR-SAFEFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CADR-SAFEFOLD-ONE-ARG)(ADD-POST-OPTIMIZER CDDR-SAFEFOLD-ONE-ARG)(ADD-POST-OPTIMIZER LASTFOLD-ONE-ARG)(ADD-POST-OPTIMIZER PAIRLISARITH-OPT-NON-ASSOCIATIVE)(ADD-POST-OPTIMIZER GLOBAL:AR-1ARITH-OPT-NON-ASSOCIATIVE)(ADD-POST-OPTIMIZER COMMON-LISP-AR-1 ARITH-OPT-NON-ASSOCIATIVE)(ADD-POST-OPTIMIZER ELTARITH-OPT-NON-ASSOCIATIVE)(ADD-POST-OPTIMIZER GLOBAL:ELTARITH-OPT-NON-ASSOCIATIVE)(ADD-POST-OPTIMIZER COMMON-LISP-ELT ARITH-OPT-NON-ASSOCIATIVE)(ADD-POST-OPTIMIZER ATOM(FOLD-TYPE-PREDICATE ATOM))(ADD-POST-OPTIMIZER SYMBOLP(FOLD-TYPE-PREDICATE SYMBOL))(ADD-POST-OPTIMIZER GLOBAL:LISTP(FOLD-TYPE-PREDICATE CONS))(ADD-POST-OPTIMIZER LISTP(FOLD-TYPE-PREDICATE LIST))(ADD-POST-OPTIMIZER COMMON-LISP-LISTP (FOLD-TYPE-PREDICATE LIST))(ADD-POST-OPTIMIZER STRINGP(FOLD-TYPE-PREDICATE #.(SI:TYPE-CANONICALIZE 'STRING)))(ADD-POST-OPTIMIZER VECTORP(FOLD-TYPE-PREDICATE #.(SI:TYPE-CANONICALIZE 'VECTOR)))(ADD-POST-OPTIMIZER BIT-VECTOR-P (FOLD-TYPE-PREDICATE #.(SI:TYPE-CANONICALIZE 'BIT-VECTOR)))(ADD-POST-OPTIMIZER PATHNAMEPFOLD-ONE-ARG)(ADD-POST-OPTIMIZER STREAMPFOLD-ONE-ARG)(ADD-POST-OPTIMIZER COMMONP(FOLD-TYPE-PREDICATE COMMON))(ADD-POST-OPTIMIZER CONSTANTPFOLD-ONE-ARG)(ADD-POST-OPTIMIZER LOCATIVEP(FOLD-TYPE-PREDICATE LOCATIVE))(ADD-POST-OPTIMIZER GLOBAL:NLISTP (FOLD-TYPE-PREDICATE ATOM))(ADD-POST-OPTIMIZER NSYMBOLPFOLD-ONE-ARG)(ADD-POST-OPTIMIZER SIMPLE-BIT-VECTOR-PFOLD-ONE-ARG)(ADD-POST-OPTIMIZER SIMPLE-STRING-PFOLD-ONE-ARG)(ADD-POST-OPTIMIZER SIMPLE-ARRAY-PFOLD-ONE-ARG)(ADD-POST-OPTIMIZER SIMPLE-VECTOR-PFOLD-ONE-ARG)(ADD-POST-OPTIMIZER ARRAYP(FOLD-TYPE-PREDICATE ARRAY))(ADD-POST-OPTIMIZER NAMED-STRUCTURE-P(FOLD-TYPE-PREDICATE NAMED-STRUCTURE))(ADD-POST-OPTIMIZER ENDPFOLD-ONE-ARG)                                               (ADD-POST-OPTIMIZER LENGTHFOLD-ONE-ARG)(ADD-POST-OPTIMIZER STRINGFOLD-ONE-ARG)(ADD-POST-OPTIMIZER STRING-LENGTH FOLD-ONE-ARG)   (ADD-POST-OPTIMIZER ARRAY-RANKFOLD-ONE-ARG)(ADD-POST-OPTIMIZER LIST-LENGTH FOLD-ONE-ARG)                                                                               (DEFUN ARITH-OPT-NON-ASSOCIATIVE (FORM)  (IF (LOOP FOR ARG IN (CDR FORM)    ALWAYS (AND (CONSP ARG)(EQ (FIRST ARG) 'QUOTE)))      (FOLD-CONSTANTS FORM)    FORM))(DEFUN FOLD-ONE-ARG (FORM)  ;; fold function of a single argument  ;; The only reason for using this instead of ARITH-OPT-NON-ASSOCIATIVE is  ;; that this is faster.  (DECLARE (INLINE QUOTEP))  (IF (AND (REST FORM)   ; not less than 1 argument   (NOT (CDDR FORM))   ; not more than 1 argument   (QUOTEP (SECOND FORM)))      (FOLD-CONSTANTS FORM)    FORM))            ;;;;        ==================================;;;;           Function calling optimization;;;;        ==================================(DEFUN CALL-FUNCTION (FUNCTION-EXP ARG-EXPS)  (IF (AND (CONSP FUNCTION-EXP)   (MEMBER (CAR FUNCTION-EXP) '(FUNCTION QUOTE) :TEST #'EQ)   (FUNCTIONP (CADR FUNCTION-EXP)))      `(,(CADR FUNCTION-EXP) . ,ARG-EXPS)    `(FUNCALL ,FUNCTION-EXP ,@ARG-EXPS)));Optimize (FUNCALL (FUNCTION (LAMBDA ...)) ...) into ((LAMBDA ...) ...).;Does not optimize (FUNCALL (FUNCTION FOO) ...) if FOO is not defined;or takes quoted args (FUNCTIONP checks for that).;Normally, this transformation is done within P1, but it can happen here;when the FUNCTION form results from value propagation during TAGBODY;optimization.(ADD-OPTIMIZER FUNCALL FUNCALL-OPT)(DEFUN FUNCALL-OPT (FORM)  ;; 4/04/85 - Created so optimization of  ;;              (FUNCALL #'(LAMBDA ...)...) ==> ((LAMBDA...)...)  ;;           is done before BREAKOFF gets called.  ;; 5/10/86 - Merged FUNCALL-LAMBDA and OPTIMIZE-FUNCALL-SELF into this  ;;single function.  ;; 6/25/86 - Fix to not optimize (FUNCALL '#<DTP-FUNCTION ...> ...).  ;; 1/09/87 - Use %FUNCTION-INSIDE-SELF directly instead of FUNCALL-SELF macro.  (LET ((FNFORM (SECOND FORM)))    (IF (AND (NOT (ATOM FNFORM))     (MEMBER (FIRST FNFORM) '(FUNCTION QUOTE) :TEST #'EQ)     (OR (SYMBOLP (SECOND FNFORM)) (CONSP (SECOND FNFORM)))     (FUNCTIONP (SECOND FNFORM)))(CONS (SECOND FNFORM) (CDDR FORM))      ;; Turn (FUNCALL SELF ...) into (FUNCALL-SELF ...) if within a method or      ;; a function with a :SELF-FLAVOR declaration.      ;; Leave it alone otherwise -- that would be a pessimization.      ;; [ %%% in release 4 this should be moved to the post-optimizer %%% ]      (IF (AND (EQ FNFORM 'SELF)       (NOT (NULL SELF-FLAVOR-DECLARATION)))  `(FUNCALL (%FUNCTION-INSIDE-SELF) . ,(CDDR FORM))FORM))))(ADD-POST-OPTIMIZER FUNCALL FUNCALL-FUNCTION)(DEFUN FUNCALL-FUNCTION (FORM)  ;; 1/26/85 - Changed from pre-optimizer to post-optimizer.  ;; 1/06/86 - Disable style checks for P1 call.  ;; 6/25/86 - Fix to not optimize (FUNCALL '#<DTP-FUNCTION ...> ...).  ;; 7/17/86 - Inline expansion of local functions.  ;; 9/09/86 - Increment COMPILAND-USE-COUNT when expanded inline.  ;; 9/19/86 - Use MARK-P1-DONE instead of P1-ALREADY-DONE; abort recursive inline expansion.  ;; 10/1/86 - COMPILAND-BREAKOFF-COUNT replaced by COMPILAND-CHILDREN.  (LET ((FNFORM (SECOND FORM)))    (IF (ATOM FNFORM)FORM      (IF (AND (MEMBER (CAR FNFORM) '(FUNCTION QUOTE) :TEST #'EQ)       (OR (SYMBOLP (SECOND FNFORM))   (CONSP (SECOND FNFORM)))       (FUNCTIONP (SECOND FNFORM)))  ;; Pass the new call through P1 to enable DEFSUBST expansion  ;; and pre-optimizations.  (LET ((INHIBIT-STYLE-WARNINGS-SWITCH T))    (DISCARD FNFORM)    (P1      (CONS (SECOND FNFORM)    (LOOP FOR ARG IN (CDDR FORM)  COLLECT (MARK-P1-DONE ARG)))))(LET (( VAR-REF NIL ))  (WHEN (AND (EQ (FIRST FNFORM) 'LOCAL-REF)     (DOLIST (X LOCAL-FUNCTIONS NIL)       (WHEN (EQ (SECOND FNFORM) (SECOND X)) (SETQ VAR-REF FNFORM) (RETURN T))))    (SETQ FNFORM (SECOND (VAR-INIT (SECOND FNFORM)))))  (OR (AND (MEMBER (FIRST FNFORM) '( BREAKOFF-FUNCTION LEXICAL-CLOSURE ) :TEST #'EQ)   (LET* (( FC (SECOND FNFORM) )  ( NAME (COMPILAND-FUNCTION-SPEC FC) )  ( INDECL (INLINE-DECL NAME) ))     (LET ((TM (ASSOC NAME INLINE-EXPANSIONS :TEST #'EQ)))       (WHEN TM ;; This is a recursive call to a function which we are ;;   currently in the process of expanding inline. ;; Abort the inline expansion. (THROW (SECOND TM) 'RECURSIVE) ))     (AND (OR (EQ INDECL 'INLINE)      (EQ INDECL 'TRY-INLINE)      (AND (NEQ INDECL 'NOTINLINE)   (< (COMPILAND-EXPRESSION-SIZE FC) 30.)   (>= (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)       (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH))   (>= (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)       (OPT-SAFETY OPTIMIZE-SWITCH))   (< (LENGTH (COMPILAND-ALLVARS FC)) 12.)))  (NULL (COMPILAND-CHILDREN FC))  (EQ (COMPILAND-FLAVOR FC) SELF-FLAVOR-DECLARATION)  (LET (( EXPANSION  (PROCEDURE-INTEGRATION   NAME (CDDR FORM) (COMPILAND-DEFINITION FC)   INDECL (COMPILAND-DEBUG-INFO FC) FC) ))    (UNLESS (NULL EXPANSION)      (UNLESS (NULL VAR-REF)(DECF (VAR-USE-COUNT (SECOND VAR-REF))))      (INCF (COMPILAND-USE-COUNT FC))      EXPANSION) ))))      FORM))))));;; Turn (MULTIPLE-VALUE-BIND (one-variable) (form) body...) into;;;   (LET ((one-variable form)) body...)(ADD-OPTIMIZER MULTIPLE-VALUE-BIND OPTIMIZE-SIMPLE-MV-BIND)(DEFUN OPTIMIZE-SIMPLE-MV-BIND (FORM)  (IF (/= (LENGTH (SECOND FORM)) 1)      FORM   ; Actually looking for >=2 values    `(LET ((,(CAR (SECOND FORM)) ,(THIRD FORM)))       ,@(CDDDR FORM))))(ADD-OPTIMIZER LEXPR-FUNCALL LEXPR-FUNCALL-ON-ONE)(ADD-OPTIMIZER APPLY LEXPR-FUNCALL-ON-ONE)(DEFUN LEXPR-FUNCALL-ON-ONE (FORM)  ;;  5/06/86 DNG - Give warning on APPLY with only one arg in Common Lisp.  ;; 10/13/86 DNG - No longer need to convert APPLY to LEXPR-FUNCALL.  (COND ((= (LENGTH FORM) 2) (WHEN (AND COMPILING-COMMON-LISP    (EQ (FIRST FORM) 'APPLY)    (NULL INHIBIT-STYLE-WARNINGS-SWITCH)    OBSOLETE-FUNCTION-WARNING-SWITCH)   (WARN 'LEXPR-FUNCALL-ON-ONE ':OBSOLETE "APPLY with only one argument is obsolete; use (APPLY (CAR arg) (CDR arg)).")) (LET ((ARG (CADR FORM)))   (ONCE-ONLY (ARG)     `(LEXPR-FUNCALL (CAR ,ARG) (CDR ,ARG)))))(T FORM)))(ADD-POST-OPTIMIZER APPLY  APPLY-POST-OPT)(ADD-POST-OPTIMIZER LEXPR-FUNCALL APPLY-POST-OPT);; 12/27/84 DNG - Changed from pre- to post-optimizer.(DEFUN APPLY-POST-OPT (FORM)  ;; 12/20/85 DNG - Fix to optimize when last argument is NIL.  ;;  8/28/86 CLM - Add test so that a quoted rest arg will not be  ;;                de-listed  ;; 10/13/86 DNG - Merged functions OPTIMIZE-LEXPR-FUNCALL-SELF and LEXPR-FUNCALL-ON-LIST . (IF (AND (NOT (NULL SELF-FLAVOR-DECLARATION))  (EQ (SECOND FORM) 'SELF))     `(LEXPR-FUNCALL (%FUNCTION-INSIDE-SELF) ,@(CDDR FORM))   (LET ((LASTARG (CAR (LAST FORM))) (FIRSTARG (CADR FORM)))     (COND       ((ATOM LASTARG) FORM)       ((MEMBER (CAR LASTARG) '(LIST NCONS) :TEST #'EQ);; If function to be called is quoted symbol, optimize out the "funcall";; in case the symbol is a subst function.(CALL-FUNCTION FIRSTARG (NCONC (BUTLAST (CDDR FORM)) (CDR LASTARG))))       ((MEMBER (CAR LASTARG) '(LIST* CONS) :TEST #'EQ)`(LEXPR-FUNCALL ,@(BUTLAST (CDR FORM)) ,@(CDR LASTARG)))       ((AND (EQ (CAR LASTARG) 'QUOTE)     (LISTP (CADR LASTARG))     (< (length (cadr lastarg)) 2))`(FUNCALL ,@(BUTLAST (CDR FORM))  ,@(MAPCAR #'(LAMBDA (X) (LIST 'QUOTE X))    (CADR LASTARG))))       (T FORM)))))(ADD-OPTIMIZER MULTIPLE-VALUE-CALL MULTIPLE-VALUE-CALL-OPT)(DEFUN MULTIPLE-VALUE-CALL-OPT (FORM)  ;;  9/05/86 CLM - Original.  If there is only one form in  ;;                the arglist of the function argument, do  ;;                not expand MULTIPLE-VALUE-CALL.  Instead  ;;                use the pass 2 handler.  ;;  9/13/86 DNG - Include the expansion for the default case here since  ;;MULTIPLE-VALUE-CALL is being changed from a macro to a special form.  ;; 10/07/86 DNG - Optimization not applicable to VM1.  ;; 10/13/86 DNG - Re-designed to use pass 1 handler for MULTIPLE-VALUE-CALL.  (LET ((ARGLIST (CDDR FORM)))    (DECLARE (UNSPECIAL ARGLIST)(LIST ARGLIST))    (COND ((EVERY #'TRIVIAL-FORM-P ARGLIST) ; multiple values not possible   `(FUNCALL ,(SECOND FORM) . ,ARGLIST))  ((NOT (COMPILING-FOR-V2))   `(CALL ,(SECOND FORM)  . ,(MAPCAN #'(LAMBDA (FORM) `(':SPREAD (MULTIPLE-VALUE-LIST ,FORM)))     ARGLIST)) )  #-Elroy ; temporary name change to avoid release 2 macro  (T (CONS 'MULT-VALUE-CALL (REST FORM)))  (T FORM))))(ADD-POST-OPTIMIZER MULTIPLE-VALUE-CALL MULT-VALUE-CALL-OPT)(DEFUN MULT-VALUE-CALL-OPT (FORM)  ;; 10/13/86 DNG - Original.  (debug-assert (= (length form) 3)) ; ensured by pass 1 handler  (LET ((FUNCTION (SECOND FORM))(ARG (THIRD FORM)))    (COND ((TRIVIAL-FORM-P ARG)   `(FUNCALL . ,(REST FORM)))  ((EQUAL FUNCTION '(FUNCTION LIST))   `(MULTIPLE-VALUE-LIST ,ARG))  ((EQ (FIRST ARG) 'VALUES)   `(FUNCALL ,FUNCTION . ,(REST ARG)))  ((EQ (FIRST ARG) 'VALUES-LIST)   `(APPLY ,FUNCTION ,(SECOND ARG)))  (T FORM) )));;;;        ==================================;;;;           Optimize list operations;;;;        ==================================#|  folding of LIST not actually included yet because it could be dangerous --    if the list is going to be altered, then it really does need to be built at run time.(ADD-POST-OPTIMIZER LIST FOLD-LIST)(ADD-POST-OPTIMIZER LIST* FOLD-LIST)(ADD-POST-OPTIMIZER CONS FOLD-LIST)(DEFUN FOLD-LIST (FORM)  (IF (LOOP FOR ARG IN (REST FORM)    ALWAYS (QUOTEP ARG))      (LET ((DEFAULT-CONS-AREA WORKING-STORAGE-AREA))(FOLD-CONSTANTS FORM))    FORM))|#(ADD-POST-OPTIMIZER LIST LIST-OPT)(DEFUN LIST-OPT (FORM)  (COND ((NULL (REST FORM)); (LIST)   ==> NIL         '(QUOTE NIL))     #|    -- this optimization removed 6/25/85 because NCONS              does not do CDR-coding and is only negligably faster.((NULL (CDDR FORM)) ; (LIST x) ==> (NCONS x) `(NCONS ,(SECOND FORM)))     |#        (T FORM)))(ADD-POST-OPTIMIZER LIST* LIST*-OPT)(DEFUN LIST*-OPT (FORM)  (COND    ((NULL (REST FORM)); (LIST*)   ==> NIL     '(QUOTE NIL))    ((NULL (CDDR FORM)); (LIST* x) ==> x     (SECOND FORM))    ((NULL (CDDDR FORM)); (LIST* x y) ==> (CONS x y)     `(CONS . ,(REST FORM)))    (T FORM)))(ADD-POST-OPTIMIZER LENGTH LENGTH-OPT)(DEFUN LENGTH-OPT (FORM); (LENGTH (LIST a b)) ==> (PROGN a b 2)  ;;  1/04/85 - Original.  (LET ((ARG (SECOND FORM)))    (IF (AND (CONSP ARG)     (MEMBER (FIRST ARG) '(LIST NCONS) :TEST #'EQ))(CONS 'PROGN      (APPEND (REST ARG) (LIST (LIST 'QUOTE (LENGTH (REST ARG))))))      FORM)))(ADD-POST-OPTIMIZER APPEND APPEND-OPT)(DEFUN APPEND-OPT (FORM)  ;; 2/19/85 - Original.  ;; 6/25/85 - Change two-argument call to use *APPEND.  (IF (= (LENGTH FORM) 3)   ; two arguments      (IF (AND (CONSP (SECOND FORM))       (EQ (FIRST (SECOND FORM)) 'LIST))  ;; (APPEND (LIST x y) z) ==> (LIST* x y z)  `(LIST* ,@(REST (SECOND FORM)) ,(THIRD FORM));; (APPEND x y) ==> (*APPEND x y)(CONS 'SI::*APPEND (REST FORM)))    FORM))(ADD-POST-OPTIMIZER ENDP ENDP-OPT)(DEFUN ENDP-OPT (FORM)  ;;  5/12/86 DNG - Add check for (EQ P1VALUE 'D-INDS).  (IF (OR (AND (EQ P1VALUE 'D-INDS)       (> (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)  (OPT-SAFETY OPTIMIZE-SWITCH)))  (EQ TARGET-PROCESSOR :CADR)) ; ENDP instruction broken on Cadr      ;; Use ATOM for efficiency.      `(ATOM ,(SECOND FORM))    ;; Use ENDP instruction for full error checking.    FORM));;; Find simple calls to MAKE-LIST and convert them into calls to the;;; microcoded %MAKE-LIST.  NOTE THAT THIS CHANGES ORDER OF EVALUATION!(ADD-POST-OPTIMIZER MAKE-LIST MAKE-LIST-%MAKE-LIST %MAKE-LIST)(DEFUN MAKE-LIST-%MAKE-LIST (FORM) ;;  2/25/86 DNG - Changed from a pre- to a post- optimizer; moved ;;handling of obsolete style to file ZETALISP; simplify by ;;using RETURN-FROM instead of *THROW.  (IF (ODDP (LENGTH FORM))      FORM    (BLOCK GIVE-UP      (LET ((AREA-FORM '(QUOTE NIL))    (INITIAL-VALUE-FORM '(QUOTE NIL)))(DO ((OPTIONS (CDDR FORM) (CDDR OPTIONS)))    ((NULL OPTIONS))  (LET ((KEYWORD-FORM (FIRST OPTIONS)) (VALUE-FORM (SECOND OPTIONS)));; If the keyword form isn't a quoted symbol, punt.    (WHEN (OR (ATOM KEYWORD-FORM)      (/= (LENGTH KEYWORD-FORM) 2)      (NEQ (FIRST KEYWORD-FORM) 'QUOTE)      (NOT (SYMBOLP (SECOND KEYWORD-FORM))))      (RETURN-FROM GIVE-UP FORM))    (CASE (SECOND KEYWORD-FORM)      (:AREA (SETQ AREA-FORM VALUE-FORM))      ((:INITIAL-VALUE :INITIAL-ELEMENT)       (SETQ INITIAL-VALUE-FORM VALUE-FORM))      (OTHERWISE (RETURN-FROM GIVE-UP FORM)))))`(%MAKE-LIST ,INITIAL-VALUE-FORM ,AREA-FORM ,(SECOND FORM))))))(ADD-POST-OPTIMIZER CONS CONS-LIST);;  optimization on CONS:  (CONS x NIL)        ==> (NCONS x);;                         (CONS x (NCONS y))  ==> (LIST x y);;                         (CONS x (LIST y z)) ==> (LIST x y z)(DEFUN CONS-LIST (FORM)  (IF (ATOM (THIRD FORM))      FORM    (CASE (FIRST (THIRD FORM))      (LIST `(LIST ,(SECOND FORM) ,@(REST (THIRD FORM))))      (NCONS `(LIST ,(SECOND FORM) ,(SECOND (THIRD FORM))))      '(IF (NULL (SECOND (THIRD FORM)))   `(NCONS ,(SECOND FORM)) FORM)      (OTHERWISE FORM))))                               (ADD-POST-OPTIMIZER NCONC NCONC-OPT)(DEFUN NCONC-OPT (FORM); (NCONC x NIL) ==> x  ;;  6/25/85 - Change two-argument NCONC to *NCONC.  (IF (AND (EQUAL (THIRD FORM) '(QUOTE NIL))   ;; Don't optimize if SAFETY is preferred since it might   ;; hide an error if the first argument is not a list.   (>= (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH) (OPT-SAFETY OPTIMIZE-SWITCH)))      (IF (CDDDR FORM)  (LIST* (FIRST FORM) (SECOND FORM) (CDDDR FORM))(SECOND FORM))    (IF (NULL (CDDDR FORM))   ; (NCONC x y) ==> (*NCONC x y)(CONS 'SI::*NCONC (REST FORM))      FORM)))                                                                                ;The following are here to make list-type structures work more efficiently.;It's easier to put the optimization in the compiler than in DEFSTRUCT.(ADD-POST-OPTIMIZER NTH NTH-OPTIMIZE)(ADD-POST-OPTIMIZER NTHCDR NTHCDR-OPTIMIZE)(DEFUN NTH-OPTIMIZE (X)  (LET ((NUM (QUOTE-NUMBER (CADR X))))    (IF (NULL NUM)X      (LET ((TEM (ASSOC NUM '((0 . CAR) (1 . CADR) (2 . CADDR) (3 . CADDDR)):TEST #'EQUAL)))(IF TEM    `(,(CDR TEM) ,(CADDR X))  X)))))(DEFUN NTHCDR-OPTIMIZE (X)  (LET ((NUM (QUOTE-NUMBER (CADR X))))    (IF (NULL NUM)X      (LET ((TEM (ASSOC NUM '((1 . CDR) (2 . CDDR) (3 . CDDDR) (4 . CDDDDR)):TEST #'EQUAL)))(COND ((ZEROP NUM) (CADDR X))      (TEM `(,(CDR TEM) ,(CADDR X)))      (T X))))));;; Optimize (CAR (CDR X)) into (CADR X) -- LOOP generates this all the time.(DEFCONSTANT CXRS   '(CAR CDR CAAR CADR CDAR CDDR     CAAAR CAADR CADAR CADDR CDAAR CDADR CDDAR CDDDR     CAAAAR CAAADR CAADAR CAADDR CADAAR CADADR CADDAR CADDDR     CDAAAR CDAADR CDADAR CDADDR CDDAAR CDDADR CDDDAR CDDDDR))#+Elroy(progn;; Note: the '#. in the following forms is because the release 3 evaluator was;;       crashing while trying to process the CXR-POP-TABLE initialization;; during cold-band crash-list processing.   -- D.N.G. 5/2/86(DEFCONSTANT 3CXRS '#.(FIRSTN 14 CXRS))(DEFCONSTANT CXR-POP-TABLE  '#.(LOOP FOR SYM IN (CDDR CXRS)   COLLECTING (CONS SYM    (INTERN (STRING-APPEND #\C (SUBSTRING SYM 2))))))(DEFCONSTANT CXR-APPEND-TABLE  '#.(LOOP FOR SYM IN 3CXRS   AS FIRST = (SUBSTRING (SYMBOL-NAME SYM) 0 (1- (ARRAY-ACTIVE-LENGTH (SYMBOL-NAME SYM))))   COLLECT (LIST SYM (INTERN (STRING-APPEND FIRST "AR")) (INTERN (STRING-APPEND FIRST "DR"))))))#-Elroy(progn;; Note: This version does not use #. because the release 2 EVAL-FOR-TARGET;; can't handle the local variables generated by LOOP. -- D.N.G. 6/25/86(DEFCONSTANT 3CXRS (FIRSTN 14 CXRS))(DEFCONSTANT CXR-POP-TABLE     (LOOP FOR SYM IN (CDDR CXRS)   COLLECTING (CONS SYM    (INTERN (STRING-APPEND #\C (SUBSTRING SYM 2))))))(DEFCONSTANT CXR-APPEND-TABLE     (LOOP FOR SYM IN 3CXRS   AS FIRST = (SUBSTRING (SYMBOL-NAME SYM) 0 (1- (ARRAY-ACTIVE-LENGTH (SYMBOL-NAME SYM))))   COLLECT (LIST SYM (INTERN (STRING-APPEND FIRST "AR")) (INTERN (STRING-APPEND FIRST "DR"))))))(EVAL-WHEN (EVAL LOAD) (DOLIST (X 3CXRS) (SETF (GET X 'POST-OPTIMIZERS) '(3CXR-OPTIMIZE))))(DEFUN 3CXR-OPTIMIZE (FORM) ;; 12/29/84 - Optimize LIST argument and fold constants.  (LET ((ARGFORM (CADR FORM)))    (COND      ((ATOM ARGFORM) FORM)      ((MEMBER (CAR ARGFORM) CXRS :TEST #'EQ)       `(,(FUNCALL (IF (= (CHAR (SYMBOL-NAME (CAR ARGFORM)) 1) #\A)       #'CADR     #'CADDR)   (ASSOC (CAR FORM) CXR-APPEND-TABLE :TEST #'EQ)) ,(LET ((X (CDR (ASSOC (CAR ARGFORM) CXR-POP-TABLE :TEST #'EQ))))    (IF X      `(,X . ,(CDR ARGFORM))      (CADR ARGFORM)))))      ((AND (MEMBER (FIRST ARGFORM) '(LIST NCONS) :TEST #'EQ)    (< (OPT-SAFETY OPTIMIZE-SWITCH)       (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))    (NO-SIDE-EFFECTS-P ARGFORM))       (LET ((NEW-FORM (OR (FUNCALL (FIRST FORM) (REST ARGFORM))   '(QUOTE NIL)))) (DOLIST (ARG (REST ARGFORM))   (UNLESS (EQ ARG NEW-FORM)     (DISCARD ARG))) NEW-FORM))      ((EQ (FIRST ARGFORM) 'QUOTE)       (FOLD-CONSTANTS FORM))      (T FORM))))(ADD-POST-OPTIMIZER CAR CAR-OPT)(DEFUN CAR-OPT (FORM)  ;; 12/29/84 - Original.  (LET ((ARGFORM (SECOND FORM)))    (COND ((ATOM ARGFORM) FORM)  ((MEMBER (FIRST ARGFORM) '(CONS LIST LIST* NCONS) :TEST #'EQ)   `(PROG1 . ,(REST ARGFORM)))   ; (CAR (LIST x y ...)) ==> (PROG1 x y ...)  (T FORM))))(ADD-POST-OPTIMIZER CDR CDR-OPT)(DEFUN CDR-OPT (FORM) ;; 12/29/84 - Original. ;; 10/21/86 - Call POST-OPTIMIZE on new LIST form.  (LET ((ARGFORM (SECOND FORM)))    (COND      ((ATOM ARGFORM) FORM)      ((EQ (FIRST ARGFORM) 'LIST); (CDR (LIST x y ...)) ==> (PROGN x (LIST y ...))       `(PROGN  ,(SECOND ARGFORM)  ,(POST-OPTIMIZE (CONS (FIRST ARGFORM) (CDDR ARGFORM)))))      ((EQ (FIRST ARGFORM) 'CONS); (CDR (CONS x y))     ==> (PROGN x y)       `(PROGN . ,(REST ARGFORM)))      ((EQ (FIRST ARGFORM) 'NCONS); (CDR (NCONS x))      ==> (PROGN x NIL)       `(PROGN  ,(SECOND ARGFORM)  (QUOTE NIL)))      (T FORM))))(ADD-POST-OPTIMIZER VALUES-LIST VLOPT)(DEFUN VLOPT (FORM) ;;  1/15/86 DNG - Original.  Previously optimized in pass 2. ;;  9/19/86 DNG - Use MARK-P1-DONE instead of P1-ALREADY-DONE. ;; 11/04/86 DNG - When creating a LET form, make sure it doesn't get optimized away.  (LET ((ARG (SECOND FORM)))    (COND      ((TRIVIAL-FORM-P ARG) FORM)      ((EQ (FIRST ARG) 'LIST)       ;;      (VALUES-LIST (LIST a b c)) ==> (VALUES a b c)       (CONS 'VALUES (REST ARG)))      ((EQ (FIRST ARG) 'MULTIPLE-VALUE-LIST)       ;;      (VALUES-LIST (MULTIPLE-VALUE-LIST x)) ==> x       (SECOND ARG))      ((NOT (COMPILING-FOR-V2)) FORM)      ;; The following is needed to keep pass 2 from generating code that      ;; evaluates the argument twice.      (T (P1 (LET ((G (GENSYM)))       `(DONT-OPTIMIZE  (LET* ((,G ,(MARK-P1-DONE ARG)))    (VALUES-LIST ,G)))))))))(ADD-OPTIMIZER GETF GETF-OPT)(DEFUN GETF-OPT (FORM)  ;; Optimize (GETF x p) ==> (GET (LOCF x) p) if x is a LOCF-able place.  ;; Note that this can't be a post-optimizer because the macro LOCF is used.  ;;  6/06/86 DNG - Original.  This is needed in release 3 because GETF is now  ;;a normal function instead of a DEFSUBST.  ;;  6/18/86 DNG - Don't optimize if the place is a PROGN or LET form.  ;; 10/30/86 DNG - Don't optimize if the place is a CAR or CDR because the  ;;result would be wrong if the value is nil.  [SPR 2758]  (LET ((PLACE (PRE-OPTIMIZE (SECOND FORM) T)))    (WHEN (AND (EQ (CAR-SAFE PLACE) 'PROGN)       (= (LENGTH PLACE) 2))      (SETQ PLACE (SECOND PLACE)))    (COND ((AND (CDDR FORM)(NULL (NTHCDR 4 FORM))(OR (SYMBOLP PLACE)    (AND (CONSP PLACE) (SYMBOLP (FIRST PLACE)) (LET (( LM (GET (FIRST PLACE) 'SI:LOCF-METHOD) ))   ;; Need a LOCF method which is a symbol, not a macro   ;; [such as for PROGN and LET].   (AND LM (ATOM LM)(NEQ LM 'CAR-LOCATION) ; would error if value is nil(NEQ LM 'IDENTITY) ; could give wrong answer if value is nil) ))) )   `(GET (LOCF ,PLACE) . ,(CDDR FORM)) )  ((EQ PLACE (SECOND FORM))   FORM)  (T (LIST* (FIRST FORM) PLACE (CDDR FORM))) )));;;;        ==================================;;;;       Optimize control-flow special forms;;;;        ==================================(DEFUN TESTABLE-BY-BRANCH (FORM)  (AND (CONSP FORM)       (OR (GET-FOR-TARGET (FIRST FORM) 'DEF-BRANCH-OP)   (AND (EQ (FIRST FORM) 'NOT)(TESTABLE-BY-BRANCH (SECOND FORM))))))(ADD-POST-OPTIMIZER AND AND-OPT)(DEFUN AND-OPT (FORM) ;; 12/28/84 - Add use of DISCARD and CAR-SAFE optimization. ;;  1/29/85 - Use new function ALWAYS-TRUE. ;;  2/03/86 - Remove duplicate arguments. ;; 10/11/86 - Optimize materializing value from branch condition. ;; 10/14/86 - (and (f ...) t) ==> (f ...) when f always returns t or nil. ;; 10/21/86 - Fix to not error on CAR of symbol. ;; 10/22/86 - Fix bug in 10/14 change.  (LET (ARG1 ARG2)    (COND      ((NULL (REST FORM)) '(QUOTE T)); (and)   ==> t      ((NULL (CDDR FORM)) ; (and x) ==> x       (SECOND FORM))      ((EQUAL (SETQ ARG1 (SECOND FORM)) '(QUOTE NIL)); (and nil x) ==> nil       (DISCARD-FORMS (CDDR FORM))       ARG1)      ((ALWAYS-TRUE ARG1); (and t x y) ==> (and x y)       (DISCARD ARG1)       (CONS 'AND (CDDR FORM)))      ((EQUAL (SETQ ARG2 (THIRD FORM)) '(QUOTE NIL))       (DISCARD-FORMS (CDDDR FORM)); (and a nil b) ==> (progn a nil)       (LIST 'PROGN ARG1 ARG2))      ((AND (ALWAYS-TRUE ARG2)    (OR (EQ P1VALUE 'NIL)(EQ P1VALUE 'D-INDS))); (and x 'c y) ==> (and x y)       (DISCARD ARG2)       (LIST* 'AND ARG1 (CDDDR FORM)))      ((AND (CONSP ARG1)    (EQ (FIRST ARG1) 'SETQ)    (NULL (CDDDR ARG1))    (EQUAL (THIRD ARG1) '(QUOTE NIL))) ; (and (setq x nil) y) ==> (setq x nil)       (DISCARD-FORMS (CDDR FORM))       ARG1)      ((AND (EQUAL (CAR (LAST FORM)) '(QUOTE NIL))    ;; Note: 'NIL if present will be the last    ;;  argument because P1ANDOR will have already    ;;  discarded any arguments following it.    (NO-SIDE-EFFECTS-P FORM))       (DISCARD FORM) '(QUOTE NIL))      ((AND (CONSP ARG1)    (EQ (FIRST ARG1) 'NOT)    (CONSP (SECOND ARG1))    (EQ (FIRST (SECOND ARG1)) 'ATOM)    (CONSP ARG2)    (MEMBER (FIRST ARG2) '(EQ EQL EQUAL) :TEST #'EQ)    (>= (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)(OPT-SAFETY OPTIMIZE-SWITCH))    (EQ (CAR-SAFE (SECOND ARG2)) 'CAR)    (ALWAYS-TRUE (THIRD ARG2))    (EQUAL-FORMS (SECOND (SECOND ARG1)) (SECOND (SECOND ARG2)))    (NO-SIDE-EFFECTS-P (SECOND (SECOND ARG1))))       ;; (AND (NOT (ATOM x)) (EQ (CAR x) 'y) z) ==> (AND (EQ (CAR-SAFE x) 'y) z)       (DISCARD (SECOND (SECOND ARG1)))       (LIST* 'AND      (LIST (FIRST ARG2)    (LIST 'CAR-SAFE (SECOND (SECOND ARG2)))    (THIRD ARG2))      (CDDDR FORM)))      ((AND (EQUAL ARG2 '(QUOTE T))    (NULL (CDDDR FORM))    (EXPR-TYPE-P ARG1 'T-OR-NIL)); (and (eq x y) t) ==> (eq x y)       (DISCARD ARG2)       ARG1)      ((AND (EQUAL-FORMS ARG1 ARG2)    (NO-SIDE-EFFECTS-P ARG1)); (and x x y) ==> (and x y)       (DISCARD ARG1)       (LIST* (FIRST FORM) (CDDR FORM)))      ((AND P1VALUE    (NOT (EQ P1VALUE 'D-INDS)) ; when materializing a result value    (TESTABLE-BY-BRANCH ARG1))       ;;  (and a b ...) ==> (cond (a (and b ...)))       `(COND (,ARG1 ,(POST-OPTIMIZE (CONS 'AND (CDDR FORM))))) )      (T FORM))))(ADD-POST-OPTIMIZER OR OR-OPT)(DEFUN OR-OPT (FORM &AUX ARG1 ARG2) ;; 12/28/84 - Add use of DISCARD. ;;  1/29/85 - Use ALWAYS-TRUE; add optimization for SETQ argument. ;;  2/03/86 - Remove duplicate arguments.  (COND    ((NULL (REST FORM)) '(QUOTE NIL)); (or)   ==> nil    ((NULL (CDDR FORM)) (SECOND FORM)); (or x) ==> x    ((EQUAL (SETQ ARG1 (SECOND FORM))    '(QUOTE NIL)) ; (or nil x y) ==> (or x y)     (DISCARD ARG1) (CONS 'OR (CDDR FORM)))    ((ALWAYS-TRUE ARG1); (or t x) ==> t     (DISCARD-FORMS (CDDR FORM)) ARG1)    ((EQUAL (SETQ ARG2 (THIRD FORM)) '(QUOTE NIL)); (or x nil y) ==> (or x y)     (DISCARD ARG2) (LIST* 'OR ARG1 (CDDDR FORM)))    ((AND (CONSP ARG1)  (EQ (FIRST ARG1) 'SETQ)  (NULL (CDDDR ARG1))  (ALWAYS-TRUE (THIRD ARG1))); (or (setq x t) y) ==> (setq x t)     (DISCARD-FORMS (CDDR FORM)) ARG1)    ((LET (LAST-ARG)       (AND (EQ P1VALUE 'D-INDS); result only used for nil test    (ALWAYS-TRUE (SETQ LAST-ARG (CAR (LAST FORM))))    ;; Note: a non-nil constant if present will be the last    ;;  argument because P1ANDOR will have already    ;;  discarded any arguments following it.    (NO-SIDE-EFFECTS-P FORM)    ;; (cond ((or ... t) a) ...) ==> (cond (t a) ...)    (DO ((ARGS (REST FORM) (REST ARGS)))((NULL (CDR ARGS)) LAST-ARG)      (DISCARD (FIRST ARGS))))))    ((AND (EQUAL-FORMS ARG1 ARG2)  (NO-SIDE-EFFECTS-P ARG1)); (or x x y) ==> (or x y)     (DISCARD ARG1) (LIST* (FIRST FORM) (CDDR FORM)))    (T FORM)))(ADD-POST-OPTIMIZER XOR XOR-OPT)(DEFUN XOR-OPT (FORM) ; 9/27/86 original  (LET* ((NEGATE NIL) (ARGS (LOOP FOR ARG IN (REST FORM)     IF (EQUAL ARG '(QUOTE NIL))     DO (DISCARD ARG)     ELSE IF (ALWAYS-TRUE ARG)     DO (PROGN (SETQ NEGATE (NOT NEGATE))       (DISCARD ARG))     ELSE COLLECT ARG)) (NEW-FORM (COND ((NULL ARGS)  '(QUOTE NIL)) ((NULL (REST ARGS))  (FIRST ARGS)) ((= (LENGTH ARGS) (LENGTH (REST FORM)))  FORM) (T (CONS (FIRST FORM) ARGS)))))    (IF NEGATE`(NOT ,NEW-FORM)      NEW-FORM))); Turn (PROG1 FOO NIL) into FOO since PBIND generates that and it makes better code(ADD-POST-OPTIMIZER PROG1 PROG1-OPT)(DEFUN PROG1-OPT (FORM) ;; 12/28/84 - Add use of DISCARD. ;;  9/22/96 - Fix to ensure that only a single value is produced. ;; 10/10/86 - Move constant first arg to end of a PROGN.  (COND    ((NULL (CDDR FORM)); (PROG1 x) ==> (VALUES x)     (IF (REST FORM) `(VALUES ,(SECOND FORM))       '(QUOTE NIL)))    ((NO-SIDE-EFFECTS-P (THIRD FORM)); (PROG1 x c ...) ==> (PROG1 x ...)     (DISCARD (THIRD FORM))     (LIST* 'PROG1 (SECOND FORM) (CDDDR FORM)))    ((NULL P1VALUE)     (CONS 'PROGN (REST FORM)))    ((QUOTEP (SECOND FORM)); (PROG1 c x ... z) ==> (PROGN x ... z c)     (CONS 'PROGN (APPEND (CDDR FORM) (CONS (SECOND FORM) NIL))))    (T FORM)))(ADD-POST-OPTIMIZER VALUES VALUES-OPT)(DEFUN VALUES-OPT (FORM)  ;;  9/23/86 - Original.  (COND ((AND (NULL (CDDR FORM))      (REST FORM)      (TRIVIAL-FORM-P (SECOND FORM))) ;; only one arg which can't produce multiple values (SECOND FORM))((MEMBER P1VALUE '(SINGLE-VALUE NIL D-INDS VALUE-ONLY DOWNWARD-ONLY) :TEST #'EQ) ;; only one value is being received (IF (AND (NULL (CDDR FORM))  (REST FORM))     (SECOND FORM)   (CONS 'PROG1 (CDR FORM))))(T FORM)))(ADD-POST-OPTIMIZER MULTIPLE-VALUE-PROG1 MVP1-OPT)(DEFUN MVP1-OPT (FORM)  ;; 10/10/86 - Original.  (IF (OR (TRIVIAL-FORM-P (SECOND FORM))  (MEMBER P1VALUE '(SINGLE-VALUE NIL D-INDS VALUE-ONLY DOWNWARD-ONLY) :TEST #'EQ))      (CONS 'PROG1 (REST FORM))    FORM))#-Elroy ; The PROG2 macro has been fixed in release 3(progn(ADD-OPTIMIZER PROG2 PROG2-NO-OP)(DEFUN PROG2-NO-OP (FORM)  ;;  5/12/86 - Instead of just optimizing special case of (PROG2 NIL x) ==> x,  ;;expand PROG2 into PROGN and PROG1 like the macro ought to do.  `(PROGN ,(SECOND FORM) (PROG1 . ,(CDDR FORM)))) )(ADD-POST-OPTIMIZER COND COND-OPT)(DEFUN COND-OPT (FORM) ;; 1/25/85 - Use DISCARD. ;; 1/29/85 - Use ALWAYS-TRUE; optimize SETQ as first test. ;; 3/05/85 - Optimize (IF b T NIL) ==> b ;; 8/09/86 - Use new macro BOOLEAN-FUNCTION-P.  (LET ((BODY (CDR FORM)));;  (COND)  ==>  'NIL    (IF (NULL BODY)'(QUOTE NIL)      (LET* ((CLAUSE-1 (FIRST BODY))     (TEST-1 (CAR-SAFE CLAUSE-1))     CLAUSE-2)(COND ;;  (COND ( NIL x ) ( y z ) ... ) ==> (COND ( y z ) ... ) ((EQUAL TEST-1 '(QUOTE NIL))  (DISCARD-FORMS CLAUSE-1)  (CONS 'COND (REST BODY))) ;;  (COND ( T x ) ... ) ==> x ((ALWAYS-TRUE TEST-1)  (DOLIST (CLAUSE (REST BODY))    (DISCARD-FORMS CLAUSE))  (CONS 'PROGN CLAUSE-1)) ;;  (COND ((SETQ x c) a)...) ==> (PROGN (SETQ x c) ;;                                      (COND (c a)...)) ((AND (EQ (CAR-SAFE TEST-1) 'SETQ)       (NULL (CDDDR TEST-1))       (QUOTEP (THIRD TEST-1)))  `(PROGN     ,TEST-1     ,(POST-OPTIMIZE `(COND(,(THIRD TEST-1) . ,(REST CLAUSE-1)),@(REST BODY))))) ;;  (COND (p x)(NIL y)(q z)...) ==> (COND (p x) (q z) ...) ((NULL (CDR BODY)) FORM) ((EQUAL (FIRST (SETQ CLAUSE-2 (SECOND BODY))) '(QUOTE NIL))  (DISCARD-FORMS CLAUSE-2)  (LIST* 'COND CLAUSE-1 (CDDR BODY))) ;;  (COND ( p x ) ( T x ) ... ) ==> x ((AND (ALWAYS-TRUE (FIRST CLAUSE-2))       (CONSP (CDR CLAUSE-2)))  (LET (FC1 FC2 (NDIF NIL) NOVARS)    (COND      ((EQUAL-FORMS (REST CLAUSE-1) (REST CLAUSE-2))       (DOLIST (CLAUSE (REST BODY)) (DISCARD-FORMS CLAUSE))       (CONS 'PROGN CLAUSE-1)); later, if safe, change:  (PROGN p x) ==> x      ;;  (COND ((eq x y) T) (T NIL)) ==> (eq x y)      ((AND (EQUAL (REST CLAUSE-1) '('T))    (EQUAL (REST CLAUSE-2) '('NIL))    (OR (EQ P1VALUE 'D-INDS)(AND (CONSP TEST-1)     (BOOLEAN-FUNCTION-P (FIRST TEST-1)))))       (DISCARD (CONS (FIRST FORM) (CDDR FORM)))       TEST-1)      ;;  (COND (p (f a b c)) (T (f a z c))) ==>      ;;     (f a (COND ((p b)(T z))) c)      ((AND (EQUAL-FORMS (CDDR CLAUSE-1) (CDDR CLAUSE-2))    (> (OPT-SPACE OPTIMIZE-SWITCH) 0)    (NOT (TRIVIAL-FORM-P (SETQ FC1 (SECOND CLAUSE-1))))    (NOT (TRIVIAL-FORM-P (SETQ FC2 (SECOND CLAUSE-2))))    (EQ (FIRST FC1) (FIRST FC2))   ; same function    (NOT (QUOTES-ANY-ARGS (FIRST FC1)))   ; not a special form    (= (LENGTH FC1) (LENGTH FC2))  ; same no. of args.    (LOOP NAMED SCAN-ARGS  INITIALLY (SETQ NOVARS T) ; no variable references yet  FOR A1 IN (REST FC1)  FOR A2 IN (REST FC2)  FOR N FROM 1 BY 1  WHEN (NOT (EQUAL-FORMS A1 A2))  DO (IF (NULL NDIF) (SETQ NDIF N)   ; number of arg that differs       (RETURN-FROM SCAN-ARGS NIL))  WHEN (AND (NULL NDIF) NOVARS)  DO (SETQ NOVARS (QUOTEP A1))  FINALLY (RETURN-FROM SCAN-ARGS (NOT (NULL NDIF))))    ;; only one argument is different    (OR NOVARS (NO-SIDE-EFFECTS-P (FIRST CLAUSE-1)))    ;; condition can safely be moved since it doesn't    ;;  interact with any of the leading arguments.    )       `(PROGN  (,@(FIRSTN NDIF (SECOND CLAUSE-1))   (COND     (,(FIRST CLAUSE-1) ,(NTH NDIF FC1))     (,(FIRST CLAUSE-2) ,(NTH NDIF FC2)))   . ,(NTHCDR (1+ NDIF) (SECOND CLAUSE-1)))  ,@(CDDR CLAUSE-1)))      (T FORM)))) ;;  otherwise, return original form (T FORM))))))       (ADD-POST-OPTIMIZER PROGN PROGN-OPT)(DEFUN PROGN-OPT (FORM) ;; 12/28/84 - Add use of DISCARD. ;; 10/17/86 - Return 2nd value of T when result doesn't need further optimization.  (COND    ((NULL (REST FORM)); (PROGN)   ==> 'NIL     '(QUOTE NIL))    ((NULL (CDDR FORM)); (PROGN x) ==> x     (VALUES (SECOND FORM) T))    ((NO-SIDE-EFFECTS-P (SECOND FORM)); (PROGN c x ...) ==> (PROGN x ...)     (DISCARD (SECOND FORM))     (CONS 'PROGN (CDDR FORM)))    ((ATOM (SECOND FORM)) FORM)    ((MEMBER (FIRST (SECOND FORM)); (PROGN (RETURN...)...) ==> (RETURN...)     '(RETURN-FROM GO *THROW THROW)     :TEST #'EQ)     (DISCARD-FORMS (CDDR FORM))     (VALUES (SECOND FORM) T))    (T FORM)))(ADD-POST-OPTIMIZER BLOCK BLOCK-OPT)(ADD-POST-OPTIMIZER BLOCK-FOR-PROG BLOCK-OPT)(DEFUN BLOCK-OPT (FORM) ;; the P1'd form is: (BLOCK gotags progdesc . body)  ;;  9/12/86 - Add call to DISCARD-FORMS.  ;; 10/17/86 - Return 2nd value of T when result doesn't need further optimization.  ;; 10/18/86 - Use GOTAGS-SEARCH.  (LET ((RETURN-COUNT (GOTAG-USE-COUNT (GOTAGS-SEARCH (PROGDESC-RETTAG (THIRD FORM)) T (SECOND FORM))))BF)    (COND      ((= RETURN-COUNT 0); No RETURNs so change BLOCK to PROGN.       (CONS 'PROGN (CDDDR FORM)))      ((NULL (CDDDR FORM)) '(QUOTE NIL)); empty body      ;; BF is first body form      ((NO-SIDE-EFFECTS-P (SETQ BF (FOURTH FORM)))       (IF (NULL (NTHCDR 4 FORM)); (BLOCK name c) ==> c   BF ;; (BLOCK name c x) ==> (BLOCK name x) (LIST* (FIRST FORM) (SECOND FORM) (THIRD FORM) (NTHCDR 4 FORM))))      ((AND (EQ (FIRST BF) 'RETURN-FROM)    (EQ (SECOND BF) (THIRD FORM))    (= RETURN-COUNT 1))       ;; (BLOCK name (RETURN-FROM name value)) ==> value       (DISCARD-FORMS (NTHCDR 4 FORM))       (VALUES (THIRD BF) T))      (T FORM))))(ADD-POST-OPTIMIZER THE-EXPR THE-EXPR-OPT);; (THE-EXPR expression used-var-set altered-var-set optimize-switch type)(DEFUN THE-EXPR-OPT (FORM) ;; 1/23/85 - Original version. ;; 2/19/85 - More cases for removing annotation. ;; 3/10/86 - Don't discard type information. ;; 9/19/86 - Call POST-OPTIMIZE in P1-WITH-ANNOTATION instead of here. ;;10/11/86 - Do re-optimize the arg if P1VALUE has changed. ;;10/17/86 - Return 2nd value of T when result doesn't need further optimization. ;;11/19/86 - Test OPCODE property instead of QLVAL.  (LET* ((ARG (EXPR-FORM FORM)))    (COND      ((OR (QUOTEP ARG); annotation not needed on constant   (AND (OR (TRIVIAL-FORM-P ARG)   ; annotation not needed on variable    (NOT (GET (FIRST ARG) 'P2))   ; not a special form, annotation not needed    (GET (FIRST ARG) 'OPCODE)   ; machine instruction, not worth annotating    )(LET ((TYPE (EXPR-TYPE FORM)))  (OR (EQ TYPE 'UNKNOWN)      (EQ TYPE (TYPE-OF-EXPRESSION ARG)))))   ; don't need the type   (MEMBER (CAR-SAFE ARG) '(RETURN-FROM GO *THROW THROW) :TEST #'EQ)   ;; annotation would get in way of optimization   (AND (EQ (CAR-SAFE ARG) 'THE-EXPR)(OR (EQ (EXPR-TYPE FORM) 'UNKNOWN)    (NOT (EQ (EXPR-TYPE ARG) 'UNKNOWN))))   )       (VALUES ARG T))   ; remove annotation      ((AND (SYMBOLP P1VALUE)    (NOT (EQ P1VALUE (EXPR-DEST FORM))))       (MAKE-EXPR :EXPR-FORM (POST-OPTIMIZE ARG)  :EXPR-USED (EXPR-USED FORM)  :EXPR-ALTERED (EXPR-ALTERED FORM)  :EXPR-OPTIMIZE (EXPR-OPTIMIZE FORM)  :EXPR-TYPE (EXPR-TYPE FORM)))      (T FORM))))(ADD-OPTIMIZER DOTIMES DOTIMES-OPT)(DEFUN DOTIMES-OPT (FORM)  ;; 10/15/86 DNG - Original.  (LET ((X (SECOND FORM)))    (IF (AND (CONSP X)     (SYMBOLP (FIRST X))     (<= (LENGTH X) 3)     (NOT (EQ (CAR-SAFE (SECOND X)) 'P1-HAS-BEEN-DONE)) ; not 2nd time around     (NOT (EQ P1VALUE 'TOP-LEVEL-FORM)))(LET* ((COUNT-FORM (LET ((P1VALUE 'INTEGER))     (P1 (SECOND X))))       (COUNT-VALUE (QUOTE-NUMBER COUNT-FORM)))  (IF (AND (REALP COUNT-VALUE) ; the count is a numeric constant   (< COUNT-VALUE 2)) ; will loop either 0 or 1 times      (PROGN(DISCARD COUNT-FORM)`(PROGN (AND ,(> COUNT-VALUE 0)     (PROG ((,(FIRST X) 0))       ,@(CDDR FORM)   ; body may begin with declarations       (PROGN ,(FIRST X)) ; avoid warning if not referenced      ))(LET ((,(FIRST X) ,(IF (< COUNT-VALUE 1) 0 1)))  ,(FIRST X)  ,(THIRD X))))    (LIST* (FIRST FORM)   (LIST* (FIRST X) (MARK-P1-DONE COUNT-FORM) (CDDR X))   (CDDR FORM))))      FORM)))(ADD-OPTIMIZER DOLIST DOLIST-EXPANDER)(DEFUN DOLIST-EXPANDER (FORM)  ;; 10/10/84 DNG - Fixed to evaluate the list expression outside  ;;                of the binding for the iteration variable in  ;;                case the same name is used in both.  ;;  8/15/86 DNG - Don't optimize if at top level in a file. (IF (EQ P1VALUE 'TOP-LEVEL-FORM)     ;; Don't optimize top-level form because then it couldn't be evaluated.     FORM  (LET* ((X (SECOND FORM)) (RESULT (IF (CDDR X)     `(LET ((,(FIRST X) NIL)),(FIRST X),(THIRD X))   NIL)))    (IF (OR (ATOM X)    (NULL (REST X))    (NOT (SYMBOLP (FIRST X)))   ; invalid    (> (OPT-SAFETY OPTIMIZE-SWITCH) (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)));; prefer ease of debuggingFORM   ; leave it alone      (MULTIPLE-VALUE-BIND (BODY DECLS)  (EXTRACT-DECLARATIONS-RECORD-MACROS (CDDR FORM) NIL)(LET ((LIST (GENSYM)))  `(BLOCK NIL     (LET* ((,LIST ,(SECOND X))    (,(FIRST X) (UNDEFINED-VALUE)))       (DECLARE . ,DECLS)       (%DOLIST ,(FIRST X) ,LIST (TAGBODY . ,BODY)))     ,RESULT)))))))(ADD-POST-OPTIMIZER TAGBODY TAGBODY-OPT)(ADD-POST-OPTIMIZER %DOLIST TAGBODY-OPT)(DEFUN TAGBODY-OPT (FORM) ;; FORM looks like:  (TAGBODY <local-gotags> . <body>) ;; 1/26/85 - Original version. ;; 7/08/86 - Increment EXPRESSION-SIZE when 'NIL inserted. ;;10/15/86 - Delete unreachable code following a GO or RETURN. ;;10/18/86 - GO form now has tag structure instead of name.  (WHEN (ZEROP 1-IF-LIVE-CODE)    ;; This is all dead code so don't try to optimize it.    (RETURN-FROM TAGBODY-OPT FORM))  (WHEN (AND (OR PROPAGATE-ENABLE INLINE-EXPANSIONS)     (>= (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH) (OPT-SAFETY OPTIMIZE-SWITCH))     (>= (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH) (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH)))   ;; Function P1TAGBODY has already removed variables from the set   ;;  eligible for initial value propagation as required by   ;;  assignments within the TAGBODY.  Now re-scan the body   ;;  forms to substitute values for variables where appropriate.    (SETQ FORM (PROPAGATE-VALUES FORM)))  (IF (NEQ (FIRST FORM) 'TAGBODY)      FORM    (LET ((LOCAL-GOTAGS (SECOND FORM))  (BODY (CDDR FORM))  (CHANGED NIL))      (DECLARE (LIST LOCAL-GOTAGS BODY))      (LOOP FOR G IN LOCAL-GOTAGS    WHEN (AND (ZEROP (GOTAG-USE-COUNT G))      (NOT (GOTAG-USED-IN-LEXICAL-CLOSURES-FLAG G)))    ;; delete unreferenced tag    DO (SETQ LOCAL-GOTAGS (REMOVE G (THE LIST LOCAL-GOTAGS) :TEST #'EQ :COUNT 1)     CHANGED T)    )      (DO ((FORMS BODY (CDR FORMS))   (PREV NIL)   (FALLTHRU T))  ((NULL FORMS))(COND ((ATOM (CAR FORMS))       (IF (ASSOC (CAR FORMS) LOCAL-GOTAGS :TEST #'EQL) ; referenced tag   (SETF FALLTHRU T PREV FORMS) ;; else delete unused tag (IF (NULL PREV)     (SETF BODY (CDR FORMS))   (SETF (CDR PREV) (CDR FORMS)))))      ((OR (NOT FALLTHRU) ; delete unreachable code   (NO-SIDE-EFFECTS-P (CAR FORMS)) ; or useless code   (AND (EQ (CAR-SAFE (CAR FORMS)) 'GO)(EQUAL (GOTAG-PROG-TAG (SECOND (CAR FORMS))) (SECOND FORMS))))       (DISCARD (CAR FORMS))       (SETQ CHANGED 'T)       (IF (NULL PREV)   (SETF BODY (CDR FORMS)) (SETF (CDR PREV) (CDR FORMS))))      (T (WHEN (EXPR-TYPE-P (CAR FORMS) 'NIL) ; form that never returns   (SETF FALLTHRU NIL)   (WHEN (AND (EQ FORMS BODY)      (MEMBER (FIRST (CAR FORMS)) '(RETURN-FROM THROW *THROW))      (NO-SIDE-EFFECTS-P (THIRD (CAR FORMS))))     ;; if the first body form exits the tagbody, then none of the tags are reachable.     (SETQ LOCAL-GOTAGS NIL))) (SETF PREV FORMS))))        (COND ((NULL LOCAL-GOTAGS)     ;; No referenced tags so change TAGBODY to PROGN.     (INCF EXPRESSION-SIZE 1) ; count the 'NIL form being added     `(PROG1 (QUOTE NIL) . ,BODY))    (CHANGED     (LIST* (FIRST FORM) LOCAL-GOTAGS BODY))    (T FORM)))))(DEFUN PROPAGATE-VALUES (FORM)  ;; FORM is an S-expression which has already been processed by P1.  ;; Scans the expression looking for local variable references  ;;  which can be replaced by the variable's initial value,  ;;  making the substitution in place.  Also re-optimizes any  ;;  forms whose arguments have been changed.  ;; 1/25/85 - Original version.  ;; 2/29/85 - Allow for some more special forms.  ;; 3/04/85 - Do constant folding on *PLUS etc.  ;; 3/23/85 - Fix replacement of initial value of variable.  ;; 9/28/85 - Recognize special form VARIABLE-LOCATION.  ;; 1/07/86 - Special handling for PROG1.  ;; 5/05/86 - Check (CONSP NEW-FORM) before doing (FIRST NEW-FORM) [SPR 1827];  ;;       eliminate obsolete reference to P2NODEST.  ;; 7/03/86 - Add handling for LEXICAL-CLOSURE.  ;; 8/14/86 - No longer need special handling for *PLUS, etc.  ;; 9/09/86 - Increment use count of propagated BREAKOFF-FUNCTION.  ;; 9/19/86 - Allow propagating BREAKOFF-FUNCTION; add use of  ;;DONT-PROPAGATE-INTO-LOOP; mark compilands that have only one use.  ;;10/18/86 - Don't need to bind GOTAGS anymore.  ;;11/04/86 - Fix to handle MULTIPLE-VALUE-PUSH correctly.  (DECLARE (VALUES NEW-FORM ANY-TOP-LEVEL-CHANGES?))  (DECLARE (INLINE TRIVIAL-FORM-P))  (IF (OR (ATOM FORM)  (NOT (DEBUG-ASSERT (SYMBOLP (FIRST FORM)))))      (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL))    (LET ((CHANGED NIL))      (IF (EQ (FIRST FORM) 'THE-EXPR)  (PROGN    (LET ((USED-VAR-SET (EXPR-USED FORM))  (ALTERED-VAR-SET (EXPR-ALTERED FORM))  (PROPAGATE-VAR-SET PROPAGATE-VAR-SET)  (OPTIMIZE-SWITCH (EXPR-OPTIMIZE FORM)))      (SETF (EXPR-FORM FORM) (PROPAGATE-VALUES (EXPR-FORM FORM)))      (SETF (EXPR-USED FORM) USED-VAR-SET))    (SETQ USED-VAR-SET (LOGIOR USED-VAR-SET (EXPR-USED FORM)))    (SETQ CHANGED T))(LET (ARG-LIST      (CLAUSE-LIST NIL)      (P1VALUE P1VALUE)      (P1VALUE-FIRST T)      (P1VALUE-LAST T)      (P1VALUE-MIDDLE T)      (BIND-VARS NIL)      (BIND-VALS NIL))  (SETQ ARG-LIST(COND  ((MEMBER (FIRST FORM) '(LET LET* LET-FOR-LAMBDA) :TEST #'EQ)   ;;   1      2           3       4     5      6        7       8...   ;; (LET lambda-list outer-vars vars bindp e-lex-cnt lex-cnt . body)   (LET ((VARS (FOURTH FORM)))     (SETQ BIND-VARS '(VARS)   BIND-VALS (LIST VARS))     (DOLIST (VAR (SECOND FORM))   ; each variable in lambda list       (UNLESS (ATOM VAR) (LET ((V (LOOKUP-VAR (FIRST VAR) VARS)))   (WHEN (EQ (SECOND VAR) (SECOND (VAR-INIT V)))     (MULTIPLE-VALUE-BIND (NEW-INIT CHANGED-INIT) (PROPAGATE-VALUES (SECOND VAR))       (WHEN CHANGED-INIT (SETF (SECOND VAR) NEW-INIT) (SETF (SECOND (VAR-INIT V)) NEW-INIT) (SETQ CHANGED T) (WHEN (AND (EQ (VAR-KIND V) 'FEF-ARG-INTERNAL-AUX)    (EQ (VAR-TYPE V) 'FEF-LOCAL)    (CONSP NEW-INIT)    (MEMBER (FIRST NEW-INIT)    '(QUOTE LOCAL-REF FUNCTION BREAKOFF-FUNCTION)    :TEST #'EQ)    (NOT (LOGTEST (CDDR (VAR-LAP-ADDRESS V))  ALTERED-VAR-SET))    (NOT (AND (EQ (FIRST NEW-INIT) 'LOCAL-REF)      (LOGTEST (CDDR NEW-INIT)       ALTERED-VAR-SET))))   (SETQ PROPAGATE-VAR-SET (LOGIOR PROPAGATE-VAR-SET (CDDR (VAR-LAP-ADDRESS V))))))))))))   (SETQ P1VALUE-FIRST NIL P1VALUE-MIDDLE NIL P1VALUE-LAST P1VALUE)   (NTHCDR 7 FORM))  ((ZEROP (LOGAND PROPAGATE-VAR-SET USED-VAR-SET))   ;; There aren't any variables eligible for substitution, so quit.   (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL)))  ((EQ (FIRST FORM) 'PROGN)   (SETQ P1VALUE-FIRST NIL P1VALUE-MIDDLE NIL P1VALUE-LAST P1VALUE) (REST FORM))  ((MEMBER (FIRST FORM) '(BLOCK BLOCK-FOR-PROG   BLOCK-FOR-WITH-STACK-LIST)   :TEST #'EQ)   ;;(SETQ BIND-VARS '(GOTAGS)   ;;   BIND-VALS (LIST (APPEND (SECOND FORM) GOTAGS)))   (SETQ P1VALUE-FIRST NIL P1VALUE-MIDDLE NIL P1VALUE-LAST P1VALUE) (CDDDR FORM))  ((EQ (FIRST FORM) 'MULTIPLE-VALUE-BIND)   (NTHCDR 4 FORM))  ((MEMBER (FIRST FORM)   '(PROGN-WITH-DECLARATIONS RETURN-FROM MULTIPLE-VALUE     MULTIPLE-VALUE-PUSH MULTIPLE-VALUE-SETQ CLOSURE GO)   :TEST #'EQ)   (CDDR FORM))  ((EQ (FIRST FORM) 'COND)   (SETQ CLAUSE-LIST (REST FORM))   (SETQ P1VALUE-FIRST 'D-INDS P1VALUE-MIDDLE NIL P1VALUE-LAST P1VALUE) NIL)  ((MEMBER (FIRST FORM) '(AND OR) :TEST #'EQ)   (WHEN (OR (NULL P1VALUE) (EQ P1VALUE 'D-INDS))     (SETQ P1VALUE-FIRST 'D-INDS   P1VALUE-MIDDLE 'D-INDS))   (SETQ P1VALUE-LAST P1VALUE) (REST FORM))  ((EQ (FIRST FORM) 'TAGBODY)   ;;(SETQ BIND-VARS '(GOTAGS)   ;;      BIND-VALS (LIST (APPEND (SECOND FORM) GOTAGS)))   (SETQ P1VALUE-FIRST NIL P1VALUE-MIDDLE NIL P1VALUE-LAST NIL)   (SETQ PROPAGATE-VAR-SET (LOGDIF PROPAGATE-VAR-SET   DONT-PROPAGATE-INTO-LOOP))   (CDDR FORM))  ((EQ (FIRST FORM) '%DOLIST)   (SETQ P1VALUE-FIRST NIL P1VALUE-MIDDLE NIL P1VALUE-LAST NIL)   (SETQ PROPAGATE-VAR-SET (LOGDIF PROPAGATE-VAR-SET   DONT-PROPAGATE-INTO-LOOP))   (CDDR FORM))  ((EQ (FIRST FORM) 'LOCAL-REF) (LIST FORM))  ((TRIVIAL-FORM-P FORM)   (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL)))  ((MEMBER (FIRST FORM) '(VARIABLE-LOCATION) :TEST #'EQ)   (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL)))  ((MEMBER (FIRST FORM) '(PROG1 MULTIPLE-VALUE-PROG1)   :TEST #'EQ)   (SETQ P1VALUE-FIRST P1VALUE P1VALUE-MIDDLE NIL P1VALUE-LAST NIL) (REST FORM))  ((EQ (FIRST FORM) 'LEXICAL-CLOSURE)   #|   (LET* ((COMPILAND (SECOND FORM))  (USED-VAR-SET (COMPILAND-USED-VAR-SET COMPILAND))  (ALTERED-VAR-SET (COMPILAND-ALTERED-VAR-SET COMPILAND))  (PROPAGATE-VAR-SET PROPAGATE-VAR-SET)  (OPTIMIZE-SWITCH (COMPILAND-OPTIMIZE COMPILAND)))     (SETF (COMPILAND-EXP2 COMPILAND)   (PROPAGATE-VALUES (COMPILAND-EXP2 COMPILAND)))     (SETF (COMPILAND-USED-VAR-SET COMPILAND) USED-VAR-SET))    |#   (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL)))  ((DEBUG-ASSERT     (OR (NOT (QUOTES-ANY-ARGS (FIRST FORM))) (MEMBER (FIRST FORM) '(SETQ INTERNAL-PSETQ SET-AR-1UNWIND-PROTECT *CATCH CATCH) :TEST #'EQ)))   (REST FORM))  (T (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL))) ))  (PROGV BIND-VARS BIND-VALS    (DO ((FORM-LIST (OR ARG-LIST (POP CLAUSE-LIST)) (POP CLAUSE-LIST)))((AND (NULL FORM-LIST)      (NULL CLAUSE-LIST)))      (LOOP FOR ARGS ON FORM-LIST DO    (LET ((ARG (FIRST ARGS)))      (COND((ATOM ARG))((EQ (FIRST ARG) 'LOCAL-REF) (WHEN (LOGTEST (CDDR ARG) PROPAGATE-VAR-SET)   (LET* ((V (SECOND ARG))  (NEW (OR (SECOND (VAR-INIT V))   '(QUOTE NIL))))     (SETQ CHANGED T)     (DECF (VAR-USE-COUNT V))     (DEBUG-ASSERT (>= (VAR-USE-COUNT V) 0)   ((VAR-USE-COUNT V) USED-VAR-SET)   "Negative var use count")     (WHEN (ZEROP (VAR-USE-COUNT V))   ; no more uses       (SETQ USED-VAR-SET (LOGDIF USED-VAR-SET (CDDR ARG)))       (SETQ ALTERED-VAR-SET     (LOGDIF ALTERED-VAR-SET (CDDR ARG))))     (COND ((ATOM NEW))   ((EQ (CAR NEW) 'LOCAL-REF)    (INCF (VAR-USE-COUNT (SECOND NEW)))    (SETQ USED-VAR-SET (LOGIOR USED-VAR-SET (CDDR NEW))))   ((MEMBER (CAR NEW) '(BREAKOFF-FUNCTION LEXICAL-CLOSURE))    (WHEN (AND (= (VAR-USE-COUNT V) 0)       (= (COMPILAND-USE-COUNT (SECOND NEW)) 1))      ;; flag for PROCEDURE-INTEGRATION      (SETF (GETF (COMPILAND-PLIST (SECOND NEW))  'USED-ONLY-ONCE)    T))    (INCF (COMPILAND-USE-COUNT (SECOND NEW))))   ((TRIVIAL-FORM-P NEW))   ((DEBUG-ASSERT (ZEROP (VAR-USE-COUNT V)))    ;; rather than scanning the expression incrementing    ;; the use counts for everything it references, just    ;; delete the original expression.    (SETF (SECOND (VAR-INIT V)) 'DELETED-VALUE)))     (IF (EQ ARG FORM) (RETURN-FROM PROPAGATE-VALUES (VALUES NEW T))       (SETF (FIRST ARGS) NEW)))))((TRIVIAL-FORM-P ARG))(T (SETQ P1VALUE       (COND ((NULL (REST ARGS)) P1VALUE-LAST)     ((EQ ARGS FORM-LIST) P1VALUE-FIRST)     (T P1VALUE-MIDDLE))) (MULTIPLE-VALUE-BIND (NEW-ARG WAS-CHANGED)     (PROPAGATE-VALUES ARG)   (WHEN WAS-CHANGED     (SETF (FIRST ARGS) NEW-ARG)     (SETQ CHANGED T)))))))   ; end of LOOP      )   ; end of DO    )   ; end of PROGV  )   ; end of LET on ARG-LIST and P1VALUE)   ; end of IF THE-EXPR      (IF CHANGED  (LET ((NEW-FORM (POST-OPTIMIZE FORM)))    (RETURN-FROM PROPAGATE-VALUES (VALUES NEW-FORM (NEQ NEW-FORM FORM))))(RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL)))      ); end of LET CHANGED    ); end of IF ATOM  ); end of PROPAGATE-VALUES;;;;        ==================================;;;;           Optimize equality tests;;;;        ==================================;Turn EQUAL into EQ when that is safe.;EQUAL can never be turned into = alone because = signals an error if either;arg is not a number, whereas EQUAL does not.  However, (EQUAL <fixnum> xxx);can be turned into EQ since EQ "works" for fixnums.(ADD-POST-OPTIMIZER EQUAL EQUAL-EQ)(ADD-POST-OPTIMIZER EQL EQUAL-EQ)(DEFUN EQUAL-EQ (FORM)  ;;  1/06/86 DNG - Combined optimizers for EQUAL and EQL.  ;;  7/08/86 DNG - Check for EQUAL-FORMS before EQ-COMPARABLE-P.  (COND ((/= (LENGTH FORM) 3) FORM)((AND (OR (EQ (FIRST FORM) 'EQUAL)  (TRIVIAL-FORM-P '(SECOND FORM)))      (DISCARD-EQUAL-FORMS FORM)) '(QUOTE T))((OR (EQ-COMPARABLE-P (SECOND FORM) (FIRST FORM))     (EQ-COMPARABLE-P (THIRD FORM) (FIRST FORM))) (CONS 'EQ (CDR FORM)))(T FORM)))(ADD-POST-OPTIMIZER EQL   PUT-CONST-LAST)(ADD-POST-OPTIMIZER EQUAL PUT-CONST-LAST)(DEFUN EQ-COMPARABLE-P (QUAN &OPTIONAL (TEST 'EQL))  ;; Return true if the expression QUAN is known to be of a type such that the  ;; test (TEST QUAN X) can be optimized to (EQ QUAN X).  ;; 12/20/85 DNG - Original; replaces POINTER-IDENTITY-P.  ;;  4/21/86 DNG - Make second argument optional.  ;;  7/14/86 DNG - Revised to use TYPE-OF-EXPRESSION.  (IF (QUOTEP QUAN)      (OR (AND (MEMBER (%DATA-TYPE (SECOND QUAN))       '(#.DTP-FIX #.DTP-SYMBOL #.DTP-CHARACTER #.DTP-SMALL-FLONUM)       :TEST #'EQ)       T)  (AND (EQ TEST 'EQL)       (NOT (NUMBERP (SECOND QUAN)))))    (LET (( TYPE (TYPE-OF-EXPRESSION QUAN) ))      (WHEN (EQ (CAR-SAFE TYPE) 'VALUES)(SETQ TYPE (SECOND TYPE)) )      (AND (SYMBOLP TYPE)   (NOT (MEMBER TYPE '(T UNKNOWN)))   (OR (MEMBER TYPE '(FIXNUM SYMBOL CHARACTER SHORT-FLOAT LOCATIVE T-OR-NIL))       (AND (EQ TEST 'EQL)    (SI:DISJOINT-TYPEP TYPE 'NUMBER)))   T) )))(DEFUN DISCARD-EQUAL-FORMS (FORM)  ;; If the two arguments of FORM are the same, then discard them and return T.  (IF (AND (EQUAL-FORMS (SECOND FORM) (THIRD FORM))   (NO-SIDE-EFFECTS-P (SECOND FORM))   (< (OPT-SAFETY OPTIMIZE-SWITCH) (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)))      (PROGN (DISCARD (SECOND FORM))     (DISCARD (THIRD FORM))     T)    NIL))(ADD-POST-OPTIMIZER EQ PUT-CONST-LAST)(ADD-POST-OPTIMIZER EQ EQ-OPT)(DEFUN EQ-OPT (FORM) ;;  1/06/86 DNG - Name changed from EQ-NIL to EQ-OPT. ;; 11/19/86 DNG - Test OPCODE property instead of QLVAL.  (LET ((ARG1 (SECOND FORM))(ARG2 (THIRD FORM)))    (COND      ((NULL (CDDR FORM)) FORM); 0 or 1 arg => let it get the error.      ((AND (QUOTEP ARG1) (QUOTEP ARG2))       ;; Fold constants -- no possiblity of error.       (LIST 'QUOTE (EQ (SECOND ARG1) (SECOND ARG2))))      ((EQUAL ARG2 '(QUOTE NIL)); (EQ x NIL) ==> (NOT x)       `(NOT ,ARG1))      ;; Note: (EQ (QUOTE c) x) is changed to (EQ x (QUOTE c)) by PUT-CONST-LAST      ((AND (CONSP ARG1)    (EQ (FIRST ARG1) 'FUNCTION)    (CONSP ARG2)    (<= (OPT-SAFETY OPTIMIZE-SWITCH) (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)))       (COND ((AND (EQ (FIRST ARG2) 'FUNCTION)       (EQUAL ARG1 ARG2))  ;; (EQ #'f #'f) ==> 'T  '(QUOTE T)) ((AND (MEMBER (FIRST ARG2) '(QUOTE FUNCTION) :TEST #'EQ)       (SYMBOLP (SECOND ARG1))       (SYMBOLP (SECOND ARG2))       (NEQ (SECOND ARG1) (SECOND ARG2))       (OR (AND (GET (SECOND ARG1) 'OPCODE)(OR (EQ (FIRST ARG2) 'QUOTE)    (GET (SECOND ARG2) 'OPCODE)))   (AND (EQ (SYMBOL-PACKAGE (SECOND ARG1)) SI:PKG-LISP-PACKAGE)(EQ (SYMBOL-PACKAGE (SECOND ARG2)) SI:PKG-LISP-PACKAGE)(NEQ (SYMBOL-FUNCTION (SECOND ARG1))     (SYMBOL-FUNCTION (SECOND ARG2))))))  ;; A primitive function corresponding to a machine instruction  ;;  can be assumed to have a function definition which is never  ;;  a symbol and which is different from any other primitive.  '(QUOTE NIL)) (T FORM)))      ((AND (EQUAL-FORMS ARG1 ARG2)    (TRIVIAL-FORM-P ARG1)    (<= (OPT-SAFETY OPTIMIZE-SWITCH)(OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)))       ;; (EQ x x) ==> 'T       (DISCARD ARG1) (DISCARD ARG2)       '(QUOTE T))      (T FORM))))(ADD-POST-OPTIMIZER STRING= ARITH-OPT-NON-ASSOCIATIVE)(ADD-POST-OPTIMIZER STRING-EQUAL FOLD-STRING-EQUAL)#+Elroy(ADD-POST-OPTIMIZER GLOBAL:STRING= ARITH-OPT-NON-ASSOCIATIVE)#+Elroy(ADD-POST-OPTIMIZER GLOBAL:STRING-EQUAL FOLD-STRING-EQUAL)(ADD-POST-OPTIMIZER SI:STRING-EQUAL* ARITH-OPT-NON-ASSOCIATIVE)(ADD-POST-OPTIMIZER SI:STRING=* ARITH-OPT-NON-ASSOCIATIVE)(ADD-POST-OPTIMIZER %STRING-EQUAL FOLD-STRING-EQUAL)(DEFUN FOLD-STRING-EQUAL (FORM)  (PROG (VAL)    (UNLESS (EVERY #'QUOTEP (THE LIST (REST FORM)))      (RETURN FORM))    (LET ((ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON NIL))      (SETQ VAL (FOLD-CONSTANTS FORM)))    (UNLESS (QUOTEP VAL)      (RETURN FORM))    (WHEN (NULL (SECOND VAL))      (RETURN VAL))    (LET ((ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON T))      (SETQ VAL (FOLD-CONSTANTS FORM)))    (UNLESS (QUOTEP VAL)      (RETURN FORM))    (IF (NULL (SECOND VAL))      (RETURN FORM)      (RETURN VAL))))                                                            (ADD-OPTIMIZER NULL NULL-NOT)(DEFUN NULL-NOT (FORM)  ;;  4/23/85 DNG - Don't do the transformation if the number of  ;;                arguments is wrong -- this is to facilitate  ;;                run-time error reporting.  [bug 1574]  (IF (= (LENGTH FORM) 2)      `(NOT . ,(CDR FORM))    FORM))(ADD-POST-OPTIMIZER NOT NOT-NOT)(DEFUN NOT-NOT (FORM)  ;;  8/09/86 - Use new macro BOOLEAN-FUNCTION-P.  (LET ((ARG (SECOND FORM)))    (COND      ((ATOM ARG) FORM)      ((EQ (FIRST ARG) (FIRST FORM))   ; (NOT (NOT x)) ==> x       (IF (OR (EQ P1VALUE 'D-INDS)   ; only matters whether value is nil       (EQ P1VALUE 'NIL)       (AND (CONSP (SECOND ARG))    (BOOLEAN-FUNCTION-P (FIRST (SECOND ARG))))); always T or NIL   (SECOND ARG) FORM))      ((ALWAYS-TRUE ARG) '(QUOTE NIL))   ; (NOT #'f) ==> 'NIL      (T FORM))))(DEFUN ALWAYS-TRUE (ARG)  ;; Does expression ARG have no-side-effects and always evaluate  ;; to something other than NIL?  ;; 10/13/86 DNG - Test whether the argument has a type which is disjoint from NULL.  (CASE (CAR-SAFE ARG)    (QUOTE (SECOND ARG))    (FUNCTION     (AND (SYMBOLP (SECOND ARG))  (EQ (SYMBOL-PACKAGE (SECOND ARG)) SI:PKG-LISP-PACKAGE)  (FBOUNDP (SECOND ARG))  (SYMBOL-FUNCTION (SECOND ARG))  (>= (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH) (OPT-SAFETY OPTIMIZE-SWITCH))))    ((BREAKOFF-FUNCTION LEXICAL-CLOSURE) T)    (T (AND (<= (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH)(OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))    (LET (( ARG-TYPE (TYPE-OF-EXPRESSION ARG) ))      (AND (NOT (EQ ARG-TYPE 'T))   (OR (AND (SYMBOLP ARG-TYPE)    (MEMBER ARG-TYPE    ;; the subset of INTERESTING-TYPES that are    ;; disjoint from NULL    '(FIXNUM INTEGER SHORT-FLOAT NUMBER STRING      VECTOR ARRAY CONS CHARACTER LOCATIVE STREAM)    :TEST #'EQ))       (AND (CONSP ARG-TYPE)    (MEMBER (CAR ARG-TYPE) '(ARRAY VECTOR FUNCTION INTEGER))))   (NO-SIDE-EFFECTS-P ARG)))))));;;;        ==================================;;;;           Optimize membership tests;;;;        ==================================(DEFCONSTANT TEST-MEMBER-ALIST   '((EQ . MEMQ) (EQUAL . #+Elroy SI:MEMBER-EQUAL #-Elroy GLOBAL:MEMBER)     (EQL . MEMBER-EQL) (EQUALP . MEMBER-EQUALP))   "Alist of test functions and functions which can be used to check whether any memberof a list satisfies the test. Eg (EQ . MEMQ)")(ADD-POST-OPTIMIZER MEMBER CL-MEM-OPT)(DEFUN CL-MEM-OPT (FORM)  ;; Change Common Lisp MEMBER to MEMBER-EQL etc. to avoid keyword overhead when possible.  ;; 12/29/84 - Original.  ;;  1/04/85 - Use Zetalisp MEMBER for :TEST #'EQUAL.  ;;  4/21/86 - Modified for release 3 special case functions.  ;;  8/12/86 - Remove use of MEMBER-KEY, which no longer exists.  ;; 11/18/86 CLM - Added code to generate MEMBER* for those cases not already handled by  ;;                this optimization.  (IF (> (OPT-SAFETY OPTIMIZE-SWITCH) (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))      FORM    (LET ((FORM-LENGTH (LENGTH FORM)))      (COND((= FORM-LENGTH 3)   ; (MEMBER x y) ==> (MEMBER-EQL x y) `(MEMBER-EQL . ,(REST FORM)))((OR (/= FORM-LENGTH 5)     (EQUAL (FOURTH FORM) '(QUOTE :KEY))) (GENERIC-LIST-OPT-2 FORM '(SI:MEMBER*    (:TEST-NOT :KEY :TEST)) ) )    #|((EQUAL (FOURTH FORM) '(QUOTE :KEY)) ; (MEMBER x y :KEY z) ==> (MEMBER-KEY x y z) `(,(IF (COMPILING-FOR-V2) 'SI:MEMBER-KEY 'MEMBER-EQL)   ,(SECOND FORM) ,(THIRD FORM) ,(FIFTH FORM)))    |#((EQUAL (FOURTH FORM) '(QUOTE :TEST)) (LET ( TEM )   (IF (AND (MEMBER (CAR-SAFE (FIFTH FORM)) '(QUOTE FUNCTION) :TEST #'EQ) (SETQ TEM (ASSOC (SECOND (FIFTH FORM)) TEST-MEMBER-ALIST :TEST #'EQ)))       ;; (MEMBER x y :TEST #'EQUAL) ==> (MEMBER-EQUAL x y)       (LIST (CDR TEM) (SECOND FORM) (THIRD FORM))     (IF (COMPILING-FOR-V2) ;; (MEMBER x y :TEST z) ==> (MEMBER-TEST x y z) (LIST 'SI:MEMBER-TEST (SECOND FORM) (THIRD FORM) (FIFTH FORM))       FORM ))))(T FORM)))))(ADD-POST-OPTIMIZER GLOBAL:MEMBER MEMQ-EQ)(ADD-POST-OPTIMIZER SI:MEMBER-EQUAL MEMQ-EQ)(ADD-POST-OPTIMIZER MEMBER-EQUALP MEMQ-EQ)(ADD-POST-OPTIMIZER MEMBER-EQL MEMQ-EQ)(ADD-POST-OPTIMIZER MEMQ MEMQ-EQ)(DEFUN MEMQ-EQ (FORM)  ;;  4/21/86 - Call POST-OPTIMIZE on the new test form.  (OR (WHEN (= (LENGTH FORM) 3)(LET ((ITEM (CADR FORM))      (LIST (CADDR FORM)))  (WHEN (QUOTEP LIST)    (CASE (LENGTH (CADR LIST))       (0 `(PROGN ,ITEM  (QUOTE NIL)))       (1 `(AND ,(POST-OPTIMIZE `(,(CAR (RASSOC (CAR FORM)TEST-MEMBER-ALIST:TEST #'EQ))  ,ITEM ',(CAR (CADR LIST))))',(CADR LIST)))))))      FORM))(ADD-POST-OPTIMIZER MEMBER-EQL   MEMBER-EQL-MEMQ)(ADD-POST-OPTIMIZER SI:POSITION* MEMBER-EQL-MEMQ)(DEFUN MEMBER-EQL-MEMQ (FORM)  ;; 12/20/85 - Use EQ-COMPARABLE-P.  ;; 11/21/86 - Use this function for optimizing POSITION* also.  ;; 12/03/86 - Fix to not optimize POSITION* when second arg is not a list.  (OR (WHEN (= (LENGTH FORM) 3)(LET ((ITEM (CADR FORM))      (LIST (CADDR FORM)))  (WHEN (OR (AND (EQ (FIRST FORM) 'MEMBER-EQL) (EQ-COMPARABLE-P ITEM 'EQL))    (AND (QUOTEP LIST) (CONSP (CADR LIST)) (LOOP FOR X IN (CADR LIST)       ALWAYS (TYPEP X '(OR (NOT NUMBER) FIXNUM SHORT-FLOAT)))))    (LIST (IF (EQ (FIRST FORM) 'SI:POSITION*) 'FIND-POSITION-IN-LIST 'MEMQ)  ITEM  LIST))))      FORM))(ADD-POST-OPTIMIZER GLOBAL:MEMBER   MEMBER-MEMQ)(ADD-POST-OPTIMIZER SI:MEMBER-EQUAL MEMBER-MEMQ)(DEFUN MEMBER-MEMQ (FORM)  ;; 12/20/85 - Original.  (OR (WHEN (= (LENGTH FORM) 3)(LET ((ITEM (CADR FORM))      (LIST (CADDR FORM)))  (WHEN (OR (EQ-COMPARABLE-P ITEM 'EQUAL)    (AND (QUOTEP LIST) (CONSP (CADR LIST)) (LOOP FOR X IN (CADR LIST)       ALWAYS         (MEMBER (%DATA-TYPE X) '(#.DTP-FIX #.DTP-SYMBOL   #.DTP-CHARACTER #.DTP-SMALL-FLONUM) :TEST #'EQ))))    `(MEMQ ,ITEM ,LIST))))      FORM))(ADD-POST-OPTIMIZER ASSOC ASSOC-OPT)(DEFUN ASSOC-OPT (FORM)  ;; Change Common Lisp ASSOC to more specific functions.  ;;  4/21/86 - Original.  ;; 11/21/86 - Use ASSQ for constant list with fixnum or non-numeric keys.  (IF (> (OPT-SAFETY OPTIMIZE-SWITCH) (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))      FORM    (LET ((FORM-LENGTH (LENGTH FORM)))      (COND((AND (= FORM-LENGTH 3)   ; (ASSOC x y) ==> (ASSOC-EQL x y)      (COMPILING-FOR-V2)) (LET ( TEM )   (IF (AND (QUOTEP (THIRD FORM))    (CONSP (SETQ TEM (SECOND (THIRD FORM))))    (LOOP FOR X IN TEM  ALWAYS (TYPEP (CAR-SAFE X) '(OR (NOT NUMBER) FIXNUM SHORT-FLOAT))))       `(ASSQ . ,(REST FORM))     `(SI:ASSOC-EQL . ,(REST FORM)))))((/= FORM-LENGTH 5) FORM)((EQUAL (FOURTH FORM) '(QUOTE :TEST)) (LET ( TEM )   (IF (AND (MEMBER (CAR-SAFE (FIFTH FORM)) '(QUOTE FUNCTION) :TEST #'EQ) (SETQ TEM (ASSOC (SECOND (FIFTH FORM))  '((EQ . ASSQ)    (EQUAL . #+Elroy SI:ASSOC-EQUAL #-Elroy GLOBAL:ASSOC)    (EQL . SI:ASSOC-EQL)    (EQUALP . SI:ASSOC-EQUALP))  :TEST #'EQ)))       ;; (ASSOC x y :TEST #'EQUAL) ==> (ASSOC-EQUAL x y)       (LIST (CDR TEM) (SECOND FORM) (THIRD FORM))     (IF (COMPILING-FOR-V2) ;; (ASSOC x y :TEST z) ==> (ASSOC-TEST x y z) (LIST 'SI:ASSOC-TEST (SECOND FORM) (THIRD FORM) (FIFTH FORM))       FORM ))))((AND (EQUAL (FOURTH FORM) '(QUOTE :TEST-NOT))      (COMPILING-FOR-V2)) (LIST 'SI:ASSOC-TESTNOT (SECOND FORM) (THIRD FORM) (FIFTH FORM)))(T FORM)))))(ADD-POST-OPTIMIZER RASSOC RASSOC-OPT)(DEFUN RASSOC-OPT (FORM)  ;; Change Common Lisp RASSOC to more specific functions.  ;;  4/21/86 - Original.  (IF (> (OPT-SAFETY OPTIMIZE-SWITCH) (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))      FORM    (LET ((FORM-LENGTH (LENGTH FORM)))      (COND((AND (= FORM-LENGTH 3)   ; (RASSOC x y) ==> (RASSOC-EQL x y)      (COMPILING-FOR-V2)) `(SI:RASSOC-EQL . ,(REST FORM)))((/= FORM-LENGTH 5) FORM)((EQUAL (FOURTH FORM) '(QUOTE :TEST)) (LET ( TEM )   (IF (AND (MEMBER (CAR-SAFE (FIFTH FORM)) '(QUOTE FUNCTION) :TEST #'EQ) (SETQ TEM (ASSOC (SECOND (FIFTH FORM))  '((EQ . RASSQ)    (EQUAL . #+Elroy SI:RASSOC-EQUAL #-Elroy GLOBAL:RASSOC)    (EQL . SI:RASSOC-EQL)    (EQUALP . SI:RASSOC-EQUALP))  :TEST #'EQ)))       ;; (RASSOC x y :TEST #'EQUAL) ==> (RASSOC-EQUAL x y)       (LIST (CDR TEM) (SECOND FORM) (THIRD FORM))     (IF (COMPILING-FOR-V2) ;; (RASSOC x y :TEST z) ==> (RASSOC-TEST x y z) (LIST 'SI:RASSOC-TEST (SECOND FORM) (THIRD FORM) (FIFTH FORM))       FORM ))))((AND (EQUAL (FOURTH FORM) '(QUOTE :TEST-NOT))      (COMPILING-FOR-V2)) (LIST 'SI:RASSOC-TESTNOT (SECOND FORM) (THIRD FORM) (FIFTH FORM)))(T FORM)))))(ADD-POST-OPTIMIZER ASSQSEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER RASSQSEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER ASSOCSEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER SI:ASSOC-EQL SEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER SI:ASSOC-EQUAL SEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER SI:ASSOC-EQUALP SEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER GLOBAL:ASSOC SEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER ASSOC-IFSEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER ASSOC-IF-NOT SEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER RASSOCSEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER SI:RASSOC-EQL SEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER SI:RASSOC-EQUAL SEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER SI:RASSOC-EQUALP SEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER GLOBAL:RASSOC SEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER RASSOC-IFSEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER RASSOC-IF-NOT SEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER SI:POSITION* SEARCH-EMPTY-LIST) ; added 11/21/86(ADD-POST-OPTIMIZER SI:FIND-LIST SEARCH-EMPTY-LIST) ; added 11/21/86(DEFUN SEARCH-EMPTY-LIST (FORM)  ;;     (ASSOC x 'NIL) ==> 'NIL  ;;  1/14/86 DNG - Original.  (IF (AND (EQUAL (THIRD FORM) '(QUOTE NIL))   (NULL (CDDDR FORM)))      (CONS 'PROGN (REST FORM)) ; in case 1st arg has side-effects    FORM));;;;        ==================================;;;;           Optimize type tests;;;;        ==================================;;; Open coding of TYPEP and COERCE.  Optimizers defined in SYS: SYS; TYPES.(ADD-OPTIMIZER TYPEP SI::TYPEP-TWO-ARGS SI:TYPEP-STRUCTURE SI:TYPEP-FLAVOR   SUBINSTANCE-OF-CLASS-SYMBOL-P)#-Elroy(WHEN-SUPPORTING-CROSS-COMPILATION ; temporary so optimizer in COLD file is done first  (WHEN (EQUAL (GET 'TYPEP 'OPTIMIZERS) '(SI::TYPEP-TWO-ARGS DEFTYPE-LOAD))    (SETF (GET 'TYPEP 'OPTIMIZERS) '(DEFTYPE-LOAD SI::TYPEP-TWO-ARGS))))(ADD-OPTIMIZER COERCE SI::COERCE-OPTIMIZER SI::COERCE-TO-ARRAY-OPTIMIZED              SI::COERCE-TO-CHARACTER SI::COERCE-TO-LIST)(DEFUN FOLD-TYPE-PREDICATE (FORM TEST-TYPE)  ;; FORM is a call to a predicate which tests for TEST-TYPE.  ;;  5/12/86 DNG - Original.  (DECLARE (INLINE QUOTEP))  (COND ((CDDR FORM) FORM); too many arguments((QUOTEP (SECOND FORM)); argument is a constant (FOLD-CONSTANTS FORM))((> (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH)    (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)) FORM)(T (LET (( ARG-TYPE (TYPE-OF-EXPRESSION (SECOND FORM)) ))     (COND ((MEMBER ARG-TYPE '(T UNKNOWN) :TEST #'EQ)    FORM)   ((OR (EQ ARG-TYPE TEST-TYPE)(SUBTYPEP ARG-TYPE TEST-TYPE)) ; test passes    `(PROGN ,(SECOND FORM) 'T))   ((SI:DISJOINT-TYPEP ARG-TYPE TEST-TYPE) ; test fails    `(PROGN ,(SECOND FORM) 'NIL))   (T FORM) )))));;;;        ==================================;;;;           Array optimizations;;;;        ==================================(ADD-POST-OPTIMIZER MAKE-ARRAY TRY-TO-USE-SIMPLE-MAKE-ARRAY SI:SIMPLE-MAKE-ARRAY)(DEFUN TRY-TO-USE-SIMPLE-MAKE-ARRAY (FORM)  ;;  9/27/86 DNG - Changed from a pre-optimizer to a post-optimizer.  ;; 10/14/86 DNG - Add handling for :LEADER-LIST option.  ;; 11/21/86 DNG - Convert array type symbol to its corresponding number.  ;; 11/22/86 DNG - Use SI:INTERNAL-MAKE-SIMPLE-VECTOR when appropriate.  (LET ((LEN (LENGTH FORM)))    (WHEN (OR (< LEN 2) (ODDP LEN))      (RETURN-FROM TRY-TO-USE-SIMPLE-MAKE-ARRAY FORM)))  (LET ((DIMENSIONS-FORM (SECOND FORM))(INITIAL-VALUE-FORM '(QUOTE NIL))(INITIAL-VALUE-SPECIFIED NIL)(AREA-FORM '(QUOTE NIL))(TYPE-FORM '(QUOTE ART-Q))(LEADER-LENGTH-FORM '(QUOTE NIL))(FILL-POINTER-FORM '(QUOTE NIL))(FILL-POINTER-SPECIFIED NIL)(NAMED-STRUCTURE-SYMBOL-FORM '(QUOTE NIL))(NAMED-STRUCTURE-SYMBOL-SPECIFIED  NIL)(OUT-OF-ORDER NIL))    (LOOP FOR (KEYWORD-FORM ARGUMENT-FORM) ON (CDDR FORM) BY #'CDDR DO      (IF (NOT (QUOTEP KEYWORD-FORM))  (RETURN-FROM TRY-TO-USE-SIMPLE-MAKE-ARRAY FORM)(CASE (SECOND KEYWORD-FORM)  ((:TYPE :ELEMENT-TYPE)   (IF (EQ (SECOND KEYWORD-FORM) ':ELEMENT-TYPE)       (SETQ TYPE-FORM     (POST-OPTIMIZE `(SI:ARRAY-TYPE-FROM-ELEMENT-TYPE ,ARGUMENT-FORM)))     (SETQ TYPE-FORM ARGUMENT-FORM))   (UNLESS (AND (INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM AREA-FORM)(INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM LEADER-LENGTH-FORM)(INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM INITIAL-VALUE-FORM)(INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM FILL-POINTER-FORM)(INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM NAMED-STRUCTURE-SYMBOL-FORM))     (SETQ OUT-OF-ORDER T)))  (:AREA   (SETQ AREA-FORM ARGUMENT-FORM)   (UNLESS (AND (INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM LEADER-LENGTH-FORM)(INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM INITIAL-VALUE-FORM)(INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM FILL-POINTER-FORM)(INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM NAMED-STRUCTURE-SYMBOL-FORM))     (SETQ OUT-OF-ORDER T)))  (:LEADER-LENGTH   (SETQ LEADER-LENGTH-FORM ARGUMENT-FORM)   (UNLESS (AND (INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM INITIAL-VALUE-FORM)(INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM FILL-POINTER-FORM)(INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM NAMED-STRUCTURE-SYMBOL-FORM))     (SETQ OUT-OF-ORDER T)))  ((:INITIAL-VALUE :INITIAL-ELEMENT)   (SETQ INITIAL-VALUE-FORM ARGUMENT-FORM INITIAL-VALUE-SPECIFIED T)   (UNLESS (AND (INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM FILL-POINTER-FORM)(INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM NAMED-STRUCTURE-SYMBOL-FORM))     (SETQ OUT-OF-ORDER T)))  (:FILL-POINTER   (SETQ FILL-POINTER-FORM ARGUMENT-FORM FILL-POINTER-SPECIFIED T)   (UNLESS (INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM NAMED-STRUCTURE-SYMBOL-FORM)     (SETQ OUT-OF-ORDER T)))  (:LEADER-LIST   (IF (AND (QUOTEP ARGUMENT-FORM)    (CONSP (SECOND ARGUMENT-FORM))    (= (LENGTH (SECOND ARGUMENT-FORM)) 1)    (NOT FILL-POINTER-SPECIFIED))       (SETQ FILL-POINTER-FORM `(QUOTE ,(FIRST (SECOND ARGUMENT-FORM)))     FILL-POINTER-SPECIFIED T)     (RETURN-FROM TRY-TO-USE-SIMPLE-MAKE-ARRAY FORM)))  (:NAMED-STRUCTURE-SYMBOL   (SETQ NAMED-STRUCTURE-SYMBOL-FORM ARGUMENT-FORM NAMED-STRUCTURE-SYMBOL-SPECIFIED T))  (OTHERWISE (RETURN-FROM TRY-TO-USE-SIMPLE-MAKE-ARRAY FORM)))))    (IF OUT-OF-ORDER;; Don't optimize if it means exchanging two subforms;; which could affect each other.FORM      (LET ( STARTFORM )(WHEN FILL-POINTER-SPECIFIED  (SETQ LEADER-LENGTH-FORM (IF (EQUAL LEADER-LENGTH-FORM '(QUOTE NIL))       '(QUOTE 1)     (POST-OPTIMIZE `(MAX '1 ,LEADER-LENGTH-FORM)))))(WHEN (AND (QUOTEP TYPE-FORM)   (>= (OPT-SPEED OPTIMIZE-SWITCH) (OPT-SAFETY OPTIMIZE-SWITCH))   (EQ TARGET-PROCESSOR HOST-PROCESSOR))  ;; convert array type symbol to the corresponding number  (LET ((NUM (FOLD-CONSTANTS `(SI:COMPUTE-LISPM-ARRAY-TYPE ,TYPE-FORM))))    (WHEN (QUOTEP NUM) ;unless error       (SETQ TYPE-FORM NUM))))(WHEN (QUOTEP DIMENSIONS-FORM)  (LET ((DIM (SECOND DIMENSIONS-FORM)))    (WHEN (AND (CONSP DIM)       (NULL (CDR DIM))       (FIXNUMP (CAR DIM)))      (SETQ DIMENSIONS-FORM `(QUOTE ,(CAR DIM))))))(SETQ STARTFORM      (COND(INITIAL-VALUE-SPECIFIED `(SI:SIMPLE-MAKE-ARRAY ,DIMENSIONS-FORM ,TYPE-FORM ,AREA-FORM,LEADER-LENGTH-FORM ,INITIAL-VALUE-FORM))((AND (COMPILING-FOR-V2)      (SI:SIMPLE-VECTOR-SIZE-P (QUOTE-NUMBER DIMENSIONS-FORM))      (INDEPENDENT-EXPRESSIONS-P AREA-FORM LEADER-LENGTH-FORM)) (COND ((NOT (EQUAL AREA-FORM '(QUOTE NIL)))`(SI:INTERNAL-MAKE-SIMPLE-VECTOR ,DIMENSIONS-FORM ,TYPE-FORM ,LEADER-LENGTH-FORM ,AREA-FORM))       ((NOT (EQUAL LEADER-LENGTH-FORM '(QUOTE NIL)))`(SI:INTERNAL-MAKE-SIMPLE-VECTOR ,DIMENSIONS-FORM ,TYPE-FORM ,LEADER-LENGTH-FORM))       (T `(SI:INTERNAL-MAKE-SIMPLE-VECTOR ,DIMENSIONS-FORM ,TYPE-FORM))))((NOT (EQUAL LEADER-LENGTH-FORM '(QUOTE NIL))) `(SI:SIMPLE-MAKE-ARRAY ,DIMENSIONS-FORM ,TYPE-FORM ,AREA-FORM,LEADER-LENGTH-FORM))((NOT (EQUAL AREA-FORM '(QUOTE NIL))) `(SI:SIMPLE-MAKE-ARRAY ,DIMENSIONS-FORM ,TYPE-FORM ,AREA-FORM))(T `(SI:SIMPLE-MAKE-ARRAY ,DIMENSIONS-FORM ,TYPE-FORM))))(IF (OR FILL-POINTER-SPECIFIED NAMED-STRUCTURE-SYMBOL-SPECIFIED)    (LET ((ARRAY-VAR (GENSYM)))      (P1 `(LET ((,ARRAY-VAR ,(MARK-P1-DONE STARTFORM)) (FILL-POINTER ,(MARK-P1-DONE FILL-POINTER-FORM)) (NAMED-STRUCTURE-SYMBOL ,(MARK-P1-DONE NAMED-STRUCTURE-SYMBOL-FORM)))     (DECLARE (ARRAY ,ARRAY-VAR))     (AND ,FILL-POINTER-SPECIFIED       (SETF (FILL-POINTER ,ARRAY-VAR)     FILL-POINTER))     (AND ,NAMED-STRUCTURE-SYMBOL-SPECIFIED       (MAKE-ARRAY-INTO-NAMED-STRUCTURE ,ARRAY-VAR NAMED-STRUCTURE-SYMBOL))     ,ARRAY-VAR)))  STARTFORM)))))(ADD-POST-OPTIMIZER SI::ARRAY-TYPE-FROM-ELEMENT-TYPE ARRAY-TYPE-OPT)(ADD-POST-OPTIMIZER SI::TYPE-CANONICALIZE  ARRAY-TYPE-OPT)(DEFUN ARRAY-TYPE-OPT (FORM &AUX ARG)  ;; 01/14/86 DNG - Original.  [fold standard types only]  ;; 08/29/86 DNG - Use new function TYPE-SPECIFIER-P to enable folding user-defined types.  ;; 10/15/86 DNG - Fold (ARRAY-TYPE-FROM-ELEMENT-TYPE '*) ==> ART-Q  (IF (AND (NULL (CDDR FORM))   ; not more than 1 argument   (QUOTEP (SETQ ARG (SECOND FORM)))   (OR (SI:TYPE-SPECIFIER-P (SECOND ARG))       (AND (EQ (FIRST FORM) 'SI::ARRAY-TYPE-FROM-ELEMENT-TYPE)    (EQ (SECOND ARG) '*))))      (FOLD-CONSTANTS FORM)    FORM))(ADD-POST-OPTIMIZER MAKE-STRING MAKE-STRING-SIMPLE-MAKE-ARRAY SI:SIMPLE-MAKE-ARRAY)(DEFUN MAKE-STRING-SIMPLE-MAKE-ARRAY (FORM)  ;;  9/27/86 DNG - Changed from a pre-optimizer to a post-optimizer.  (LET* ((LOSS `(MAKE-ARRAY ,(CADR FORM) :TYPE ART-STRING ,@(CDDR FORM))) (LOSER (TRY-TO-USE-SIMPLE-MAKE-ARRAY LOSS)))    (IF (EQ LOSS LOSER)FORM      LOSER)))(ADD-OPTIMIZER GLOBAL:AREF AREF-EXPANDER)(DEFUN AREF-EXPANDER (FORM)  (CASE (LENGTH FORM)    (3 (CONS 'GLOBAL:AR-1 (CDR FORM)))    (4 (CONS 'AR-2   (CDR FORM)))    (5 (CONS 'AR-3   (CDR FORM)))    (T FORM)))(ADD-OPTIMIZER COMMON-LISP-AREF COMMON-LISP-AREF-EXPANDER)(ADD-OPTIMIZER AREF COMMON-LISP-AREF-EXPANDER)(DEFUN COMMON-LISP-AREF-EXPANDER (FORM)  ;;  4/26/85 - Modified to use new Explorer instructions COMMON-LISP-AR-2  ;;            and COMMON-LISP-AR-3. This assumes microcode version 186 or later.  ;;            [ref bug report 1136]  ;; Note: The Common Lisp array accessors differ from the Zetalisp versions  ;;       only in that elements of an ART-STRING are returned as character  ;;       objects instead of fixnums.  The Lambda instructions AR-2 and AR-3  ;;       are actually the same as the Explorer COMMON-LISP-AR-2 and -3, which  ;;       means that 2 or 3 dimensional ART-STRING arrays in Zetalisp mode  ;;       return characters instead of fixnums on a Lambda.  (But there is no  ;;       reason for Zetalisp to use multidimensional ART-STRING anyway --  ;;       just use ART-8B.)  (LET ((NEW-FN  (CASE (LENGTH FORM)    (3 'COMMON-LISP-AR-1)    (4 (IF (COMPILING-FOR-EXPLORER-P)   'COMMON-LISP-AR-2 'AR-2))    (5 (IF (COMPILING-FOR-EXPLORER-P)   'COMMON-LISP-AR-3 'AR-3))    (T 'COMMON-LISP-AREF))))    (IF (EQ NEW-FN (FIRST FORM))FORM      (CONS NEW-FN (REST FORM)))))(ADD-OPTIMIZER ASET ASET-EXPANDER)(DEFUN ASET-EXPANDER (FORM)  (CASE (LENGTH FORM)    (4 (CONS 'AS-1 (CDR FORM)))    (5 (CONS 'AS-2 (CDR FORM)))    (6 (CONS 'AS-3 (CDR FORM)))    (T FORM)))(ADD-OPTIMIZER SET-AREF SET-AREF-EXPANDER)(DEFUN SET-AREF-EXPANDER (FORM)  (CASE (LENGTH FORM)    (4 (CONS 'SET-AR-1 (CDR FORM)))    (5 (CONS 'SET-AR-2 (CDR FORM)))    (6 (CONS 'SET-AR-3 (CDR FORM)))    (T FORM)))(ADD-OPTIMIZER ALOC ALOC-EXPANDER)(DEFUN ALOC-EXPANDER (FORM)  (CASE (LENGTH FORM)    (3 (CONS 'AP-1 (CDR FORM)))    (4 (CONS 'AP-2 (CDR FORM)))    (5 (CONS 'AP-3 (CDR FORM)))    (T FORM)))(ADD-POST-OPTIMIZER AS-1 STORE-TO-SET)(ADD-POST-OPTIMIZER STORE-ARRAY-LEADER STORE-TO-SET)(ADD-POST-OPTIMIZER %INSTANCE-SET STORE-TO-SET)(DEFUN STORE-TO-SET (FORM);   (operation value array index)  ;; Change AS-1 to SET-AR-1 to enable use of AREFI instruction  ;; for constant index.  ;;  8/19/85 - Original.  (LET ((ARGL (CDR FORM)))    (IF (AND (= (LENGTH ARGL) 3)     (QUOTEP (THIRD ARGL))   ; constant index      (INDEPENDENT-EXPRESSIONS-P (FIRST ARGL) (SECOND ARGL)));; safe to change evaluation order(LIST (CDR (ASSOC (FIRST FORM)  '((AS-1 . SET-AR-1)    (STORE-ARRAY-LEADER . SET-ARRAY-LEADER)    (%INSTANCE-SET . %SET-INSTANCE-REF))  :TEST #'EQ))      (SECOND ARGL)   ; array      (THIRD ARGL)   ; index      (FIRST ARGL))   ; value      FORM)));;;;        ==================================;;;;           Optimize string functions;;;;        ==================================(ADD-POST-OPTIMIZER STRING-SEARCH STRING-SEARCH-STRING-SEARCH-CHAR STRING-SEARCH-CHAR)(ADD-POST-OPTIMIZER SI:SEARCH*-STRING-NOCASE STRING-SEARCH-STRING-SEARCH-CHAR)(ADD-POST-OPTIMIZER SI:SEARCH*-STRING-CASE STRING-SEARCH-STRING-SEARCH-CHAR)(DEFUN STRING-SEARCH-STRING-SEARCH-CHAR (FORM)  ;;  5/02/86 - Changed from pre to post optimizer and updated.  ;;  6/05/86 - Eliminated use of obsolete function STRING-LENGTH.  ;;  2/23/87 - Fixed to not call STRING-SEARCH-CHAR with too many arguments.  ;;  2/26/87 - Modify to use for SI:SEARCH*-STRING-CASE and SI:SEARCH*-STRING-NOCASE.  (LET* ((KEY-ARG (SECOND FORM)) KEY-VALUE (CHAR-ARG   (COND ((AND (QUOTEP KEY-ARG)       (PROGN (SETQ KEY-VALUE (SECOND KEY-ARG))      (OR (AND (OR (STRINGP KEY-VALUE)   (SYMBOLP KEY-VALUE))       (= (LENGTH (STRING KEY-VALUE)) 1))  (AND (FIXNUMP KEY-VALUE)       (<= 0 KEY-VALUE 255)))))  `(QUOTE ,(CHARACTER KEY-VALUE))) ((EXPR-TYPE-P KEY-ARG 'CHARACTER)  KEY-ARG) (T (RETURN-FROM STRING-SEARCH-STRING-SEARCH-CHAR FORM)))) (LEN (LENGTH FORM)))    (COND ((AND (<= LEN 5)(NOT (EQ (FIRST FORM) 'SI:SEARCH*-STRING-CASE)))   `(STRING-SEARCH-CHAR ,CHAR-ARG . ,(CDDR FORM)))  ((AND (> LEN 5)(OR (NOT (EQUAL (SIXTH FORM) '(QUOTE 0))); KEY-FROM    (AND (> LEN 6) (NOT (EQUAL (SEVENTH FORM) '(QUOTE NIL)))))); KEY-TO   FORM)  (T `(STRING-SEARCH-CHAR ,CHAR-ARG; CHAR  ,(THIRD FORM); STRING  ,(OR (FOURTH FORM) '(QUOTE 0)); FROM  ,(OR (FIFTH FORM) '(QUOTE NIL)); TO  . ,(IF (EQ (FIRST FORM) 'SI:SEARCH*-STRING-CASE) '((QUOTE T))       (NTHCDR 7 FORM)); CONSIDER-CASE  )))))(ADD-POST-OPTIMIZER STRING-SEARCH  COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER STRING-REVERSE-SEARCH COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER STRING-EQUAL COERCES-ARG-1-TO-STRING)#+Elroy(ADD-POST-OPTIMIZER GLOBAL:STRING-EQUAL COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER STRING= COERCES-ARG-1-TO-STRING)#+Elroy(ADD-POST-OPTIMIZER GLOBAL:STRING= COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER SI:STRING-EQUAL* COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER SI:STRING=*  COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER STRING< COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER STRING> COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER STRING<= COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER STRING>= COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER STRING/= COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER STRING-LESSP COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER STRING-GREATERP COERCES-ARG-1-TO-STRING);; These functions include a coercion of their first argument to a string,;; so (STRING-SEARCH (STRING x) ...) ==> (STRING-SEARCH x ...);; [The former form can result from optimization of a POSITION or SEARCH call.](DEFUN COERCES-ARG-1-TO-STRING ( FORM )  (LET (( ARG1 (SECOND FORM) ))    (IF (AND (CONSP ARG1)     (EQ (FIRST ARG1) 'STRING)     (= (LENGTH ARG1) 2))(LIST* (FIRST FORM) (SECOND ARG1) (CDDR FORM))      FORM)))(ADD-POST-OPTIMIZER STRING-SEARCHCOERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING-REVERSE-SEARCHCOERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING-SEARCH-CHARCOERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING-SEARCH-NOT-CHARCOERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING-REVERSE-SEARCH-CHARCOERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING-REVERSE-SEARCH-NOT-CHAR COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING-EQUAL COERCES-ARG-2-TO-STRING)#+Elroy(ADD-POST-OPTIMIZER GLOBAL:STRING-EQUAL COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING= COERCES-ARG-2-TO-STRING)#+Elroy(ADD-POST-OPTIMIZER GLOBAL:STRING= COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER SI:STRING-EQUAL* COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER SI:STRING=*  COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING< COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING> COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING<= COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING>= COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING/= COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING-LESSP COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING-GREATERP COERCES-ARG-2-TO-STRING);; (STRING-SEARCH x (STRING y) ...) ==> (STRING-SEARCH x y ...)(DEFUN COERCES-ARG-2-TO-STRING ( FORM )  (LET (( ARG2 (THIRD FORM) ))    (IF (AND (CONSP ARG2)     (EQ (FIRST ARG2) 'STRING)     (= (LENGTH ARG2) 2))(LIST* (FIRST FORM) (SECOND FORM) (SECOND ARG2) (CDDDR FORM))      FORM)));;;;        ==================================;;;;         Optimize variable binding forms;;;;        ==================================(ADD-POST-OPTIMIZER LET LET-OPT)(ADD-POST-OPTIMIZER LET* LET-OPT)(ADD-POST-OPTIMIZER LET-FOR-LAMBDA LET-OPT);;   1        2           3       4     5      6        7       8...;; (LET   lambda-list outer-vars vars bindp e-lex-cnt lex-cnt . body)(DEFUN LET-OPT (FORM &OPTIONAL DELETE-ALL) ;; 1/25/85 DNG - Call DISCARD on initial value of deleted variable. ;; 2/27/85 DNG - Fix for duplicated variable names. ;; 3/04/85 DNG - Move check for special variables referenced by the ;;               microcode from here to VARS-USED. ;; 1/09/86 DNG - Fix handling of doubly-defined variables. [SPR 1518] ;; 1/20/86 DNG - Another fix for handling of doubly-defined variables. ;; 9/16/86 DNG - Permit deleting variable initialized to (UNDEFINED-VALUE). ;; 9/25/86 DNG - Optimize out some variables which are used only once. ;;10/02/86 DNG - Don't call DISCARD on a value deleted by PROPAGATE-VALUES. ;;10/14/86 DNG - Optimize binding of *STANDARD-OUTPUT* around print functions. ;;10/18/86 DNG - Handle more cases of variables used once. ;;10/21/86 DNG - Fix for variable used once that depends on special variable bindings.  (DECLARE (SPECIAL PROPAGATE-ENABLE))  (UNLESS PROPAGATE-ENABLE    (RETURN-FROM LET-OPT FORM))  (LET ((VARS (FOURTH FORM))(VLIST (SECOND FORM))(CHANGED NIL)VUSED(BODY (NTHCDR 7 FORM))(NNEWVARS 0)(NEW-PROPAGATE 0))    (DO ((VS VARS) (VL VLIST (CDR VL)))((NULL VL))      (LOOP DO (SETQ V (FIRST VS)     VS (REST VS)     NNEWVARS (1+ NNEWVARS))    UNTIL (NEQ (VAR-KIND V) 'FEF-ARG-DELETED)))    (FLET ((USES-SPECIAL-BINDINGS-P (V OLD-VARS)     ;; Does the initial value of this variable use any special variables     ;; which are bound in this same LET?     (VARS-USED (SECOND (VAR-INIT V))(LET ((SPECIALS NIL))  (DO ((VS VARS (CDR VS)))      ((EQ VS OLD-VARS))    (WHEN (EQ (VAR-TYPE (CAR VS)) 'FEF-SPECIAL)      (PUSH (VAR-LAP-ADDRESS (CAR VS))    SPECIALS)))  SPECIALS)) ))    ;; delete unused variables from the lambda list    (SETQ VLIST      (LOOPFOR VLIST-TAIL ON VLISTFOR VAR = (FIRST VLIST-TAIL) ; each variable in lambda listDO(LOOP DO (SETQ V (NTH (SETQ NNEWVARS (1- NNEWVARS)) VARS))      UNTIL (NEQ (VAR-KIND V) 'FEF-ARG-DELETED)      FINALLY (UNLESS (EQ (VAR-NAME V)  (IF (ATOM VAR) VAR (FIRST VAR)))(WARN 'LET-OPT :BUG "Bug in ~S on ~S" 'LET-OPT VAR)(RETURN-FROM LET-OPT FORM)))IF (OR (AND (OR (NULL (SETQ USED (VAR-USE-COUNT V)))   ; never referenced(ZEROP USED)   ; value never usedDELETE-ALL)   ; called from DISCARD to throw all away    (MEMBER (VAR-KIND V)    '(FEF-ARG-INTERNAL-AUX FEF-ARG-FREE FEF-ARG-DELETED)    :TEST #'EQ)    (OR (EQ (VAR-TYPE V) 'FEF-LOCAL)DELETE-ALL(AND (OR (NEQ (FIRST FORM) 'LET*) (NULL (REST VLIST-TAIL)))     (OR (NULL BODY) (AND (NULL (REST BODY))      (OR ;; Check for references in the body form.(AND (< (OPT-SAFETY OPTIMIZE-SWITCH)(OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))     (NULL (VARS-USED (FIRST BODY)      (LIST (VAR-LAP-ADDRESS V)))));; Can binding be replaced by an optional argument?(AND (EQ (VAR-NAME V) '*STANDARD-OUTPUT*)     (MEMBER (CAR-SAFE (FIRST BODY))     '( PRIN1 PRINT PPRINT PRINC       WRITE-CHAR WRITE-STRING WRITE-LINE       WRITE-BYTE))     (= (LENGTH (FIRST BODY)) 2)     (INDEPENDENT-EXPRESSIONS-P       (SECOND (FIRST BODY)) (SECOND (VAR-INIT V)))     (PROGN       ;; (LET ((*STANDARD-OUTPUT* x)) (PRINT a)) ==> (PRINT a x)       ;; [such forms are created by the FORMAT optimizer]       (SETF (CDDR (FIRST BODY))     (LIST (SECOND (VAR-INIT V))))       (SETF VAR NIL)       T)))))))    (OR (ATOM VAR)DELETE-ALL(NO-SIDE-EFFECTS-P (SECOND VAR))))       (AND (EQL USED 1)    (MEMBER 'FEF-ARG-NOT-ALTERED (VAR-MISC V))    (<= (OPT-SAFETY OPTIMIZE-SWITCH)(OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))    (AND (NULL (REST BODY)) (CONSP (FIRST BODY)) (NOT (QUOTES-ANY-ARGS (FIRST (FIRST BODY)))) (NOT (USES-SPECIAL-BINDINGS-P V (THIRD FORM))) (DO ((INIT (SECOND (VAR-INIT V)))      (ARGS (REST (FIRST BODY)) (REST ARGS)))     ((NULL ARGS) NIL)   (COND ((EQ (FIRST ARGS) (VAR-LAP-ADDRESS V))  ;; (LET ((x (foo a))) (bar x)) ==> (bar (foo a))  (SETF (FIRST ARGS) INIT)  (SETF VAR NIL)  (RETURN T)) ((INDEPENDENT-EXPRESSIONS-P INIT (FIRST ARGS))) (T (RETURN NIL))))))       )   ; variable can be deletedDO (PROGN (DEBUG-ASSERT (OR (ATOM VAR)    (EQ (SECOND VAR) (SECOND (VAR-INIT V)))    (AND (EQUAL (SECOND VAR) '(UNDEFINED-VALUE)) (EQ (FIRST (VAR-INIT V)) 'FEF-INI-NONE))    (EQ (SECOND (VAR-INIT V)) 'DELETED-VALUE))NIL "init mismatch in LET-OPT for ~S" (VAR-NAME V))  ;; Now mark the variable deleted.  (SETF (VAR-KIND V) 'FEF-ARG-DELETED)  (UNLESS (OR (ATOM VAR)      (EQ (SECOND (VAR-INIT V)) 'DELETED-VALUE))    (DISCARD (SECOND VAR)))  (SETQ CHANGED T))ELSE COLLECT(PROGN  (WHEN (AND (EQL USED 1)     (MEMBER 'FEF-ARG-NOT-ALTERED (VAR-MISC V))     (<= (OPT-SAFETY OPTIMIZE-SWITCH) (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))     (OR ;;(ZEROP ALTERED-VAR-SET) ; include this when have time to debug it.       (INDEPENDENT-EXPRESSIONS-P (SECOND (VAR-INIT V)) (IF (AND (EQ (FIRST FORM) 'LET*)  (REST VLIST-TAIL))     FORM   (CONS 'VALUES BODY))))     (NOT (USES-SPECIAL-BINDINGS-P V (THIRD FORM))))    ;; Local variable used exactly once; try to replace the    ;; reference with the initial value expression.    (SETQ NEW-PROPAGATE  (LOGIOR NEW-PROPAGATE (CDDR (VAR-LAP-ADDRESS V)))))  VAR))))    (IF (AND (NULL VLIST) ; empty lambda list     (NULL (FIFTH FORM))   ;  no BIND     (= (SIXTH FORM) (SEVENTH FORM))   ; no lexical closures     )      (CONS 'PROGN BODY); (LET () body) ==> (PROGN body)      (PROGN(WHEN CHANGED; some variables deleted ;; change the form instead of creating a new list so that ;;  POST-OPTIMIZE won't waste time calling LET-OPT again.  (SETF (SECOND FORM) VLIST))(IF (AND (NULL (REST VLIST)) (CONSP (FIRST VLIST)) (NULL (REST BODY)) (EQ (VAR-LAP-ADDRESS (SETQ V (LOOKUP-VAR (FIRST (FIRST VLIST))  VARS)))     (FIRST BODY)) (NULL (FIFTH FORM))   ; no BIND (= (SIXTH FORM) (SEVENTH FORM))   ; no lexical closures )    ;;  (let ((a x)) a) ==> x    (PROGN (SETF (VAR-KIND V) 'FEF-ARG-DELETED)   (SECOND (FIRST VLIST)))  (IF (NOT (ZEROP (LOGDIF NEW-PROPAGATE PROPAGATE-VAR-SET)))      (LET* ((PROPAGATE-VAR-SET NEW-PROPAGATE)     (DONT-PROPAGATE-INTO-LOOP NEW-PROPAGATE)     (NEW-FORM (PROPAGATE-VALUES FORM)))(IF (EQ NEW-FORM FORM)    (LET-OPT FORM) ; remove variables whose use counts have now become 0  NEW-FORM))    FORM))))));;;;        ==================================;;;;             Utility functions;;;;        ==================================(DEFUN EQUAL-FORMS (A B)  ;; Compares two expressions (which have already been processed by P1)  ;; to see whether they are the same.  This is just like the standard  ;; EQUAL function except that alphabetic case is significant  ;; and we check for LOCAL-REF forms to avoid endless recursion  ;; on a circular list.  One consequence of this (not necessarily   ;; desirable) is that two references to the same local variable  ;; will test as being equal, but two variables with the same name but  ;; different scope will not be considered equal.  ;; 07/31/84 DNG - Original version.  ;; 10/21/86 DNG - Bypass THE-EXPR annotation.  (DECLARE (OPTIMIZE (SPEED 3) (SAFETY 0)))  (DECLARE (INLINE EQUAL-FORMS))  ;; First do as much testing as possible with EQ and ATOM since  ;; they are very fast.  (COND ((EQ A B) T)((ATOM A) (IF (NOT (ATOM B))     NIL   (EQUAL A B)))((ATOM B) NIL)((EQ (CAR A) 'THE-EXPR) (EQUAL-FORMS (EXPR-FORM A) B))((EQ (CAR B) 'THE-EXPR) (EQUAL-FORMS A (EXPR-FORM B)))((EQ (CAR A) 'LOCAL-REF) NIL)   ; don't try to compare circular list(T (AND (EQUAL-FORMS (CAR A) (CAR B))(EQUAL-FORMS (CDR A) (CDR B))))))(DEFUN TRIVIAL-FORM-P (X)  ;; Tests whether X is a constant or variable rather than a function call.  ;;  1/09/86 - Return true for all atoms, not just numbers and symbols.  ;;            [Especially needs to return true for characters and strings.]  ;;  3/12/86 - Return true for THE-EXPR form wrapped around a variable.  (DECLARE (INLINE TRIVIAL-FORM-P))   ; so interpreted def. is saved.  (OR (ATOM X)      (MEMBER (CAR X) '(QUOTE LOCAL-REF SELF-REF LEXICAL-REF FUNCTION BREAKOFF-FUNCTION)      :TEST #'EQ)      (AND (EQ (CAR X) 'THE-EXPR) (TRIVIAL-FORM-P (EXPR-FORM X)))))(DEFUN FUNCTION-WITHOUT-SIDE-EFFECTS-P (FUNCTION-NAME)  ;;  9/15/86 DNG - Original version separated from NO-SIDE-EFFECTS-P.  ;; 10/18/86 DNG - Check for some new P1 handlers besides P1SIMPLE.  (DECLARE (OPTIMIZE SPEED) (TYPE SYMBOL FUNCTION-NAME))  (OR (MEMBER (GET FUNCTION-NAME 'P1) '(P1SIMPLE P1ARITHMETIC P1ACCESSOR P1AREF) :TEST #'EQ)      (MEMBER FUNCTION-NAME      '(LIST CONS LIST* EQ NCONS CONS-IN-AREA VALUES)      :TEST #'EQ)      (LET (( OPTS (GET FUNCTION-NAME 'POST-OPTIMIZERS) ))(IF (LISTP OPTS)    (LOOP FOR X IN OPTS  THEREIS  (IF (ATOM X)      (MEMBER X      '(FOLD-ONE-ARG ARITH-OPT-NON-ASSOCIATIVEFOLD-NUMBERS ADD-1-OPT *TIMES-OPTAND-OPT OR-OPT 3CXR-OPTIMIZE FOLD-STRING-EQUAL)      :TEST #'EQ)    (MEMBER (CAR X) '(FOLD-TYPE-PREDICATE)    :TEST #'EQ)))  (MEMBER OPTS  '(FOLD-ONE-ARG ARITH-OPT-NON-ASSOCIATIVE FOLD-NUMBERS ADD-1-OPT *TIMES-OPT AND-OPT OR-OPT 3CXR-OPTIMIZE FOLD-STRING-EQUAL)  :TEST #'EQ))))   ; operator for which constant folding is enabled  )(DEFUN NO-SIDE-EFFECTS-P (FORM)  ;; Returns true if FORM is known to not produce any side-effects when it is  ;;   evaluated; returns NIL if FORM has side-effects or if we don't know.  ;; The current criteria is rather simple and could be improved later.  ;; 09/01/84 DNG - Fixed for no side-effects of C...R and EQ.  ;; 02/06/85 DNG - Check for P1SIMPLE handler; beware of functions  ;;                passed as arguments.  ;; 03/05/85 DNG - Add FOLD-NUMBERS to list of constant folders.  ;; 06/26/85 DNG - Fix DECLARE so TRIVIAL-FORM-P will be inline.  ;; 12/02/85 DNG - Don't use TRIVIAL-FORM-P in order to exclude BREAKOFF-FUNCTION.  ;;  3/10/86 DNG - Add handling of THE-EXPR form.  ;;  5/30/86 DNG - Fix for POST-OPTIMIZERS property which is not a list.  ;;  6/06/86 DNG - Recognize users of FOLD-TYPE-PREDICATE as not having side-effects.  ;;  7/12/86 DNG - BREAKOFF-FUNCTION and LEXICAL-CLOSURE can now be considered to have no side-effects.  ;;  9/11/86 DNG - Return true for (UNDEFINED-VALUE).  ;;  9/15/86 DNG - Use new function FUNCTION-WITHOUT-SIDE-EFFECTS-P .  ;;  9/25/86 DNG - Return true for (%FUNCTION-INSIDE-SELF).  (DECLARE (OPTIMIZE SPEED) (INLINE TRIVIAL-FORM-P))  (IF (OR (ATOM FORM)  (MEMBER (CAR FORM)  '(QUOTE LOCAL-REF SELF-REF LEXICAL-REF    FUNCTION BREAKOFF-FUNCTION LEXICAL-CLOSURE UNDEFINED-VALUE)  :TEST #'EQ)  (AND   ; function call    ;; don't bother with recursive expression traversal if user    ;;   is most concerned with fast compilation.    (< (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH) 3)    ;; This function is usually used to decide whether an expression    ;;   can be either deleted or moved.  Since such optimizations    ;;   could confuse debugging, don't do them when the user has    ;;   requested extra safety.  Also, deleting an expression    ;;   could hide an error that would have occurred if it had    ;;   been executed.    (< (OPT-SAFETY OPTIMIZE-SWITCH) 2)    (COND      ((EQ (FIRST FORM) 'COND)       (DOLIST (C (REST FORM)) (DOLIST (X C)   (UNLESS (NO-SIDE-EFFECTS-P X)     (RETURN-FROM NO-SIDE-EFFECTS-P NIL))))       (RETURN-FROM NO-SIDE-EFFECTS-P T))      ((EQ (FIRST FORM) 'THE-EXPR)       (AND (ZEROP (EXPR-ALTERED FORM))    (OR SIDE-EFFECT-ENABLE(NO-SIDE-EFFECTS-P (EXPR-FORM FORM)))))      ((NULL (CDR FORM)) ; no arguments       (EQ (FIRST FORM) '%FUNCTION-INSIDE-SELF))      (T       (AND (FUNCTION-WITHOUT-SIDE-EFFECTS-P (FIRST FORM))    (DOLIST (ARG (REST FORM) T)   ; check each argument      (COND((ATOM ARG))((MEMBER (FIRST ARG) '(QUOTE LOCAL-REF SELF-REF LEXICAL-REF) :TEST #'EQ))((EQ (FIRST ARG) 'FUNCTION) ;; If a function is being passed as an argument, ;; then it may have side-effects when it is invoked. (UNLESS (OR (MEMBER (FIRST FORM)     '(PROGN AND OR EQ EQL EQUAL NOT) ; these don't call the function     :TEST #'EQ)     (AND (SYMBOLP (SECOND ARG))  (FUNCTION-WITHOUT-SIDE-EFFECTS-P (SECOND ARG))))   (RETURN NIL)))((MEMBER (FIRST ARG) '(BREAKOFF-FUNCTION LEXICAL-CLOSURE) :TEST #'EQ) (UNLESS (ZEROP (COMPILAND-ALTERED-VAR-SET (SECOND ARG)))   (RETURN NIL)))(T (UNLESS (NO-SIDE-EFFECTS-P ARG)     (RETURN NIL))))))))))      T    NIL))(DEFPARAMETER STACK-MANIPULATORS   ;; Sub-primitives which change the level of the stack.   '(%PUSH %POP %DUP %PUSH-VALUES-AND-COUNT MULTIPLE-VALUE-PUSH     %MAKE-EXPLICIT-STACK-LIST %MAKE-EXPLICIT-STACK-LIST* %EXCHANGE))(DEFUN INDEPENDENT-EXPRESSIONS-P (FORM1 FORM2)  ;; Are FORM1 and FORM2 independent expressions?  That, is, can they  ;; be evaluated in either order without changing the results?  ;;  8/19/85 - Original version.  ;;  4/21/86 - FUNCTION form can't interact with anything else.  ;;  9/18/86 - Use new function INVULNERABLE-EXPRESSION-P .  ;; 10/18/86 - (%POP) can't be interchanged with anything.  (COND ((INVULNERABLE-EXPRESSION-P FORM1) (OR (ATOM FORM2)     (NOT (MEMBER (FIRST FORM2) STACK-MANIPULATORS :TEST #'EQ))))((INVULNERABLE-EXPRESSION-P FORM2) (OR (ATOM FORM1)     (NOT (MEMBER (FIRST FORM1) STACK-MANIPULATORS :TEST #'EQ))))((AND SIDE-EFFECT-ENABLE      (EQ (CAR-SAFE FORM1) 'THE-EXPR)      (EQ (CAR-SAFE FORM2) 'THE-EXPR)) (AND (ZEROP (LOGAND (EXPR-USED FORM1) (EXPR-ALTERED FORM2)))      (ZEROP (LOGAND (EXPR-USED FORM2) (EXPR-ALTERED FORM1)))))(T (AND (NO-SIDE-EFFECTS-P FORM1)(NO-SIDE-EFFECTS-P FORM2)))));;;;        ==================================;;;;          Optimize variable assignment;;;;        ==================================(ADD-POST-OPTIMIZER SET SET-OPT)(DEFUN SET-OPT (FORM); (SET 'x y) ==> (SETQ x y)  (IF (AND (NULL (CDDDR FORM))   (QUOTEP (SECOND FORM))   (SYMBOLP (SECOND (SECOND FORM))))      (LET ((NAME (SECOND (SECOND FORM))))(PUSHNEW NAME FREEVARS)(LIST 'SETQ NAME (THIRD FORM)))    FORM))(ADD-POST-OPTIMIZER SYMEVAL SYMEVAL-OPT)(ADD-POST-OPTIMIZER SYMBOL-VALUE SYMEVAL-OPT)(DEFUN SYMEVAL-OPT (FORM); (SYMBOL-VALUE 'x) ==> x  ;; 3/4/86 - Original.  ;; 2/9/87 - Fix for NIL.  (IF (AND (NULL (CDDR FORM))   (QUOTEP (SECOND FORM))   (SYMBOLP (SECOND (SECOND FORM))))      (LET ((NAME (SECOND (SECOND FORM))))(IF (OR (EQ NAME 'NIL) (EQ NAME 'T) (KEYWORDP NAME))    (SECOND FORM)  (PROGN (PUSHNEW NAME FREEVARS) NAME)))    FORM))(ADD-POST-OPTIMIZER SETQ SETQ-OPT)(DEFUN SETQ-OPT (FORM)  (IF (NULL (REST FORM))   ; (SETQ) ==> NIL      '(QUOTE NIL)    (DO ((PAIRS (REST FORM) (CDDR PAIRS)))((NULL PAIRS) FORM)      (WHEN (EQ (FIRST PAIRS) (SECOND PAIRS))   ; setting a variable to itself(LET ((NEWFORM (CONS (FIRST FORM) (SETQ-OPT-1 (REST FORM)))))  ;; (SETQ ... a b x x y z ...) ==> (SETQ ... a b y z ...)  (WHEN P1VALUE    ;; if the value of the SETQ form is going to be used,     ;;  check whether the last assignment was deleted;    ;;  if so, construct a PROGN to hold the value.    (LOOP WHILE (CDDR PAIRS)  DO (SETQ PAIRS (CDDR PAIRS)))    (WHEN (EQ (FIRST PAIRS) (SECOND PAIRS))      (SETQ NEWFORM (LIST 'PROGN (POST-OPTIMIZE NEWFORM) (FIRST PAIRS)))))  (RETURN-FROM SETQ-OPT NEWFORM))))))(DEFUN SETQ-OPT-1 (PAIRS) ; remove pairs of list elements in which the two items are identical.  (COND ((NULL PAIRS) NIL)((EQ (FIRST PAIRS) (SECOND PAIRS)) (SETQ-OPT-1 (CDDR PAIRS)))(T (LIST* (FIRST PAIRS) (SECOND PAIRS) (SETQ-OPT-1 (CDDR PAIRS))))))  (ADD-OPTIMIZER PSETQ SAVE-PSETQ)(DEFUN SAVE-PSETQ (FORM)  ;;  8/15/86 DNG - Don't change the form when at top level in a file.  (IF P1VALUE   ; if value used      (IF (EQ P1VALUE 'TOP-LEVEL-FORM)  FORM(PROGN  (WHEN (AND (ATOM P1VALUE)   ; unless at end of function     (NOT COMPILING-COMMON-LISP))    (WARN 'PSETQ :IMPLAUSIBLE "Attempt to use value returned from (PSETQ ~S ..."  (SECOND FORM)))  ;; In ZetaLisp, the value returned from PSETQ was documented  ;; as "undefined" but was actually the value of one of the  ;; assignments.  Common Lisp specifies that PSETQ always  ;; returns NIL.  (LIST 'PROGN FORM NIL)))    (IF (>= (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)    (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH));; prevent macro expansion of PSETQ so it can be post-optimized.(CONS 'INTERNAL-PSETQ (REST FORM))      FORM)))(ADD-POST-OPTIMIZER INTERNAL-PSETQ PSETQ-OPT)(DEFUN PSETQ-OPT (FORM) ;;  optimize (PSETQ V1 E1 ... Vn En) by attempting to use SETQ  (COND    ((NULL (REST FORM)) '(QUOTE NIL));  (PSETQ)  ==>  NIL    ((NULL (CDDDR FORM));  (PSETQ x y) ==> (SETQ x y)     (CONS 'SETQ (REST FORM)))    (T; at least two variables     (LET ((PRE NIL); assignments for SETQ before the PSETQ (reverse order)   (POST NIL); assignments for SETQ after PSETQ (forward order)   (PSETQ NIL); assignments that must still be done in parallel   (USES NIL); set of Vi occurring in any Ej other than Ei   (PSVARS NIL); destination variables ( Vn ... V2 V1 )   (HAS-SIDE-EFFECTS NIL) ; points to first expression with side-effects    PSETQ-SIDE-EFFECTS ; does any Ei have side-effects?   (PSET-LIST NIL))   ;;    First, construct USES list       (DO ((PAIRS (REST FORM) (CDDR PAIRS)))   ((NULL PAIRS)) (PUSH (FIRST PAIRS) PSVARS) ; list variables being assigned )       (DO ((PAIRS (REST FORM) (CDDR PAIRS)))   ((OR (NULL PAIRS); until nothing left to look at(NULL PSVARS))); or nothing left to look for    ;; check each expression to see if it references any of    ;; the other assignment destination variables. (DOLIST (USED (VARS-USED (SECOND PAIRS)  (REMOVE (FIRST PAIRS)  (THE LIST PSVARS)  :TEST #'EQ)))   (PUSH USED USES); this variable is referenced   (SETQ PSVARS (DELETE USED (THE LIST PSVARS) :TEST #'EQ))   ;; no need to look for any more references to same variable   ))       ;;    Look for assignments that can be done serially before the others,       ;;    while scanning the PSETQ from left to right, being careful to keep       ;;    expressions with side-effects in the same order.       (DO ((PAIRS (REST FORM) (CDDR PAIRS)))   ((NULL PAIRS)) (LET ((V (FIRST PAIRS))       (E (SECOND PAIRS)))   (COND     ((AND (OR (NOT HAS-SIDE-EFFECTS) ; no variables altered       (QUOTEP E))   ; or none referenced   (NOT (MEMBER V USES :TEST #'EQ)))      ;; This variable is not used in any of the other      ;; expressions so its assignment can be moved to a      ;; SETQ before the PSETQ.      (SETQ PRE (LIST* E V PRE)))     (T      (UNLESS HAS-SIDE-EFFECTS(UNLESS (NO-SIDE-EFFECTS-P E)  (SETQ HAS-SIDE-EFFECTS E)))      (SETQ PSET-LIST (LIST* E V PSET-LIST))))))       ;;    Look for assignments that can be done serially after the others,       ;;    while scanning the PSETQ from right to left, being careful to keep       ;;    expressions with side-effects in the same order.       (SETQ PSETQ-SIDE-EFFECTS NIL)       (DO ((PAIRS PSET-LIST (CDDR PAIRS)))   ((NULL PAIRS)) (LET ((E (FIRST PAIRS))       (V (SECOND PAIRS)))   (COND     ((OR (QUOTEP E)  (AND (NOT PSETQ-SIDE-EFFECTS)       (NULL (VARS-USED E (REMOVE V (THE LIST USES) :TEST #'EQ)))))      ;; This expression does not reference any of the      ;; other variables so the assignment can be moved      ;; to a SETQ following the PSETQ.      (SETQ POST (LIST* V E POST)))     (T      (SETQ PSETQ (LIST* V E PSETQ)) ; leave in PSETQ      (WHEN (AND (NOT PSETQ-SIDE-EFFECTS) ; no side-effects yet in right-to left scan HAS-SIDE-EFFECTS  ; but some E does have side-effects (OR (EQ E HAS-SIDE-EFFECTS)   ; this is the one     (NOT (NO-SIDE-EFFECTS-P E))   ; this one does too      ))(SETQ PSETQ-SIDE-EFFECTS T))))))       (IF (OR PRE POST);; We have been able to split up the assignments, so now;; put the pieces together for the optimized code. (LET ((NEW-FORMS NIL))   (WHEN POST     (PUSH (POST-OPTIMIZE (CONS 'SETQ POST)) NEW-FORMS))   (WHEN PSETQ     (PUSH (POST-OPTIMIZE (CONS (FIRST FORM) PSETQ)) NEW-FORMS))   (WHEN PRE     (PUSH (POST-OPTIMIZE (CONS 'SETQ (NREVERSE PRE))) NEW-FORMS))   (CONS 'PROGN NEW-FORMS)) ;; Else, no improvements could be made, so set up to do ;; parallel assignment using PROG1 primitive. `(SETQ ,(FIRST PSETQ)(PROG1  ,(SECOND PSETQ)  ,(POST-OPTIMIZE (CONS (FIRST FORM) (CDDR PSETQ))))))))));; Bindings of the following special variables can't be optimized away even;; when they don't appear to be used, because they are used by the error handler,;; which could get invoked at nearly any time.  [SPR 2447](DEFPROP EH:CONDITION-HANDLERS       T DONT-OPTIMIZE-SPECIAL-VARIABLE)(DEFPROP EH:CONDITION-DEFAULT-HANDLERS T DONT-OPTIMIZE-SPECIAL-VARIABLE)(DEFPROP EH:CONDITION-RESUME-HANDLERS  T DONT-OPTIMIZE-SPECIAL-VARIABLE);; New names for release 3:(DEFPROP EH:*CONDITION-HANDLERS* T DONT-OPTIMIZE-SPECIAL-VARIABLE)(DEFPROP EH:*CONDITION-DEFAULT-HANDLERS* T DONT-OPTIMIZE-SPECIAL-VARIABLE)(DEFPROP EH:*CONDITION-RESUME-HANDLERS*  T DONT-OPTIMIZE-SPECIAL-VARIABLE)(DEFUN VARS-USED (EXP LOOK-FOR)  ;; Scan expression EXP, looking for occurences of the variables  ;; in the list LOOK-FOR.  Returns a list of those variables in LOOK-FOR  ;; which were actually found.  ;; The arguments have already been processed by P1, so variables will  ;; appear as atoms only when they are special variables.  ;;  ;; Since this function is used to decide whether optimizations can be safely    ;; done, it does not attempt to go to the time and trouble of doing an  ;; exhaustive analysis of the expression.  It is designed to quickly  ;; analyze simple expressions; if a form is encountered that it can't handle,   ;; it gives up and assumes that all the variables are referenced.  ;;  ;;  3/04/85 - Added special handling for special variables used by the microcode.  ;;  6/20/86 - Add test for DONT-OPTIMIZE-SPECIAL-VARIABLE property. [SPR 2447]  (DECLARE (SPECIAL LOOK-FOR))  (LET ((FOUND NIL)(NO-SPECIALS NIL)FOUND2)    (DECLARE (SPECIAL FOUND NO-SPECIALS))    (SETQ FOUND2 (CATCH 'VARS-USED   (VARS-USED-1 EXP)   FOUND))    (DOLIST (V LOOK-FOR)      (WHEN (SYMBOLP V) ; special variable(COND ((MEMBER (CAR-SAFE EXP) '( QUOTE LOCAL-REF ) :TEST #'EQ)       ;; Too trivial for the special cases below to apply.       (RETURN))      ((GET V 'DONT-OPTIMIZE-SPECIAL-VARIABLE)       ;; Variable used in unusual way; have to play it safe by assuming       ;; that it is referenced even when it doesn't look like it.       (PUSH V FOUND2))      ((OR (MEMBER V (SYMEVAL-FOR-TARGET 'M-MEMORY-LOCATION-NAMES)   :TEST #'EQ)   (MEMBER V (SYMEVAL-FOR-TARGET 'A-MEMORY-LOCATION-NAMES)   :TEST #'EQ))       ;; Special variable that is directly referenced by the microcode.       (UNLESS (TRIVIAL-FORM-P EXP) (PUSH V FOUND2))))))    FOUND2))(DEFUN VARS-USED-1 (EXP) ; called only by VARS-USED  (DECLARE (SPECIAL LOOK-FOR FOUND NO-SPECIALS))  ;; As variables are found, they are removed from the list of those  ;; begin searched for; if we find them all, then we can quit without  ;; needing to look at the rest of the expression.  ;; 09/25/84 DNG - Fix to recognize that the micro-coded function  ;;                CLOSURE references special variables.  ;; 02/25/85 DNG - Fix to handle flavor instance variables correctly;  ;;                fix to recognize FUNCALL as a possible special variable  ;;                reference.  ;; 03/04/85 DNG - Added check of LEXICAL-CLOSURE-COUNT; count SELF-REF  ;;                as a reference to SELF and SELF-MAPPING-TABLE.  (COND    ((NULL LOOK-FOR)     (THROW 'VARS-USED FOUND))    ((MEMBER EXP LOOK-FOR :TEST #'EQ) ; found one     (PUSH EXP FOUND)     (SETQ LOOK-FOR (DELETE EXP (THE LIST LOOK-FOR) :TEST #'EQ)))    ((ATOM EXP))    ((MEMBER (FIRST EXP) '(QUOTE LOCAL-REF FUNCTION) :TEST #'EQ))    ((MEMBER (FIRST EXP) '(SELF-REF LEXICAL-REF) :TEST #'EQ)     ;; Instance variable references need special handling because     ;; they are not EQ.     (DOLIST (V LOOK-FOR)       (WHEN (EQUAL EXP V) (PUSH V FOUND) ; V instead of EXP so EQ to var looked for (SETQ LOOK-FOR (REMOVE V (THE LIST LOOK-FOR) :TEST #'EQ))))     (WHEN (EQ (FIRST EXP) 'SELF-REF)       (VARS-USED-1 'SELF)       (VARS-USED-1 'SELF-MAPPING-TABLE)))    ((EQ (FIRST EXP) 'COND)     (DOLIST (C (REST EXP))       (DOLIST (X C) (VARS-USED-1 X))))    ((EQ (FIRST EXP) 'RETURN-FROM)     (VARS-USED-1 (THIRD EXP)))    ((AND (QUOTES-ANY-ARGS (FIRST EXP))  (NOT (MEMBER (FIRST EXP) '(AND OR SETQ) :TEST #'EQ)))     ;; special form: don't bother trying to analyze, just make a     ;; safe worst case assumption that it references everything.     (THROW 'VARS-USED    (APPEND FOUND LOOK-FOR)))    (T; general function call     (WHEN (AND (NOT NO-SPECIALS) ; may be looking for special variables  (NOT  (AND (GETL (FIRST EXP) '(P2 COMPILER:QINTCMP OPCODE))       (NOT (MEMBER (FIRST EXP) '(FUNCALL LEXPR-FUNCALL APPLY CLOSURE   FUNCALL-WITH-MAPPING-TABLE-INTERNAL   LEXPR-FUNCALL-WITH-MAPPING-TABLE-INTERNAL) :TEST #'EQ)))))       ;; function which might reference special variables       (DOLIST (V LOOK-FOR) (WHEN (OR (ATOM V) ; special variable, assume referenced   (NEQ (FIRST V) 'LOCAL-REF)   (NOT (ZEROP LEXICAL-CLOSURE-COUNT)))   (PUSH V FOUND)   (SETQ LOOK-FOR (DELETE V (THE LIST LOOK-FOR) :TEST #'EQUAL))))       (SETQ NO-SPECIALS T) ; don't need to do this again       )     ;; finally, examine the function arguments     (DOLIST (ARG (REST EXP))       (VARS-USED-1 ARG)))))(ADD-OPTIMIZER SETF SETF-OPT)(DEFUN SETF-OPT (FORM)  ;; 10/18/86 DNG - Original.  ;; 11/14/86 DNG - Fix for NIL place.  (IF (AND (CONSP (SECOND FORM))   (EQ (FIRST (SECOND FORM)) 'VALUES)   (NOT (EQ P1VALUE 'TOP-LEVEL-FORM)))      ;; special handling for (SETF (VALUES ...) ...)      (LET ((RESULT NIL))(UNLESS (NULL (CDDDR FORM))  (PUSH `(SETF . ,(CDDDR FORM)) RESULT))(LET ((TEMP (GENSYM)))  (DOLIST (PLACE (REST (SECOND FORM)))    (SETQ PLACE (PRE-OPTIMIZE PLACE T)) ; expand macros    (PUSH (COND ((ATOM PLACE) (IF (NULL PLACE)     `(%POP-PDL) ; avoid decrementing PDLLVL in P2   `(SETQ ,PLACE (%POP))))((MEMBER (GET (CAR PLACE) 'SI:SETF-METHOD) '(SET-AREF SET-AR-1)) `(ASET (%POP) . ,(REST PLACE)))(T `(LET ((,TEMP (%POP)))      (SETF ,PLACE ,TEMP))))  RESULT)))`(PROGN (MULTIPLE-VALUE-PUSH ,(LENGTH (REST (SECOND FORM))) ; number of values     ,(THIRD FORM)). ,RESULT) )    FORM))(DEFUN (:PROPERTY %POP-PDL P2) (ARGL IGNORE) ; like %POP but don't decrement PDLLVL  (OUT-AUX 'POP-PDL (OR (FIRST ARGL) 1)));;;;        ==================================;;;;           Miscellaneous optimizations;;;;        ==================================#-Elroy ; this is a macro in release 3(ADD-OPTIMIZER COMMENT COMMENT-EXPAND)#-Elroy(DEFUN COMMENT-EXPAND (IGNORE)  '(QUOTE COMMENT));; 8/15/86 DNG - Deleted DEFPROP-EXPAND; now using inline expansion instead.;;Changed because DEFPROP is better than PUTPROP at top level.;;Also, the optimizer did not give the correct result value.;; 5/10/86 DNG - Moved GET-FROM-ALTERNATING-LIST optimizer to ZETALISP file.;;Moved GLOBAL:CATCH and GLOBAL:THROW optimizers to MACLISP file;;;deleted *CATCH-PROGNIFY since now handled by P1CATCH.;;Optimization of GET and (TIME) to (TIME-IN-60THS) moved to file TYPEOPT.(ADD-OPTIMIZER INHIBIT-STYLE-WARNINGS INHIBIT-STYLE-OPT);; This doesn't do anything except suppress style checking.;; The only reason for having an optimizer instead of using the macro definition;; is to prevent it from wasting space in the MACROS-EXPANDED debug info.(DEFUN INHIBIT-STYLE-OPT (FORM) ; 9/26/86 Original.  (IF (NULL (CDDR FORM))      (SECOND FORM)    (CONS 'PROGN (REST FORM))))(ADD-OPTIMIZER SI:DISPLACED UN-DISPLACE)(DEFUN UN-DISPLACE (FORM)  ;; 11/14/86 DNG - Original.  Don't let displaced macro expansion take  ;;precedence over a local macro.  [SPR 2796]  (IF (OR *LOCAL-ENVIRONMENT* ;might be a local macro  (GET (FIRST FORM) 'OPTIMIZERS)) ; need to optimize before macro expansion      (SECOND FORM) ; use the original form    (THIRD FORM) ; else use the macro expansion that has already been done.    ));;;;        ==================================;;;;          Function name substitution;;;;        ==================================(DEFUN SUBSTITUTE-FUNCTION-NAME ( FORM )  ;; When compiling a call to a function defined by DEFF, change the form  ;; to call the real function directly.  ;;  5/10/86 DNG - Replaced FIX-SYNONYM-SPECIAL-FORM with this function,  ;;which was moved from file MACLISP and simplified.  (LET ( NEWFN )    (IF (AND (FBOUNDP (FIRST FORM))     (SETQ NEWFN (FUNCTION-NAME (SYMBOL-FUNCTION (FIRST FORM))))     (SYMBOLP NEWFN)     (NEQ NEWFN (FIRST FORM)) )(CONS NEWFN (REST FORM))      FORM ) ) )                                                                                        #-Elroy ; these are no longer used in release 3(progn;;; These functions are defined in ENCAPS, but loaded here(ADD-OPTIMIZER SI::ENCAPSULATION-LETSUBSTITUTE-FUNCTION-NAME)(ADD-OPTIMIZER SI::ENCAPSULATION-LIST*SUBSTITUTE-FUNCTION-NAME)(ADD-OPTIMIZER SI::ADVISE-PROGSUBSTITUTE-FUNCTION-NAME)(ADD-OPTIMIZER SI::ADVISE-SETQSUBSTITUTE-FUNCTION-NAME)(ADD-OPTIMIZER SI::ADVISE-PROGNSUBSTITUTE-FUNCTION-NAME)(ADD-OPTIMIZER SI::ADVISE-MULTIPLE-VALUE-LIST SUBSTITUTE-FUNCTION-NAME)(ADD-OPTIMIZER SI::ADVISE-RETURN-LIST SUBSTITUTE-FUNCTION-NAME)(ADD-OPTIMIZER SI::ADVISE-APPLYSUBSTITUTE-FUNCTION-NAME)(ADD-OPTIMIZER SI::ADVISE-LETSUBSTITUTE-FUNCTION-NAME)(ADD-OPTIMIZER SI::ADVISE-LIST*SUBSTITUTE-FUNCTION-NAME));;;;        ==================================;;;;           Generic sequence optimizations;;;;        ==================================;;for the following optimizations, the list of optional arguments is deliberately;;in REVERSE order to facilitate truncating trailing nil's(ADD-POST-OPTIMIZER DELETE-DUPLICATES     (GENERIC-SEQUENCES-OPT-1 (SI:DELETE-DUPLICATES-LISTSI:DELETE-DUPLICATES-VECTOR SI:DELETE-DUPLICATES*        (:FROM-END :END :START :TEST-NOT :KEY :TEST))))(ADD-POST-OPTIMIZER REMOVE-DUPLICATES     (GENERIC-SEQUENCES-OPT-1 (SI:REMOVE-DUPLICATES-LISTSI:REMOVE-DUPLICATES-VECTOR SI:REMOVE-DUPLICATES*        (:FROM-END :END :START :TEST-NOT :KEY :TEST))))(ADD-POST-OPTIMIZER DELETE     (GENERIC-SEQUENCES-OPT-2 (SI:DELETE-LIST SI:DELETE-VECTOR SI:DELETE*        (:FROM-END :END :START :TEST-NOT :KEY :COUNT :TEST))))(ADD-POST-OPTIMIZER DELETE-IF      (GENERIC-SEQUENCES-OPT-2 (SI:DELETE-IF-LIST SI:DELETE-IF-VECTOR SI:DELETE-IF*        (:FROM-END :END :START :KEY :COUNT))))(ADD-POST-OPTIMIZER DELETE-IF-NOT      (GENERIC-SEQUENCES-OPT-2 (SI:DELETE-IF-NOT-LIST SI:DELETE-IF-NOT-VECTOR SI:DELETE-IF-NOT*        (:FROM-END :END :START :KEY :COUNT))))(ADD-POST-OPTIMIZER REMOVE     (GENERIC-SEQUENCES-OPT-2 (SI:REMOVE-LIST SI:REMOVE-VECTOR SI:REMOVE*        (:FROM-END :END :START :TEST-NOT :KEY :COUNT :TEST))))(ADD-POST-OPTIMIZER REMOVE-IF     (GENERIC-SEQUENCES-OPT-2 (SI:REMOVE-IF-LIST SI:REMOVE-IF-VECTOR SI:REMOVE-IF*        (:FROM-END :END :START :KEY :COUNT))))(ADD-POST-OPTIMIZER REMOVE-IF-NOT     (GENERIC-SEQUENCES-OPT-2 (SI:REMOVE-IF-NOT-LIST SI:REMOVE-IF-NOT-VECTOR SI:REMOVE-IF-NOT*        (:FROM-END :END :START :KEY :COUNT))))(ADD-POST-OPTIMIZER FIND      (GENERIC-SEQUENCES-OPT-2 (SI:FIND-LIST SI:FIND-VECTOR SI:FIND*        (:FROM-END :END :START :TEST-NOT :KEY :TEST))))(ADD-POST-OPTIMIZER FIND-IF      (GENERIC-SEQUENCES-OPT-2 (SI:FIND-IF-LIST SI:FIND-IF-VECTOR SI:FIND-IF*        (:FROM-END :END :START :KEY))))(ADD-POST-OPTIMIZER FIND-IF-NOT      (GENERIC-SEQUENCES-OPT-2 (SI:FIND-IF-NOT-LIST SI:FIND-IF-NOT-VECTOR SI:FIND-IF-NOT*        (:FROM-END :END :START :KEY))))(ADD-POST-OPTIMIZER COUNT      (GENERIC-SEQUENCES-OPT-2 (SI:COUNT-LIST SI:COUNT-VECTOR SI:COUNT*        (:FROM-END :END :START :TEST-NOT :KEY :TEST))))(ADD-POST-OPTIMIZER COUNT-IF      (GENERIC-SEQUENCES-OPT-2 (SI:COUNT-IF-LIST SI:COUNT-IF-VECTOR SI:COUNT-IF*        (:FROM-END :END :START :KEY))))(ADD-POST-OPTIMIZER COUNT-IF-NOT      (GENERIC-SEQUENCES-OPT-2 (SI:COUNT-IF-NOT-LIST SI:COUNT-IF-NOT-VECTOR SI:COUNT-IF-NOT*        (:FROM-END :END :START :KEY))))(ADD-POST-OPTIMIZER REPLACE      (GENERIC-SEQUENCES-OPT-2 ( SI:REPLACE* SI:REPLACE* SI:REPLACE*        (:END2 :START2 :END1 :START1))))(ADD-POST-OPTIMIZER STRING=      (GENERIC-SEQUENCES-OPT-2 (SI:STRING=* SI:STRING=* SI:STRING=*         (:END2 :START2 :END1 :START1))))(ADD-POST-OPTIMIZER STRING-EQUAL      (GENERIC-SEQUENCES-OPT-2 (SI:STRING-EQUAL* SI:STRING-EQUAL* SI:STRING-EQUAL*         (:END2 :START2 :END1 :START1))))(ADD-POST-OPTIMIZER NSUBSTITUTE      (GENERIC-SEQUENCES-OPT-3 (SI:NSUBSTITUTE-LIST SI:NSUBSTITUTE-VECTOR SI:NSUBSTITUTE*        (:FROM-END :END :START :TEST-NOT :KEY :COUNT :TEST))))(ADD-POST-OPTIMIZER NSUBSTITUTE-IF      (GENERIC-SEQUENCES-OPT-3 (SI:NSUBSTITUTE-IF-LIST SI:NSUBSTITUTE-IF-VECTOR SI:NSUBSTITUTE-IF*        (:FROM-END :END :START :KEY :COUNT))))(ADD-POST-OPTIMIZER NSUBSTITUTE-IF-NOT      (GENERIC-SEQUENCES-OPT-3 (SI:NSUBSTITUTE-IF-NOT-LIST       SI:NSUBSTITUTE-IF-NOT-VECTOR SI:NSUBSTITUTE-IF-NOT*        (:FROM-END :END :START :KEY :COUNT))))(ADD-POST-OPTIMIZER SUBSTITUTE      (GENERIC-SEQUENCES-OPT-3 (SI:SUBSTITUTE-LIST SI:SUBSTITUTE-VECTOR SI:SUBSTITUTE*        (:FROM-END :END :START :TEST-NOT :KEY :COUNT :TEST))))(ADD-POST-OPTIMIZER SUBSTITUTE-IF      (GENERIC-SEQUENCES-OPT-3 (SI:SUBSTITUTE-IF-LIST SI:SUBSTITUTE-IF-VECTOR SI:SUBSTITUTE-IF*        (:FROM-END :END :START :KEY :COUNT))))(ADD-POST-OPTIMIZER SUBSTITUTE-IF-NOT      (GENERIC-SEQUENCES-OPT-3 (SI:SUBSTITUTE-IF-NOT-LIST       SI:SUBSTITUTE-IF-NOT-VECTOR SI:SUBSTITUTE-IF-NOT*        (:FROM-END :END :START :KEY :COUNT))))(DEFUN REFORM-ARG-LIST (KEY-ARGS OPT-ARGS FCTN-NAME)  ;;  9/23/86 CLM - Original version.  Convert keyword arguments into optional args.  ;;  9/29/86 CLM - Added test to make sure switching the argument order is possible,  ;;                i.e. no order dependencies.  ;;  9/29/86 DNG - Change the error message to lower case.  ;; 10/01/86 DNG - Default the :TEST argument to #'EQL instead of NIL; fix to  ;;gracefully handle an odd number of keyword and value args or an  ;;atom where a quoted keyword is expected.  Use :TEST #'EQ in the calls to POSITION.  ;; 10/02/86 DNG - Modify previous fix to not specify both :TEST and :TEST-NOT.  ;; 11/18/86 CLM - Default :start1 and :start2 keyword args to 0.  ;;  3/13/87 DNG - Also default :START to 0 when not the last argument.  (LET ((OPT-A (COPY-LIST OPT-ARGS))(TEST-NOT NIL))    (DECLARE (TYPE LIST OPT-A))    ;;loop thru key-args list to see if key-arg is valid for the function; if not,    ;;signal an error.  also see if key-arg is a variable and if so, return nil    ;;signalling no optimizations can be done.    (DO ((KARG KEY-ARGS (CDDR KARG)))((NULL KARG))      (IF (AND (QUOTEP (CAR KARG))       (MEMBER (CADAR KARG) OPT-ARGS :TEST #'EQ))  (UNLESS (CDR KARG)    (WARN 'KEYWORD-NOT-VALID :IMPOSSIBLE  "Missing value for last keyword in (~S ... ~S)."  FCTN-NAME (CADAR KARG))    (RETURN-FROM REFORM-ARG-LIST NIL))  (DO ((RESTARGS (CDDR KARG) (CDDR RESTARGS)))      ((NULL RESTARGS))    (UNLESS (INDEPENDENT-EXPRESSIONS-P (SECOND KARG) (SECOND RESTARGS))      (WHEN (< (POSITION (CADAR KARG) OPT-A :TEST #'EQ)       (POSITION (CADAR RESTARGS) OPT-A :TEST #'EQ))(RETURN-FROM REFORM-ARG-LIST NIL))))(PROGN  (WHEN (QUOTEP (CAR KARG))    (WARN 'KEYWORD-NOT-VALID :IMPOSSIBLE  "The function ~S was called with the invalid keyword argument ~S."  FCTN-NAME (CADAR KARG)))  (RETURN-FROM REFORM-ARG-LIST NIL))))    (DO ((OPT-ARG OPT-A (CDR OPT-ARG)) (ANY-SUPPLIED NIL))((NULL OPT-ARG) ;;REMOVE TRAILING NILS (DO ((ARGS OPT-A (CDR ARGS)))     ((NOT (EQUAL (CAR ARGS) '(QUOTE NIL))))   (POP OPT-A)) (RETURN  (NREVERSE OPT-A)))      (DO ((KEY-ARG KEY-ARGS (CDDR KEY-ARG)))  ((NULL KEY-ARG)   (SETF (CAR OPT-ARG) (IF KEY-ARGS     (COND ((AND (EQ (CAR OPT-ARG) ':TEST) (NOT TEST-NOT))    '(FUNCTION EQL))   ((MEMBER (CAR OPT-ARG) '(:START1 :START2))    '(QUOTE 0))   ((AND (EQ (CAR OPT-ARG) ':START) ANY-SUPPLIED)    '(QUOTE 0))   (T '(QUOTE NIL)))     '(QUOTE NIL)) ));;IF KEY-ARG IN NOT ON THE OPT-ARG LIST, THAT INDICATES THAT;;THE KEY IS A DUPLICATE AND IN SUCH CASES REFERENCES AFTER THE FIRST;;ARE DISCARDED(WHEN (EQ (CADAR KEY-ARG) (CAR OPT-ARG))  (WHEN (EQ (CAR OPT-ARG) ':TEST-NOT)    (SETQ TEST-NOT T))  (SETF (CAR OPT-ARG) (CADR KEY-ARG))  (SETF ANY-SUPPLIED T)  (RETURN))  ))))(DEFUN GENERIC-SEQUENCES-OPT-1 (FORM OPT)  ;; 9/23/86 CLM - Original version.  (LET ((OPTIONAL-ARG-FORMAT (FOURTH OPT))(ACTUAL-KEY-ARGS (CDDR FORM)))    (IF (NOT (COMPILING-FOR-V2))FORM(LET (ARG-LIST)  (SETQ ARG-LIST (REFORM-ARG-LIST ACTUAL-KEY-ARGS OPTIONAL-ARG-FORMAT (FIRST FORM)))  (IF (OR ARG-LIST  (NULL ACTUAL-KEY-ARGS)) ;may not be any keyargs, but still do the opt      (COND ((EXPR-TYPE-P (SECOND FORM) 'LIST)     (APPEND (LIST (FIRST OPT) (SECOND FORM))     ARG-LIST ))    ((EXPR-TYPE-P (SECOND FORM) 'ARRAY)     (APPEND (LIST (SECOND OPT) (SECOND FORM))     ARG-LIST ))    (T     (APPEND (LIST (THIRD OPT) (SECOND FORM))     ARG-LIST )) )      FORM)) ) ))(DEFUN GENERIC-SEQUENCES-OPT-2 (FORM OPT)  ;; 9/23/86 CLM - Original version.  (LET ((OPTIONAL-ARG-FORMAT (FOURTH OPT))(ACTUAL-KEY-ARGS (CDDDR FORM)))    (IF (NOT (COMPILING-FOR-V2))FORM(LET (ARG-LIST)  (SETQ ARG-LIST (REFORM-ARG-LIST ACTUAL-KEY-ARGS OPTIONAL-ARG-FORMAT (FIRST FORM)))  (IF (OR ARG-LIST  (NULL ACTUAL-KEY-ARGS))      (COND ((EXPR-TYPE-P (THIRD FORM) 'LIST)     (APPEND (LIST (CAR OPT) (SECOND FORM) (THIRD FORM))     ARG-LIST ))    ((EXPR-TYPE-P (THIRD FORM) 'ARRAY)     (APPEND (LIST (CADR OPT) (SECOND FORM) (THIRD FORM))     ARG-LIST ))    (T     (APPEND (LIST (CADDR OPT) (SECOND FORM) (THIRD FORM))     ARG-LIST )) )      FORM)) ) ))(DEFUN GENERIC-SEQUENCES-OPT-3 (FORM OPT)  ;; 9/23/86 CLM - Original version.  (LET ((OPTIONAL-ARG-FORMAT (FOURTH OPT))(ACTUAL-KEY-ARGS (CDDDDR FORM)))   (IF (NOT (COMPILING-FOR-V2))      FORM      (LET (ARG-LIST)(SETQ ARG-LIST (REFORM-ARG-LIST ACTUAL-KEY-ARGS OPTIONAL-ARG-FORMAT (CAR FORM)))(IF (OR ARG-LIST(NULL ACTUAL-KEY-ARGS))    (COND ((EXPR-TYPE-P (FOURTH FORM) 'LIST)   (APPEND (LIST (FIRST OPT) (SECOND FORM) (THIRD FORM) (FOURTH FORM))   ARG-LIST ))  ((EXPR-TYPE-P (FOURTH FORM) 'ARRAY)   (APPEND (LIST (SECOND OPT) (SECOND FORM) (THIRD FORM) (FOURTH FORM))   ARG-LIST ))  (T   (APPEND (LIST (THIRD OPT) (SECOND FORM) (THIRD FORM) (FOURTH FORM))   ARG-LIST )) )    FORM)) ) ));;;the optimizer for position is the same for lists of two req args(ADD-POST-OPTIMIZER POSITION      (GENERIC-LIST-OPT-2 (SI:POSITION*        (:FROM-END :END :START :TEST-NOT :KEY :TEST))))(ADD-POST-OPTIMIZER POSITION-IF     (GENERIC-LIST-OPT-2 (SI:POSITION-IF*        (:FROM-END :END :START :KEY))))(ADD-POST-OPTIMIZER POSITION-IF-NOT     (GENERIC-LIST-OPT-2 (SI:POSITION-IF-NOT*        (:FROM-END :END :START :KEY))))(ADD-POST-OPTIMIZER ADJOIN      (GENERIC-LIST-OPT-2 (SI:ADJOIN*        (:TEST-NOT :KEY :TEST))))(ADD-POST-OPTIMIZER SUBLIS       (GENERIC-LIST-OPT-2 (SI:SUBLIS*        (:TEST-NOT :KEY :TEST))))(ADD-POST-OPTIMIZER NSUBLIS       (GENERIC-LIST-OPT-2 (SI:NSUBLIS*        (:TEST-NOT :KEY :TEST))))(ADD-POST-OPTIMIZER INTERSECTION       (GENERIC-LIST-OPT-2 (SI:INTERSECTION*        (:TEST-NOT :KEY :TEST))))(ADD-POST-OPTIMIZER NINTERSECTION       (GENERIC-LIST-OPT-2 (SI:NINTERSECTION*        (:TEST-NOT :KEY :TEST))))(ADD-POST-OPTIMIZER SET-DIFFERENCE       (GENERIC-LIST-OPT-2 (SI:SET-DIFFERENCE*        (:TEST-NOT :KEY :TEST))))(ADD-POST-OPTIMIZER NSET-DIFFERENCE       (GENERIC-LIST-OPT-2 (SI:NSET-DIFFERENCE*        (:TEST-NOT :KEY :TEST))))(ADD-POST-OPTIMIZER UNION       (GENERIC-LIST-OPT-2 (SI:UNION*        (:TEST-NOT :KEY :TEST))))(ADD-POST-OPTIMIZER NUNION       (GENERIC-LIST-OPT-2 (SI:NUNION*        (:TEST-NOT :KEY :TEST))))(ADD-POST-OPTIMIZER SET-EXCLUSIVE-OR       (GENERIC-LIST-OPT-2 (SI:SET-EXCLUSIVE-OR*        (:TEST-NOT :KEY :TEST))))(ADD-POST-OPTIMIZER NSET-EXCLUSIVE-OR       (GENERIC-LIST-OPT-2 (SI:NSET-EXCLUSIVE-OR*        (:TEST-NOT :KEY :TEST))))(ADD-POST-OPTIMIZER SUBSETP       (GENERIC-LIST-OPT-2 (SI:SUBSETP*        (:TEST-NOT :KEY :TEST))))(DEFUN GENERIC-LIST-OPT-2 (FORM OPT)  ;; 9/23/86 CLM - Original version.  (LET ((OPTIONAL-ARG-FORMAT (SECOND OPT))(ACTUAL-KEY-ARGS (CDDDR FORM)))    (IF (NOT (COMPILING-FOR-V2))FORM(LET (ARG-LIST)  (SETQ ARG-LIST (REFORM-ARG-LIST ACTUAL-KEY-ARGS OPTIONAL-ARG-FORMAT (FIRST FORM)))  (IF (OR ARG-LIST  (NULL ACTUAL-KEY-ARGS))       (APPEND (LIST (FIRST OPT) (SECOND FORM) (THIRD FORM))      ARG-LIST )      FORM)) )))(ADD-POST-OPTIMIZER SUBST      (GENERIC-LIST-OPT-3 (SI:SUBST*        (:TEST-NOT :KEY :TEST))))(ADD-POST-OPTIMIZER NSUBST      (GENERIC-LIST-OPT-3 (SI:NSUBST*        (:TEST-NOT :KEY :TEST))))(DEFUN GENERIC-LIST-OPT-3 (FORM OPT)  ;; 9/23/86 CLM - Original version.  (LET ((OPTIONAL-ARG-FORMAT (SECOND OPT))(ACTUAL-KEY-ARGS (CDDDDR FORM)))    (IF (NOT (COMPILING-FOR-V2))FORM(LET (ARG-LIST)  (SETQ ARG-LIST (REFORM-ARG-LIST ACTUAL-KEY-ARGS OPTIONAL-ARG-FORMAT (FIRST FORM)))  (IF (OR ARG-LIST  (NULL ACTUAL-KEY-ARGS))      (APPEND (LIST (FIRST OPT) (SECOND FORM) (THIRD FORM) (FOURTH FORM))      ARG-LIST )      FORM)) ) ));;;;        ==================================;;;;              SEARCH optimization;;;;        ==================================(ADD-POST-OPTIMIZER SEARCH SEARCH-OPT)(DEFUN SEARCH-OPT (FORM)  (IF (NOT (COMPILING-FOR-V2))      FORM  (LET* ((ACTUAL-KEY-ARGS (CDDDR FORM)) (ARG-LIST   (REFORM-ARG-LIST ACTUAL-KEY-ARGS    '(:TEST-NOT :KEY :FROM-END :END1 :START1 :END2 :START2 :TEST)    (FIRST FORM))))    (IF (OR ARG-LIST    (NULL ACTUAL-KEY-ARGS))(COND ((AND (EXPR-TYPE-P (SECOND FORM) 'ARRAY)    (EXPR-TYPE-P (THIRD FORM) 'ARRAY))       (IF (<= (LENGTH ARG-LIST) 5)   (LET ((TEST (FIRST ARG-LIST)))     (IF (AND (CONSP TEST)      (MEMBER (FIRST TEST) '(QUOTE FUNCTION))      (OR (EQ (SECOND TEST) 'EQ)  (AND (MEMBER (SECOND TEST) '(CHAR= CHAR-EQUAL))       (EXPR-TYPE-P (SECOND FORM) 'STRING)       (EXPR-TYPE-P (THIRD FORM) 'STRING)))) (LIST* (IF (EQ (SECOND TEST) 'CHAR-EQUAL)    'SI:SEARCH*-STRING-NOCASE  'SI:SEARCH*-STRING-CASE)(SECOND FORM) (THIRD FORM) (REST ARG-LIST))       (IF (MEMBER TEST '(NIL 'EQL #'EQL) :TEST #'EQUAL)   (LIST* (IF (AND (EXPR-TYPE-P (SECOND FORM) 'STRING)   (EXPR-TYPE-P (THIRD FORM) 'STRING))      'SI:SEARCH*-STRING-CASE    'SI:SEARCH*-VECTOR-EQL)  (SECOND FORM) (THIRD FORM) (REST ARG-LIST)) `(SI:SEARCH*-VECTOR ,(SECOND FORM) ,(THIRD FORM) . ,ARG-LIST) ))) (LET ((FROM-END (SIXTH ARG-LIST)))   (COND ((EQUAL FROM-END '(QUOTE NIL))  (LIST* 'SI:SEARCH*-VECTOR (SECOND FORM) (THIRD FORM) (NCONC (FIRSTN 5 ARG-LIST) (NTHCDR 6 ARG-LIST)))) ((ALWAYS-TRUE FROM-END)  (LIST* 'SI:SEARCH*-VECTOR-FROMEND (SECOND FORM) (THIRD FORM) (NCONC (FIRSTN 5 ARG-LIST) (NTHCDR 6 ARG-LIST)))) (T `(SI:SEARCH* ,(SECOND FORM) ,(THIRD FORM) . ,ARG-LIST)) ))))      ((AND (EXPR-TYPE-P (SECOND FORM) 'LIST)    (EXPR-TYPE-P (THIRD FORM) 'LIST))       `(SI:SEARCH*-LIST ,(SECOND FORM) ,(THIRD FORM) . ,ARG-LIST))      (T `(SI:SEARCH* ,(SECOND FORM) ,(THIRD FORM) . ,ARG-LIST)) )      FORM))))(ADD-POST-OPTIMIZER SI:SEARCH*-VECTOR(TRIM-TRAILING-ARGS (T T #'EQL '0 'NIL '0)))(ADD-POST-OPTIMIZER SI:SEARCH*-VECTOR-FROMEND(TRIM-TRAILING-ARGS (T T #'EQL '0 'NIL '0)))(ADD-POST-OPTIMIZER SI:SEARCH*-VECTOR-EQL(TRIM-TRAILING-ARGS (T T '0 'NIL '0)))(ADD-POST-OPTIMIZER SI:SEARCH*-STRING-NOCASE(TRIM-TRAILING-ARGS (T T '0 'NIL '0 'NIL)))(ADD-POST-OPTIMIZER SI:SEARCH*-STRING-CASE(TRIM-TRAILING-ARGS (T T '0 'NIL '0 'NIL)))(ADD-POST-OPTIMIZER SI:SEARCH*-STRING-NOCASE-FROMEND(TRIM-TRAILING-ARGS (T T '0 'NIL '0 'NIL)))(ADD-POST-OPTIMIZER SI:SEARCH*-STRING-CASE-FROMEND(TRIM-TRAILING-ARGS (T T '0 'NIL '0 'NIL)))(ADD-POST-OPTIMIZER SI:SEARCH*-LIST(TRIM-TRAILING-ARGS (T T #'EQL '0 'NIL '0)))(ADD-POST-OPTIMIZER SI:SEARCH*(TRIM-TRAILING-ARGS (T T #'EQL '0 'NIL '0)))(ADD-POST-OPTIMIZER STRING-REVERSE-SEARCH-CHAR(TRIM-TRAILING-ARGS (T T 'NIL '0 'NIL)))(ADD-POST-OPTIMIZER STRING-REVERSE-SEARCH-NOT-CHAR (TRIM-TRAILING-ARGS (T T 'NIL '0 'NIL)))(DEFUN TRIM-TRAILING-ARGS (FORM &OPTIONAL DEFAULTS)  ;; Delete trailing arguments which are the same as the default value.  ;; The default default is (QUOTE NIL); T means always keep the arg.  ;;  2/26/87 DNG - Original.  (LET ((NKEEP 1)(TRIM NIL))    (DO ((ARGS (REST FORM) (REST ARGS)) (DEFAULTS DEFAULTS (REST DEFAULTS)) (ARGN 2 (1+ ARGN)))((NULL ARGS))      (IF (EQUAL (FIRST ARGS) (IF DEFAULTS (FIRST DEFAULTS) '(QUOTE NIL)))  (SETQ TRIM T)(SETQ NKEEP ARGN TRIM NIL)))    (IF TRIM(PROGN (DISCARD-FORMS (NTHCDR NKEEP FORM))       (FIRSTN NKEEP FORM))      FORM)))(ADD-POST-OPTIMIZER MISMATCH     (GENERIC-SEQUENCES-OPT-2 (SI:MISMATCH* SI:MISMATCH* SI:MISMATCH*  (:TEST-NOT :KEY :FROM-END :END1 :START1 :END2 :START2 :TEST))))(ADD-POST-OPTIMIZER SI:MISMATCH* (TRIM-TRAILING-ARGS (T T #'EQL '0 'NIL '0 'NIL)))(PROCLAIM '(TRY-INLINE REDUCE SI:REDUCE*))(ADD-POST-OPTIMIZER SI:REDUCE*TRIM-TRAILING-ARGS)(ADD-POST-OPTIMIZER SI:REDUCE-LISTTRIM-TRAILING-ARGS)(ADD-POST-OPTIMIZER SI:REDUCE-VECTORTRIM-TRAILING-ARGS) (a (and b ...)))       `(COND (,ARG1 ,(POST-OPTIMIZE (CONS 'AND (CDDR FORM))))) )      (T FORM))))(ADD-POST-OPTIMIZER OR OR-OPT)(DEFUN OR-OPT (FORM &AUX ARG1 ARG2) ;; 12/28/84 - Add use of DISCARD. ;;  1/29/85 - Use ALWAYS-TRUE; add optimization for SETQ argument. ;;  2/03/86 - Remove duplicate arguments.  (COND    ((NULL (REST FORM)) '(QUOTE NIL)); (or)   ==> nil    ((NULL (CDDR FORM)) (SECOND FORM)); (or x) ==> x    ((EQUAL (SETQ ARG1 (SECOND FORM))    '(QUOTE NIL)) ; (or nil x y) ==> (or x y)     (DISCARD ARG1) (CONS 'OR (CDDR FORM)))    ((ALWAYS-TRUE ARG1); (or t x) ==> t     (DISCARD-FORMS (CDDR FORM)) ARG1)    ((EQUAL (SETQ ARG2 (THIRD FORM)) '(QUOTE NIL)); (or x nil y) ==> (or x y)     (DISCARD ARG2) (LIST* 'OR ARG1 (CDDDR FORM)))    ((AND (CONSP ARG1)  (EQ (FIRST ARG1) 'SETQ)  (NULL (CDDDR ARG1))  (ALWAYS-TRUE (THIRD ARG1))); (or (setq x t) y) ==> (setq x t)     (DISCARD-FORMS (CDDR FORM)) ARG1)    ((LET (LAST-ARG)       (AND (EQ P1VALUE 'D-INDS); result only used for nil test    (ALWAYS-TRUE (SETQ LAST-ARG (CAR (LAST FORM))))    ;; Note: a non-nil constant if present will be the last    ;;  argument because P1ANDOR will have already    ;;  discarded any arguments following it.    (NO-SIDE-EFFECTS-P FORM)    ;; (cond ((or ... t) a) ...) ==> (cond (t a) ...)    (DO ((ARGS (REST FORM) (REST ARGS)))((NULL (CDR ARGS)) LAST-ARG)      (DISCARD (FIRST ARGS))))))    ((AND (EQUAL-FORMS ARG1 ARG2)  (NO-SIDE-EFFECTS-P ARG1)); (or x x y) ==> (or x y)     (DISCARD ARG1) (LIST* (FIRST FORM) (CDDR FORM)))    (T FORM)))(ADD-POST-OPTIMIZER XOR XOR-OPT)(DEFUN XOR-OPT (FORM) ; 9/27/86 original  (LET* ((NEGATE NIL) (ARGS (LOOP FOR ARG IN (REST FORM)     IF (EQUAL ARG '(QUOTE NIL))     DO (DISCARD ARG)     ELSE IF (ALWAYS-TRUE ARG)     DO (PROGN (SETQ NEGATE (NOT NEGATE))       (DISCARD ARG))     ELSE COLLECT ARG)) (NEW-FORM (COND ((NULL ARGS)  '(QUOTE NIL)) ((NULL (REST ARGS))  (FIRST ARGS)) ((= (LENGTH ARGS) (LENGTH (REST FORM)))  FORM) (T (CONS (FIRST FORM) ARGS)))))    (IF NEGATE`(NOT ,NEW-FORM)      NEW-FORM))); Turn (PROG1 FOO NIL) into FOO since PBIND generates that and it makes better code(ADD-POST-OPTIMIZER PROG1 PROG1-OPT)(DEFUN PROG1-OPT (FORM) ;; 12/28/84 - Add use of DISCARD. ;;  9/22/96 - Fix to ensure that only a single value is produced. ;; 10/10/86 - Move constant first arg to end of a PROGN.  (COND    ((NULL (CDDR FORM)); (PROG1 x) ==> (VALUES x)     (IF (REST FORM) `(VALUES ,(SECOND FORM))       '(QUOTE NIL)))    ((NO-SIDE-EFFECTS-P (THIRD FORM)); (PROG1 x c ...) ==> (PROG1 x ...)     (DISCARD (THIRD FORM))     (LIST* 'PROG1 (SECOND FORM) (CDDDR FORM)))    ((NULL P1VALUE)     (CONS 'PROGN (REST FORM)))    ((QUOTEP (SECOND FORM)); (PROG1 c x ... z) ==> (PROGN x ... z c)     (CONS 'PROGN (APPEND (CDDR FORM) (CONS (SECOND FORM) NIL))))    (T FORM)))(ADD-POST-OPTIMIZER VALUES VALUES-OPT)(DEFUN VALUES-OPT (FORM)  ;;  9/23/86 - Original.  (COND ((AND (NULL (CDDR FORM))      (REST FORM)      (TRIVIAL-FORM-P (SECOND FORM))) ;; only one arg which can't produce multiple values (SECOND FORM))((MEMBER P1VALUE '(SINGLE-VALUE NIL D-INDS VALUE-ONLY DOWNWARD-ONLY) :TEST #'EQ) ;; only one value is being received (IF (AND (NULL (CDDR FORM))  (REST FORM))     (SECOND FORM)   (CONS 'PROG1 (CDR FORM))))(T FORM)))(ADD-POST-OPTIMIZER MULTIPLE-VALUE-PROG1 MVP1-OPT)(DEFUN MVP1-OPT (FORM)  ;; 10/10/86 - Original.  (IF (OR (TRIVIAL-FORM-P (SECOND FORM))  (MEMBER P1VALUE '(SINGLE-VALUE NIL D-INDS VALUE-ONLY DOWNWARD-ONLY) :TEST #'EQ))      (CONS 'PROG1 (REST FORM))    FORM))#-Elroy ; The PROG2 macro has been fixed in release 3(progn(ADD-OPTIMIZER PROG2 PROG2-NO-OP)(DEFUN PROG2-NO-OP (FORM)  ;;  5/12/86 - Instead of just optimizing special case of (PROG2 NIL x) ==> x,  ;;expand PROG2 into PROGN and PROG1 like the macro ought to do.  `(PROGN ,(SECOND FORM) (PROG1 . ,(CDDR FORM)))) )(ADD-POST-OPTIMIZER COND COND-OPT)(DEFUN COND-OPT (FORM) ;; 1/25/85 - Use DISCARD. ;; 1/29/85 - Use ALWAYS-TRUE; optimize SETQ as first test. ;; 3/05/85 - Optimize (IF b T NIL) ==> b ;; 8/09/86 - Use new macro BOOLEAN-FUNCTION-P.  (LET ((BODY (CDR FORM)));;  (COND)  ==>  'NIL    (IF (NULL BODY)'(QUOTE NIL)      (LET* ((CLAUSE-1 (FIRST BODY))     (TEST-1 (CAR-SAFE CLAUSE-1))     CLAUSE-2)(COND ;;  (COND ( NIL x ) ( y z ) ... ) ==> (COND ( y z ) ... ) ((EQUAL TEST-1 '(QUOTE NIL))  (DISCARD-FORMS CLAUSE-1)  (CONS 'COND (REST BODY))) ;;  (COND ( T x ) ... ) ==> x ((ALWAYS-TRUE TEST-1)  (DOLIST (CLAUSE (REST BODY))    (DISCARD-FORMS CLAUSE))  (CONS 'PROGN CLAUSE-1)) ;;  (COND ((SETQ x c) a)...) ==> (PROGN (SETQ x c) ;;                                      (COND (c a)...)) ((AND (EQ (CAR-SAFE TEST-1) 'SETQ)       (NULL (CDDDR TEST-1))       (QUOTEP (THIRD TEST-1)))  `(PROGN     ,TEST-1     ,(POST-OPTIMIZE `(COND(,(THIRD TEST-1) . ,(REST CLAUSE-1)),@(REST BODY))))) ;;  (COND (p x)(NIL y)(q z)...) ==> (COND (p x) (q z) ...) ((NULL (CDR BODY)) FORM) ((EQUAL (FIRST (SETQ CLAUSE-2 (SECOND BODY))) '(QUOTE NIL))  (DISCARD-FORMS CLAUSE-2)  (LIST* 'COND CLAUSE-1 (CDDR BODY))) ;;  (COND ( p x ) ( T x ) ... ) ==> x ((AND (ALWAYS-TRUE (FIRST CLAUSE-2))       (CONSP (CDR CLAUSE-2)))  (LET (FC1 FC2 (NDIF NIL) NOVARS)    (COND      ((EQUAL-FORMS (REST CLAUSE-1) (REST CLAUSE-2))       (DOLIST (CLAUSE (REST BODY)) (DISCARD-FORMS CLAUSE))       (CONS 'PROGN CLAUSE-1)); later, if safe, change:  (PROGN p x) ==> x      ;;  (COND ((eq x y) T) (T NIL)) ==> (eq x y)      ((AND (EQUAL (REST CLAUSE-1) '('T))    (EQUAL (REST CLAUSE-2) '('NIL))    (OR (EQ P1VALUE 'D-INDS)(AND (CONSP TEST-1)     (BOOLEAN-FUNCTION-P (FIRST TEST-1)))))       (DISCARD (CONS (FIRST FORM) (CDDR FORM)))       TEST-1)      ;;  (COND (p (f a b c)) (T (f a z c))) ==>      ;;     (f a (COND ((p b)(T z))) c)      ((AND (EQUAL-FORMS (CDDR CLAUSE-1) (CDDR CLAUSE-2))    (> (OPT-SPACE OPTIMIZE-SWITCH) 0)    (NOT (TRIVIAL-FORM-P (SETQ FC1 (SECOND CLAUSE-1))))    (NOT (TRIVIAL-FORM-P (SETQ FC2 (SECOND CLAUSE-2))))    (EQ (FIRST FC1) (FIRST FC2))   ; same function    (NOT (QUOTES-ANY-ARGS (FIRST FC1)))   ; not a special form    (= (LENGTH FC1) (LENGTH FC2))  ; same no. of args.    (LOOP NAMED SCAN-ARGS  INITIALLY (SETQ NOVARS T) ; no variable references yet  FOR A1 IN (REST FC1)  FOR A2 IN (REST FC2)  FOR N FROM 1 BY 1  WHEN (NOT (EQUAL-FORMS A1 A2))  DO (IF (NULL NDIF) (SETQ NDIF N)   ; number of arg that differs       (RETURN-FROM SCAN-ARGS NIL))  WHEN (AND (NULL NDIF) NOVARS)  DO (SETQ NOVARS (QUOTEP A1))  FINALLY (RETURN-FROM SCAN-ARGS (NOT (NULL NDIF))))    ;; only one argument is different    (OR NOVARS (NO-SIDE-EFFECTS-P (FIRST CLAUSE-1)))    ;; condition can safely be moved since it doesn't    ;;  interact with any of the leading arguments.    )       `(PROGN  (,@(FIRSTN NDIF (SECOND CLAUSE-1))   (COND     (,(FIRST CLAUSE-1) ,(NTH NDIF FC1))     (,(FIRST CLAUSE-2) ,(NTH NDIF FC2)))   . ,(NTHCDR (1+ NDIF) (SECOND CLAUSE-1)))  ,@(CDDR CLAUSE-1)))      (T FORM)))) ;;  otherwise, return original form (T FORM))))))       (ADD-POST-OPTIMIZER PROGN PROGN-OPT)(DEFUN PROGN-OPT (FORM) ;; 12/28/84 - Add use of DISCARD. ;; 10/17/86 - Return 2nd value of T when result doesn't need further optimization.  (COND    ((NULL (REST FORM)); (PROGN)   ==> 'NIL     '(QUOTE NIL))    ((NULL (CDDR FORM)); (PROGN x) ==> x     (VALUES (SECOND FORM) T))    ((NO-SIDE-EFFECTS-P (SECOND FORM)); (PROGN c x ...) ==> (PROGN x ...)     (DISCARD (SECOND FORM))     (CONS 'PROGN (CDDR FORM)))    ((ATOM (SECOND FORM)) FORM)    ((MEMBER (FIRST (SECOND FORM)); (PROGN (RETURN...)...) ==> (RETURN...)     '(RETURN-FROM GO *THROW THROW)     :TEST #'EQ)     (DISCARD-FORMS (CDDR FORM))     (VALUES (SECOND FORM) T))    (T FORM)))(ADD-POST-OPTIMIZER BLOCK BLOCK-OPT)(ADD-POST-OPTIMIZER BLOCK-FOR-PROG BLOCK-OPT)(DEFUN BLOCK-OPT (FORM) ;; the P1'd form is: (BLOCK gotags progdesc . body)  ;;  9/12/86 - Add call to DISCARD-FORMS.  ;; 10/17/86 - Return 2nd value of T when result doesn't need further optimization.  ;; 10/18/86 - Use GOTAGS-SEARCH.  (LET ((RETURN-COUNT (GOTAG-USE-COUNT (GOTAGS-SEARCH (PROGDESC-RETTAG (THIRD FORM)) T (SECOND FORM))))BF)    (COND      ((= RETURN-COUNT 0); No RETURNs so change BLOCK to PROGN.       (CONS 'PROGN (CDDDR FORM)))      ((NULL (CDDDR FORM)) '(QUOTE NIL)); empty body      ;; BF is first body form      ((NO-SIDE-EFFECTS-P (SETQ BF (FOURTH FORM)))       (IF (NULL (NTHCDR 4 FORM)); (BLOCK name c) ==> c   BF ;; (BLOCK name c x) ==> (BLOCK name x) (LIST* (FIRST FORM) (SECOND FORM) (THIRD FORM) (NTHCDR 4 FORM))))      ((AND (EQ (FIRST BF) 'RETURN-FROM)    (EQ (SECOND BF) (THIRD FORM))    (= RETURN-COUNT 1))       ;; (BLOCK name (RETURN-FROM name value)) ==> value       (DISCARD-FORMS (NTHCDR 4 FORM))       (VALUES (THIRD BF) T))      (T FORM))))(ADD-POST-OPTIMIZER THE-EXPR THE-EXPR-OPT);; (THE-EXPR expression used-var-set altered-var-set optimize-switch type)(DEFUN THE-EXPR-OPT (FORM) ;; 1/23/85 - Original version. ;; 2/19/85 - More cases for removing annotation. ;; 3/10/86 - Don't discard type information. ;; 9/19/86 - Call POST-OPTIMIZE in P1-WITH-ANNOTATION instead of here. ;;10/11/86 - Do re-optimize the arg if P1VALUE has changed. ;;10/17/86 - Return 2nd value of T when result doesn't need further optimization. ;;11/19/86 - Test OPCODE property instead of QLVAL.  (LET* ((ARG (EXPR-FORM FORM)))    (COND      ((OR (QUOTEP ARG); annotation not needed on constant   (AND (OR (TRIVIAL-FORM-P ARG)   ; annotation not needed on variable    (NOT (GET (FIRST ARG) 'P2))   ; not a special form, annotation not needed    (GET (FIRST ARG) 'OPCODE)   ; machine instruction, not worth annotating    )(LET ((TYPE (EXPR-TYPE FORM)))  (OR (EQ TYPE 'UNKNOWN)      (EQ TYPE (TYPE-OF-EXPRESSION ARG)))))   ; don't need the type   (MEMBER (CAR-SAFE ARG) '(RETURN-FROM GO *THROW THROW) :TEST #'EQ)   ;; annotation would get in way of optimization   (AND (EQ (CAR-SAFE ARG) 'THE-EXPR)(OR (EQ (EXPR-TYPE FORM) 'UNKNOWN)    (NOT (EQ (EXPR-TYPE ARG) 'UNKNOWN))))   )       (VALUES ARG T))   ; remove annotation      ((AND (SYMBOLP P1VALUE)    (NOT (EQ P1VALUE (EXPR-DEST FORM))))       (MAKE-EXPR :EXPR-FORM (POST-OPTIMIZE ARG)  :EXPR-USED (EXPR-USED FORM)  :EXPR-ALTERED (EXPR-ALTERED FORM)  :EXPR-OPTIMIZE (EXPR-OPTIMIZE FORM)  :EXPR-TYPE (EXPR-TYPE FORM)))      (T FORM))))(ADD-OPTIMIZER DOTIMES DOTIMES-OPT)(DEFUN DOTIMES-OPT (FORM)  ;; 10/15/86 DNG - Original.  (LET ((X (SECOND FORM)))    (IF (AND (CONSP X)     (SYMBOLP (FIRST X))     (<= (LENGTH X) 3)     (NOT (EQ (CAR-SAFE (SECOND X)) 'P1-HAS-BEEN-DONE)) ; not 2nd time around     (NOT (EQ P1VALUE 'TOP-LEVEL-FORM)))(LET* ((COUNT-FORM (LET ((P1VALUE 'INTEGER))     (P1 (SECOND X))))       (COUNT-VALUE (QUOTE-NUMBER COUNT-FORM)))  (IF (AND (REALP COUNT-VALUE) ; the count is a numeric constant   (< COUNT-VALUE 2)) ; will loop either 0 or 1 times      (PROGN(DISCARD COUNT-FORM)`(PROGN (AND ,(> COUNT-VALUE 0)     (PROG ((,(FIRST X) 0))       ,@(CDDR FORM)   ; body may begin with declarations       (PROGN ,(FIRST X)) ; avoid warning if not referenced      ))(LET ((,(FIRST X) ,(IF (< COUNT-VALUE 1) 0 1)))  ,(FIRST X)  ,(THIRD X))))    (LIST* (FIRST FORM)   (LIST* (FIRST X) (MARK-P1-DONE COUNT-FORM) (CDDR X))   (CDDR FORM))))      FORM)))(ADD-OPTIMIZER DOLIST DOLIST-EXPANDER)(DEFUN DOLIST-EXPANDER (FORM)  ;; 10/10/84 DNG - Fixed to evaluate the list expression outside  ;;                of the binding for the iteration variable in  ;;                case the same name is used in both.  ;;  8/15/86 DNG - Don't optimize if at top level in a file. (IF (EQ P1VALUE 'TOP-LEVEL-FORM)     ;; Don't optimize top-level form because then it couldn't be evaluated.     FORM  (LET* ((X (SECOND FORM)) (RESULT (IF (CDDR X)     `(LET ((,(FIRST X) NIL)),(FIRST X),(THIRD X))   NIL)))    (IF (OR (ATOM X)    (NULL (REST X))    (NOT (SYMBOLP (FIRST X)))   ; invalid    (> (OPT-SAFETY OPTIMIZE-SWITCH) (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)));; prefer ease of debuggingFORM   ; leave it alone      (MULTIPLE-VALUE-BIND (BODY DECLS)  (EXTRACT-DECLARATIONS-RECORD-MACROS (CDDR FORM) NIL)(LET ((LIST (GENSYM)))  `(BLOCK NIL     (LET* ((,LIST ,(SECOND X))    (,(FIRST X) (UNDEFINED-VALUE)))       (DECLARE . ,DECLS)       (%DOLIST ,(FIRST X) ,LIST (TAGBODY . ,BODY)))     ,RESULT)))))))(ADD-POST-OPTIMIZER TAGBODY TAGBODY-OPT)(ADD-POST-OPTIMIZER %DOLIST TAGBODY-OPT)(DEFUN TAGBODY-OPT (FORM) ;; FORM looks like:  (TAGBODY <local-gotags> . <body>) ;; 1/26/85 - Original version. ;; 7/08/86 - Increment EXPRESSION-SIZE when 'NIL inserted. ;;10/15/86 - Delete unreachable code following a GO or RETURN. ;;10/18/86 - GO form now has tag structure instead of name.  (WHEN (ZEROP 1-IF-LIVE-CODE)    ;; This is all dead code so don't try to optimize it.    (RETURN-FROM TAGBODY-OPT FORM))  (WHEN (AND (OR PROPAGATE-ENABLE INLINE-EXPANSIONS)     (>= (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH) (OPT-SAFETY OPTIMIZE-SWITCH))     (>= (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH) (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH)))   ;; Function P1TAGBODY has already removed variables from the set   ;;  eligible for initial value propagation as required by   ;;  assignments within the TAGBODY.  Now re-scan the body   ;;  forms to substitute values for variables where appropriate.    (SETQ FORM (PROPAGATE-VALUES FORM)))  (IF (NEQ (FIRST FORM) 'TAGBODY)      FORM    (LET ((LOCAL-GOTAGS (SECOND FORM))  (BODY (CDDR FORM))  (CHANGED NIL))      (DECLARE (LIST LOCAL-GOTAGS BODY))      (LOOP FOR G IN LOCAL-GOTAGS    WHEN (AND (ZEROP (GOTAG-USE-COUNT G))      (NOT (GOTAG-USED-IN-LEXICAL-CLOSURES-FLAG G)))    ;; delete unreferenced tag    DO (SETQ LOCAL-GOTAGS (REMOVE G (THE LIST LOCAL-GOTAGS) :TEST #'EQ :COUNT 1)     CHANGED T)    )      (DO ((FORMS BODY (CDR FORMS))   (PREV NIL)   (FALLTHRU T))  ((NULL FORMS))(COND ((ATOM (CAR FORMS))       (IF (ASSOC (CAR FORMS) LOCAL-GOTAGS :TEST #'EQL) ; referenced tag   (SETF FALLTHRU T PREV FORMS) ;; else delete unused tag (IF (NULL PREV)     (SETF BODY (CDR FORMS))   (SETF (CDR PREV) (CDR FORMS)))))      ((OR (NOT FALLTHRU) ; delete unreachable code   (NO-SIDE-EFFECTS-P (CAR FORMS)) ; or useless code   (AND (EQ (CAR-SAFE (CAR FORMS)) 'GO)(EQUAL (GOTAG-PROG-TAG (SECOND (CAR FORMS))) (SECOND FORMS))))       (DISCARD (CAR FORMS))       (SETQ CHANGED 'T)       (IF (NULL PREV)   (SETF BODY (CDR FORMS)) (SETF (CDR PREV) (CDR FORMS))))      (T (WHEN (EXPR-TYPE-P (CAR FORMS) 'NIL) ; form that never returns   (SETF FALLTHRU NIL)   (WHEN (AND (EQ FORMS BODY)      (MEMBER (FIRST (CAR FORMS)) '(RETURN-FROM THROW *THROW))      (NO-SIDE-EFFECTS-P (THIRD (CAR FORMS))))     ;; if the first body form exits the tagbody, then none of the tags are reachable.     (SETQ LOCAL-GOTAGS NIL))) (SETF PREV FORMS))))        (COND ((NULL LOCAL-GOTAGS)     ;; No referenced tags so change TAGBODY to PROGN.     (INCF EXPRESSION-SIZE 1) ; count the 'NIL form being added     `(PROG1 (QUOTE NIL) . ,BODY))    (CHANGED     (LIST* (FIRST FORM) LOCAL-GOTAGS BODY))    (T FORM)))))(DEFUN PROPAGATE-VALUES (FORM)  ;; FORM is an S-expression which has already been processed by P1.  ;; Scans the expression looking for local variable references  ;;  which can be replaced by the variable's initial value,  ;;  making the substitution in place.  Also re-optimizes any  ;;  forms whose arguments have been changed.  ;; 1/25/85 - Original version.  ;; 2/29/85 - Allow for some more special forms.  ;; 3/04/85 - Do constant folding on *PLUS etc.  ;; 3/23/85 - Fix replacement of initial value of variable.  ;; 9/28/85 - Recognize special form VARIABLE-LOCATION.  ;; 1/07/86 - Special handling for PROG1.  ;; 5/05/86 - Check (CONSP NEW-FORM) before doing (FIRST NEW-FORM) [SPR 1827];  ;;       eliminate obsolete reference to P2NODEST.  ;; 7/03/86 - Add handling for LEXICAL-CLOSURE.  ;; 8/14/86 - No longer need special handling for *PLUS, etc.  ;; 9/09/86 - Increment use count of propagated BREAKOFF-FUNCTION.  ;; 9/19/86 - Allow propagating BREAKOFF-FUNCTION; add use of  ;;DONT-PROPAGATE-INTO-LOOP; mark compilands that have only one use.  ;;10/18/86 - Don't need to bind GOTAGS anymore.  ;;11/04/86 - Fix to handle MULTIPLE-VALUE-PUSH correctly.  (DECLARE (VALUES NEW-FORM ANY-TOP-LEVEL-CHANGES?))  (DECLARE (INLINE TRIVIAL-FORM-P))  (IF (OR (ATOM FORM)  (NOT (DEBUG-ASSERT (SYMBOLP (FIRST FORM)))))      (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL))    (LET ((CHANGED NIL))      (IF (EQ (FIRST FORM) 'THE-EXPR)  (PROGN    (LET ((USED-VAR-SET (EXPR-USED FORM))  (ALTERED-VAR-SET (EXPR-ALTERED FORM))  (PROPAGATE-VAR-SET PROPAGATE-VAR-SET)  (OPTIMIZE-SWITCH (EXPR-OPTIMIZE FORM)))      (SETF (EXPR-FORM FORM) (PROPAGATE-VALUES (EXPR-FORM FORM)))      (SETF (EXPR-USED FORM) USED-VAR-SET))    (SETQ USED-VAR-SET (LOGIOR USED-VAR-SET (EXPR-USED FORM)))    (SETQ CHANGED T))(LET (ARG-LIST      (CLAUSE-LIST NIL)      (P1VALUE P1VALUE)      (P1VALUE-FIRST T)      (P1VALUE-LAST T)      (P1VALUE-MIDDLE T)      (BIND-VARS NIL)      (BIND-VALS NIL))  (SETQ ARG-LIST(COND  ((MEMBER (FIRST FORM) '(LET LET* LET-FOR-LAMBDA) :TEST #'EQ)   ;;   1      2           3       4     5      6        7       8...   ;; (LET lambda-list outer-vars vars bindp e-lex-cnt lex-cnt . body)   (LET ((VARS (FOURTH FORM)))     (SETQ BIND-VARS '(VARS)   BIND-VALS (LIST VARS))     (DOLIST (VAR (SECOND FORM))   ; each variable in lambda list       (UNLESS (ATOM VAR) (LET ((V (LOOKUP-VAR (FIRST VAR) VARS)))   (WHEN (EQ (SECOND VAR) (SECOND (VAR-INIT V)))     (MULTIPLE-VALUE-BIND (NEW-INIT CHANGED-INIT) (PROPAGATE-VALUES (SECOND VAR))       (WHEN CHANGED-INIT (SETF (SECOND VAR) NEW-INIT) (SETF (SECOND (VAR-INIT V)) NEW-INIT) (SETQ CHANGED T) (WHEN (AND (EQ (VAR-KIND V) 'FEF-ARG-INTERNAL-AUX)    (EQ (VAR-TYPE V) 'FEF-LOCAL)    (CONSP NEW-INIT)    (MEMBER (FIRST NEW-INIT)    '(QUOTE LOCAL-REF FUNCTION BREAKOFF-FUNCTION)    :TEST #'EQ)    (NOT (LOGTEST (CDDR (VAR-LAP-ADDRESS V))  ALTERED-VAR-SET))    (NOT (AND (EQ (FIRST NEW-INIT) 'LOCAL-REF)      (LOGTEST (CDDR NEW-INIT)       ALTERED-VAR-SET))))   (SETQ PROPAGATE-VAR-SET (LOGIOR PROPAGATE-VAR-SET (CDDR (VAR-LAP-ADDRESS V))))))))))))   (SETQ P1VALUE-FIRST NIL P1VALUE-MIDDLE NIL P1VALUE-LAST P1VALUE)   (NTHCDR 7 FORM))  ((ZEROP (LOGAND PROPAGATE-VAR-SET USED-VAR-SET))   ;; There aren't any variables eligible for substitution, so quit.   (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL)))  ((EQ (FIRST FORM) 'PROGN)   (SETQ P1VALUE-FIRST NIL P1VALUE-MIDDLE NIL P1VALUE-LAST P1VALUE) (REST FORM))  ((MEMBER (FIRST FORM) '(BLOCK BLOCK-FOR-PROG   BLOCK-FOR-WITH-STACK-LIST)   :TEST #'EQ)   ;;(SETQ BIND-VARS '(GOTAGS)   ;;   BIND-VALS (LIST (APPEND (SECOND FORM) GOTAGS)))   (SETQ P1VALUE-FIRST NIL P1VALUE-MIDDLE NIL P1VALUE-LAST P1VALUE) (CDDDR FORM))  ((EQ (FIRST FORM) 'MULTIPLE-VALUE-BIND)   (NTHCDR 4 FORM))  ((MEMBER (FIRST FORM)   '(PROGN-WITH-DECLARATIONS RETURN-FROM MULTIPLE-VALUE     MULTIPLE-VALUE-PUSH MULTIPLE-VALUE-SETQ CLOSURE GO)   :TEST #'EQ)   (CDDR FORM))  ((EQ (FIRST FORM) 'COND)   (SETQ CLAUSE-LIST (REST FORM))   (SETQ P1VALUE-FIRST 'D-INDS P1VALUE-MIDDLE NIL P1VALUE-LAST P1VALUE) NIL)  ((MEMBER (FIRST FORM) '(AND OR) :TEST #'EQ)   (WHEN (OR (NULL P1VALUE) (EQ P1VALUE 'D-INDS))     (SETQ P1VALUE-FIRST 'D-INDS   P1VALUE-MIDDLE 'D-INDS))   (SETQ P1VALUE-LAST P1VALUE) (REST FORM))  ((EQ (FIRST FORM) 'TAGBODY)   ;;(SETQ BIND-VARS '(GOTAGS)   ;;      BIND-VALS (LIST (APPEND (SECOND FORM) GOTAGS)))   (SETQ P1VALUE-FIRST NIL P1VALUE-MIDDLE NIL P1VALUE-LAST NIL)   (SETQ PROPAGATE-VAR-SET (LOGDIF PROPAGATE-VAR-SET   DONT-PROPAGATE-INTO-LOOP))   (CDDR FORM))  ((EQ (FIRST FORM) '%DOLIST)   (SETQ P1VALUE-FIRST NIL P1VALUE-MIDDLE NIL P1VALUE-LAST NIL)   (SETQ PROPAGATE-VAR-SET (LOGDIF PROPAGATE-VAR-SET   DONT-PROPAGATE-INTO-LOOP))   (CDDR FORM))  ((EQ (FIRST FORM) 'LOCAL-REF) (LIST FORM))  ((TRIVIAL-FORM-P FORM)   (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL)))  ((MEMBER (FIRST FORM) '(VARIABLE-LOCATION) :TEST #'EQ)   (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL)))  ((MEMBER (FIRST FORM) '(PROG1 MULTIPLE-VALUE-PROG1)   :TEST #'EQ)   (SETQ P1VALUE-FIRST P1VALUE P1VALUE-MIDDLE NIL P1VALUE-LAST NIL) (REST FORM))  ((EQ (FIRST FORM) 'LEXICAL-CLOSURE)   #|   (LET* ((COMPILAND (SECOND FORM))  (USED-VAR-SET (COMPILAND-USED-VAR-SET COMPILAND))  (ALTERED-VAR-SET (COMPILAND-ALTERED-VAR-SET COMPILAND))  (PROPAGATE-VAR-SET PROPAGATE-VAR-SET)  (OPTIMIZE-SWITCH (COMPILAND-OPTIMIZE COMPILAND)))     (SETF (COMPILAND-EXP2 COMPILAND)   (PROPAGATE-VALUES (COMPILAND-EXP2 COMPILAND)))     (SETF (COMPILAND-USED-VAR-SET COMPILAND) USED-VAR-SET))    |#   (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL)))  ((DEBUG-ASSERT     (OR (NOT (QUOTES-ANY-ARGS (FIRST FORM))) (MEMBER (FIRST FORM) '(SETQ INTERNAL-PSETQ SET-AR-1UNWIND-PROTECT *CATCH CATCH) :TEST #'EQ)))   (REST FORM))  (T (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL))) ))  (PROGV BIND-VARS BIND-VALS    (DO ((FORM-LIST (OR ARG-LIST (POP CLAUSE-LIST)) (POP CLAUSE-LIST)))((AND (NULL FORM-LIST)      (NULL CLAUSE-LIST)))      (LOOP FOR ARGS ON FORM-LIST DO    (LET ((ARG (FIRST ARGS)))      (COND((ATOM ARG))((EQ (FIRST ARG) 'LOCAL-REF) (WHEN (LOGTEST (CDDR ARG) PROPAGATE-VAR-SET)   (LET* ((V (SECOND ARG))  (NEW (OR (SECOND (VAR-INIT V))   '(QUOTE NIL))))     (SETQ CHANGED T)     (DECF (VAR-USE-COUNT V))     (DEBUG-ASSERT (>= (VAR-USE-COUNT V) 0)   ((VAR-USE-COUNT V) USED-VAR-SET)   "Negative var use count")     (WHEN (ZEROP (VAR-USE-COUNT V))   ; no more uses       (SETQ USED-VAR-SET (LOGDIF USED-VAR-SET (CDDR ARG)))       (SETQ ALTERED-VAR-SET     (LOGDIF ALTERED-VAR-SET (CDDR ARG))))     (COND ((ATOM NEW))   ((EQ (CAR NEW) 'LOCAL-REF)    (INCF (VAR-USE-COUNT (SECOND NEW)))    (SETQ USED-VAR-SET (LOGIOR USED-VAR-SET (CDDR NEW))))   ((MEMBER (CAR NEW) '(BREAKOFF-FUNCTION LEXICAL-CLOSURE))    (WHEN (AND (= (VAR-USE-COUNT V) 0)       (= (COMPILAND-USE-COUNT (SECOND NEW)) 1))      ;; flag for PROCEDURE-INTEGRATION      (SETF (GETF (COMPILAND-PLIST (SECOND NEW))  'USED-ONLY-ONCE)    T))    (INCF (COMPILAND-USE-COUNT (SECOND NEW))))   ((TRIVIAL-FORM-P NEW))   ((DEBUG-ASSERT (ZEROP (VAR-USE-COUNT V)))    ;; rather than scanning the expression incrementing    ;; the use counts for everything it references, just    ;; delete the original expression.    (SETF (SECOND (VAR-INIT V)) 'DELETED-VALUE)))     (IF (EQ ARG FORM) (RETURN-FROM PROPAGATE-VALUES (VALUES NEW T))       (SETF (FIRST ARGS) NEW)))))((TRIVIAL-FORM-P ARG))(T (SETQ P1VALUE       (COND ((NULL (REST ARGS)) P1VALUE-LAST)     ((EQ ARGS FORM-LIST) P1VALUE-FIRST)     (T P1VALUE-MIDDLE))) (MULTIPLE-VALUE-BIND (NEW-ARG WAS-CHANGED)     (PROPAGATE-VALUES ARG)   (WHEN WAS-CHANGED     (SETF (FIRST ARGS) NEW-ARG)     (SETQ CHANGED T)))))))   ; end of LOOP      )   ; end of DO    )   ; end of PROGV  )   ; end of LET on ARG-LIST and P1VALUE)   ; end of IF THE-EXPR      (IF CHANGED  (LET ((NEW-FORM (POST-OPTIMIZE FORM)))    (RETURN-FROM PROPAGATE-VALUES (VALUES NEW-FORM (NEQ NEW-FORM FORM))))(RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL)))      ); end of LET CHANGED    ); end of IF ATOM  ); end of PROPAGATE-VALUES;;;;        ==================================;;;;           Optimize equality tests;;;;        ==================================;Turn EQUAL into EQ when that is safe.;EQUAL can never be turned into = alone because = signals an error if either;arg is not a number, whereas EQUAL does not.  However, (EQUAL <fixnum> xxx);can be turned into EQ since EQ "works" for fixnums.(ADD-POST-OPTIMIZER EQUAL EQUAL-EQ)(ADD-POST-OPTIMIZER EQL EQUAL-EQ)(DEFUN EQUAL-EQ (FORM)  ;;  1/06/86 DNG - Combined optimizers for EQUAL and EQL.  ;;  7/08/86 DNG - Check for EQUAL-FORMS before EQ-COMPARABLE-P.  (COND ((/= (LENGTH FORM) 3) FORM)((AND (OR (EQ (FIRST FORM) 'EQUAL)  (TRIVIAL-FORM-P '(SECOND FORM)))      (DISCARD-EQUAL-FORMS FORM)) '(QUOTE T))((OR (EQ-COMPARABLE-P (SECOND FORM) (FIRST FORM))     (EQ-COMPARABLE-P (THIRD FORM) (FIRST FORM))) (CONS 'EQ (CDR FORM)))(T FORM)))(ADD-POST-OPTIMIZER EQL   PUT-CONST-LAST)(ADD-POST-OPTIMIZER EQUAL PUT-CONST-LAST)(DEFUN EQ-COMPARABLE-P (QUAN &OPTIONAL (TEST 'EQL))  ;; Return true if the expression QUAN is known to be of a type such that the  ;; test (TEST QUAN X) can be optimized to (EQ QUAN X).  ;; 12/20/85 DNG - Original; replaces POINTER-IDENTITY-P.  ;;  4/21/86 DNG - Make second argument optional.  ;;  7/14/86 DNG - Revised to use TYPE-OF-EXPRESSION.  (IF (QUOTEP QUAN)      (OR (AND (MEMBER (%DATA-TYPE (SECOND QUAN))       '(#.DTP-FIX #.DTP-SYMBOL #.DTP-CHARACTER #.DTP-SMALL-FLONUM)       :TEST #'EQ)       T)  (AND (EQ TEST 'EQL)       (NOT (NUMBERP (SECOND QUAN)))))    (LET (( TYPE (TYPE-OF-EXPRESSION QUAN) ))      (WHEN (EQ (CAR-SAFE TYPE) 'VALUES)(SETQ TYPE (SECOND TYPE)) )      (AND (SYMBOLP TYPE)   (NOT (MEMBER TYPE '(T UNKNOWN)))   (OR (MEMBER TYPE '(FIXNUM SYMBOL CHARACTER SHORT-FLOAT LOCATIVE T-OR-NIL))       (AND (EQ TEST 'EQL)    (SI:DISJOINT-TYPEP TYPE 'NUMBER)))   T) )))(DEFUN DISCARD-EQUAL-FORMS (FORM)  ;; If the two arguments of FORM are the same, then discard them and return T.  (IF (AND (EQUAL-FORMS (SECOND FORM) (THIRD FORM))   (NO-SIDE-EFFECTS-P (SECOND FORM))   (< (OPT-SAFETY OPTIMIZE-SWITCH) (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)))      (PROGN (DISCARD (SECOND FORM))     (DISCARD (THIRD FORM))     T)    NIL))(ADD-POST-OPTIMIZER EQ PUT-CONST-LAST)(ADD-POST-OPTIMIZER EQ EQ-OPT)(DEFUN EQ-OPT (FORM) ;;  1/06/86 DNG - Name changed from EQ-NIL to EQ-OPT. ;; 11/19/86 DNG - Test OPCODE property instead of QLVAL.  (LET ((ARG1 (SECOND FORM))(ARG2 (THIRD FORM)))    (COND      ((NULL (CDDR FORM)) FORM); 0 or 1 arg => let it get the error.      ((AND (QUOTEP ARG1) (QUOTEP ARG2))       ;; Fold constants -- no possiblity of error.       (LIST 'QUOTE (EQ (SECOND ARG1) (SECOND ARG2))))      ((EQUAL ARG2 '(QUOTE NIL)); (EQ x NIL) ==> (NOT x)       `(NOT ,ARG1))      ;; Note: (EQ (QUOTE c) x) is changed to (EQ x (QUOTE c)) by PUT-CONST-LAST      ((AND (CONSP ARG1)    (EQ (FIRST ARG1) 'FUNCTION)    (CONSP ARG2)    (<= (OPT-SAFETY OPTIMIZE-SWITCH) (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)))       (COND ((AND (EQ (FIRST ARG2) 'FUNCTION)       (EQUAL ARG1 ARG2))  ;; (EQ #'f #'f) ==> 'T  '(QUOTE T)) ((AND (MEMBER (FIRST ARG2) '(QUOTE FUNCTION) :TEST #'EQ)       (SYMBOLP (SECOND ARG1))       (SYMBOLP (SECOND ARG2))       (NEQ (SECOND ARG1) (SECOND ARG2))       (OR (AND (GET (SECOND ARG1) 'OPCODE)(OR (EQ (FIRST ARG2) 'QUOTE)    (GET (SECOND ARG2) 'OPCODE)))   (AND (EQ (SYMBOL-PACKAGE (SECOND ARG1)) SI:PKG-LISP-PACKAGE)(EQ (SYMBOL-PACKAGE (SECOND ARG2)) SI:PKG-LISP-PACKAGE)(NEQ (SYMBOL-FUNCTION (SECOND ARG1))     (SYMBOL-FUNCTION (SECOND ARG2))))))  ;; A primitive function corresponding to a machine instruction  ;;  can be assumed to have a function definition which is never  ;;  a symbol and which is different from any other primitive.  '(QUOTE NIL)) (T FORM)))      ((AND (EQUAL-FORMS ARG1 ARG2)    (TRIVIAL-FORM-P ARG1)    (<= (OPT-SAFETY OPTIMIZE-SWITCH)(OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)))       ;; (EQ x x) ==> 'T       (DISCARD ARG1) (DISCARD ARG2)       '(QUOTE T))      (T FORM))))(ADD-POST-OPTIMIZER STRING= ARITH-OPT-NON-ASSOCIATIVE)(ADD-POST-OPTIMIZER STRING-EQUAL FOLD-STRING-EQUAL)#+Elroy(ADD-POST-OPTIMIZER GLOBAL:STRING= ARITH-OPT-NON-ASSOCIATIVE)#+Elroy(ADD-POST-OPTIMIZER GLOBAL:STRING-EQUAL FOLD-STRING-EQUAL)(ADD-POST-OPTIMIZER SI:STRING-EQUAL* ARITH-OPT-NON-ASSOCIATIVE)(ADD-POST-OPTIMIZER SI:STRING=* ARITH-OPT-NON-ASSOCIATIVE)(ADD-POST-OPTIMIZER %STRING-EQUAL FOLD-STRING-EQUAL)(DEFUN FOLD-STRING-EQUAL (FORM)  (PROG (VAL)    (UNLESS (EVERY #'QUOTEP (THE LIST (REST FORM)))      (RETURN FORM))    (LET ((ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON NIL))      (SETQ VAL (FOLD-CONSTANTS FORM)))    (UNLESS (QUOTEP VAL)      (RETURN FORM))    (WHEN (NULL (SECOND VAL))      (RETURN VAL))    (LET ((ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON T))      (SETQ VAL (FOLD-CONSTANTS FORM)))    (UNLESS (QUOTEP VAL)      (RETURN FORM))    (IF (NULL (SECOND VAL))      (RETURN FORM)      (RETURN VAL))))                                                            (ADD-OPTIMIZER NULL NULL-NOT)(DEFUN NULL-NOT (FORM)  ;;  4/23/85 DNG - Don't do the transformation if the number of  ;;                arguments is wrong -- this is to facilitate  ;;                run-time error reporting.  [bug 1574]  (IF (= (LENGTH FORM) 2)      `(NOT . ,(CDR FORM))    FORM))(ADD-POST-OPTIMIZER NOT NOT-NOT)(DEFUN NOT-NOT (FORM)  ;;  8/09/86 - Use new macro BOOLEAN-FUNCTION-P.  (LET ((ARG (SECOND FORM)))    (COND      ((ATOM ARG) FORM)      ((EQ (FIRST ARG) (FIRST FORM))   ; (NOT (NOT x)) ==> x       (IF (OR (EQ P1VALUE 'D-INDS)   ; only matters whether value is nil       (EQ P1VALUE 'NIL)       (AND (CONSP (SECOND ARG))    (BOOLEAN-FUNCTION-P (FIRST (SECOND ARG))))); always T or NIL   (SECOND ARG) FORM))      ((ALWAYS-TRUE ARG) '(QUOTE NIL))   ; (NOT #'f) ==> 'NIL      (T FORM))))(DEFUN ALWAYS-TRUE (ARG)  ;; Does expression ARG have no-side-effects and always evaluate  ;; to something other than NIL?  ;; 10/13/86 DNG - Test whether the argument has a type which is disjoint from NULL.  (CASE (CAR-SAFE ARG)    (QUOTE (SECOND ARG))    (FUNCTION     (AND (SYMBOLP (SECOND ARG))  (EQ (SYMBOL-PACKAGE (SECOND ARG)) SI:PKG-LISP-PACKAGE)  (FBOUNDP (SECOND ARG))  (SYMBOL-FUNCTION (SECOND ARG))  (>= (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH) (OPT-SAFETY OPTIMIZE-SWITCH))))    ((BREAKOFF-FUNCTION LEXICAL-CLOSURE) T)    (T (AND (<= (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH)(OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))    (LET (( ARG-TYPE (TYPE-OF-EXPRESSION ARG) ))      (AND (NOT (EQ ARG-TYPE 'T))   (OR (AND (SYMBOLP ARG-TYPE)    (MEMBER ARG-TYPE    ;; the subset of INTERESTING-TYPES that are    ;; disjoint from NULL    '(FIXNUM INTEGER SHORT-FLOAT NUMBER STRING      VECTOR ARRAY CONS CHARACTER LOCATIVE STREAM)    :TEST #'EQ))       (AND (CONSP ARG-TYPE)    (MEMBER (CAR ARG-TYPE) '(ARRAY VECTOR FUNCTION INTEGER))))   (NO-SIDE-EFFECTS-P ARG)))))));;;;        ==================================;;;;           Optimize membership tests;;;;        ==================================(DEFCONSTANT TEST-MEMBER-ALIST   '((EQ . MEMQ) (EQUAL . #+Elroy SI:MEMBER-EQUAL #-Elroy GLOBAL:MEMBER)     (EQL . MEMBER-EQL) (EQUALP . MEMBER-EQUALP))   "Alist of test functions and functions which can be used to check whether any memberof a list satisfies the test. Eg (EQ . MEMQ)")(ADD-POST-OPTIMIZER MEMBER CL-MEM-OPT)(DEFUN CL-MEM-OPT (FORM)  ;; Change Common Lisp MEMBER to MEMBER-EQL etc. to avoid keyword overhead when possible.  ;; 12/29/84 - Original.  ;;  1/04/85 - Use Zetalisp MEMBER for :TEST #'EQUAL.  ;;  4/21/86 - Modified for release 3 special case functions.  ;;  8/12/86 - Remove use of MEMBER-KEY, which no longer exists.  ;; 11/18/86 CLM - Added code to generate MEMBER* for those cases not already handled by  ;;                this optimization.  (IF (> (OPT-SAFETY OPTIMIZE-SWITCH) (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))      FORM    (LET ((FORM-LENGTH (LENGTH FORM)))      (COND((= FORM-LENGTH 3)   ; (MEMBER x y) ==> (MEMBER-EQL x y) `(MEMBER-EQL . ,(REST FORM)))((OR (/= FORM-LENGTH 5)     (EQUAL (FOURTH FORM) '(QUOTE :KEY))) (GENERIC-LIST-OPT-2 FORM '(SI:MEMBER*    (:TEST-NOT :KEY :TEST)) ) )    #|((EQUAL (FOURTH FORM) '(QUOTE :KEY)) ; (MEMBER x y :KEY z) ==> (MEMBER-KEY x y z) `(,(IF (COMPILING-FOR-V2) 'SI:MEMBER-KEY 'MEMBER-EQL)   ,(SECOND FORM) ,(THIRD FORM) ,(FIFTH FORM)))    |#((EQUAL (FOURTH FORM) '(QUOTE :TEST)) (LET ( TEM )   (IF (AND (MEMBER (CAR-SAFE (FIFTH FORM)) '(QUOTE FUNCTION) :TEST #'EQ) (SETQ TEM (ASSOC (SECOND (FIFTH FORM)) TEST-MEMBER-ALIST :TEST #'EQ)))       ;; (MEMBER x y :TEST #'EQUAL) ==> (MEMBER-EQUAL x y)       (LIST (CDR TEM) (SECOND FORM) (THIRD FORM))     (IF (COMPILING-FOR-V2) ;; (MEMBER x y :TEST z) ==> (MEMBER-TEST x y z) (LIST 'SI:MEMBER-TEST (SECOND FORM) (THIRD FORM) (FIFTH FORM))       FORM ))))(T FORM)))))(ADD-POST-OPTIMIZER GLOBAL:MEMBER MEMQ-EQ)(ADD-POST-OPTIMIZER SI:MEMBER-EQUAL MEMQ-EQ)(ADD-POST-OPTIMIZER MEMBER-EQUALP MEMQ-EQ)(ADD-POST-OPTIMIZER MEMBER-EQL MEMQ-EQ)(ADD-POST-OPTIMIZER MEMQ MEMQ-EQ)(DEFUN MEMQ-EQ (FORM)  ;;  4/21/86 - Call POST-OPTIMIZE on the new test form.  (OR (WHEN (= (LENGTH FORM) 3)(LET ((ITEM (CADR FORM))      (LIST (CADDR FORM)))  (WHEN (QUOTEP LIST)    (CASE (LENGTH (CADR LIST))       (0 `(PROGN ,ITEM  (QUOTE NIL)))       (1 `(AND ,(POST-OPTIMIZE `(,(CAR (RASSOC (CAR FORM)TEST-MEMBER-ALIST:TEST #'EQ))  ,ITEM ',(CAR (CADR LIST))))',(CADR LIST)))))))      FORM))(ADD-POST-OPTIMIZER MEMBER-EQL   MEMBER-EQL-MEMQ)(ADD-POST-OPTIMIZER SI:POSITION* MEMBER-EQL-MEMQ)(DEFUN MEMBER-EQL-MEMQ (FORM)  ;; 12/20/85 - Use EQ-COMPARABLE-P.  ;; 11/21/86 - Use this function for optimizing POSITION* also.  ;; 12/03/86 - Fix to not optimize POSITION* when second arg is not a list.  (OR (WHEN (= (LENGTH FORM) 3)(LET ((ITEM (CADR FORM))      (LIST (CADDR FORM)))  (WHEN (OR (AND (EQ (FIRST FORM) 'MEMBER-EQL) (EQ-COMPARABLE-P ITEM 'EQL))    (AND (QUOTEP LIST) (CONSP (CADR LIST)) (LOOP FOR X IN (CADR LIST)       ALWAYS (TYPEP X '(OR (NOT NUMBER) FIXNUM SHORT-FLOAT)))))    (LIST (IF (EQ (FIRST FORM) 'SI:POSITION*) 'FIND-POSITION-IN-LIST 'MEMQ)  ITEM  LIST))))      FORM))(ADD-POST-OPTIMIZER GLOBAL:MEMBER   MEMBER-MEMQ)(ADD-POST-OPTIMIZER SI:MEMBER-EQUAL MEMBER-MEMQ)(DEFUN MEMBER-MEMQ (FORM)  ;; 12/20/85 - Original.  (OR (WHEN (= (LENGTH FORM) 3)(LET ((ITEM (CADR FORM))      (LIST (CADDR FORM)))  (WHEN (OR (EQ-COMPARABLE-P ITEM 'EQUAL)    (AND (QUOTEP LIST) (CONSP (CADR LIST)) (LOOP FOR X IN (CADR LIST)       ALWAYS         (MEMBER (%DATA-TYPE X) '(#.DTP-FIX #.DTP-SYMBOL   #.DTP-CHARACTER #.DTP-SMALL-FLONUM) :TEST #'EQ))))    `(MEMQ ,ITEM ,LIST))))      FORM))(ADD-POST-OPTIMIZER ASSOC ASSOC-OPT)(DEFUN ASSOC-OPT (FORM)  ;; Change Common Lisp ASSOC to more specific functions.  ;;  4/21/86 - Original.  ;; 11/21/86 - Use ASSQ for constant list with fixnum or non-numeric keys.  (IF (> (OPT-SAFETY OPTIMIZE-SWITCH) (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))      FORM    (LET ((FORM-LENGTH (LENGTH FORM)))      (COND((AND (= FORM-LENGTH 3)   ; (ASSOC x y) ==> (ASSOC-EQL x y)      (COMPILING-FOR-V2)) (LET ( TEM )   (IF (AND (QUOTEP (THIRD FORM))    (CONSP (SETQ TEM (SECOND (THIRD FORM))))    (LOOP FOR X IN TEM  ALWAYS (TYPEP (CAR-SAFE X) '(OR (NOT NUMBER) FIXNUM SHORT-FLOAT))))       `(ASSQ . ,(REST FORM))     `(SI:ASSOC-EQL . ,(REST FORM)))))((/= FORM-LENGTH 5) FORM)((EQUAL (FOURTH FORM) '(QUOTE :TEST)) (LET ( TEM )   (IF (AND (MEMBER (CAR-SAFE (FIFTH FORM)) '(QUOTE FUNCTION) :TEST #'EQ) (SETQ TEM (ASSOC (SECOND (FIFTH FORM))  '((EQ . ASSQ)    (EQUAL . #+Elroy SI:ASSOC-EQUAL #-Elroy GLOBAL:ASSOC)    (EQL . SI:ASSOC-EQL)    (EQUALP . SI:ASSOC-EQUALP))  :TEST #'EQ)))       ;; (ASSOC x y :TEST #'EQUAL) ==> (ASSOC-EQUAL x y)       (LIST (CDR TEM) (SECOND FORM) (THIRD FORM))     (IF (COMPILING-FOR-V2) ;; (ASSOC x y :TEST z) ==> (ASSOC-TEST x y z) (LIST 'SI:ASSOC-TEST (SECOND FORM) (THIRD FORM) (FIFTH FORM))       FORM ))))((AND (EQUAL (FOURTH FORM) '(QUOTE :TEST-NOT))      (COMPILING-FOR-V2)) (LIST 'SI:ASSOC-TESTNOT (SECOND FORM) (THIRD FORM) (FIFTH FORM)))(T FORM)))))(ADD-POST-OPTIMIZER RASSOC RASSOC-OPT)(DEFUN RASSOC-OPT (FORM)  ;; Change Common Lisp RASSOC to more specific functions.  ;;  4/21/86 - Original.  (IF (> (OPT-SAFETY OPTIMIZE-SWITCH) (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))      FORM    (LET ((FORM-LENGTH (LENGTH FORM)))      (COND((AND (= FORM-LENGTH 3)   ; (RASSOC x y) ==> (RASSOC-EQL x y)      (COMPILING-FOR-V2)) `(SI:RASSOC-EQL . ,(REST FORM)))((/= FORM-LENGTH 5) FORM)((EQUAL (FOURTH FORM) '(QUOTE :TEST)) (LET ( TEM )   (IF (AND (MEMBER (CAR-SAFE (FIFTH FORM)) '(QUOTE FUNCTION) :TEST #'EQ) (SETQ TEM (ASSOC (SECOND (FIFTH FORM))  '((EQ . RASSQ)    (EQUAL . #+Elroy SI:RASSOC-EQUAL #-Elroy GLOBAL:RASSOC)    (EQL . SI:RASSOC-EQL)    (EQUALP . SI:RASSOC-EQUALP))  :TEST #'EQ)))       ;; (RASSOC x y :TEST #'EQUAL) ==> (RASSOC-EQUAL x y)       (LIST (CDR TEM) (SECOND FORM) (THIRD FORM))     (IF (COMPILING-FOR-V2) ;; (RASSOC x y :TEST z) ==> (RASSOC-TEST x y z) (LIST 'SI:RASSOC-TEST (SECOND FORM) (THIRD FORM) (FIFTH FORM))       FORM ))))((AND (EQUAL (FOURTH FORM) '(QUOTE :TEST-NOT))      (COMPILING-FOR-V2)) (LIST 'SI:RASSOC-TESTNOT (SECOND FORM) (THIRD FORM) (FIFTH FORM)))(T FORM)))))(ADD-POST-OPTIMIZER ASSQSEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER RASSQSEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER ASSOCSEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER SI:ASSOC-EQL SEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER SI:ASSOC-EQUAL SEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER SI:ASSOC-EQUALP SEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER GLOBAL:ASSOC SEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER ASSOC-IFSEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER ASSOC-IF-NOT SEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER RASSOCSEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER SI:RASSOC-EQL SEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER SI:RASSOC-EQUAL SEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER SI:RASSOC-EQUALP SEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER GLOBAL:RASSOC SEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER RASSOC-IFSEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER RASSOC-IF-NOT SEARCH-EMPTY-LIST)(ADD-POST-OPTIMIZER SI:POSITION* SEARCH-EMPTY-LIST) ; added 11/21/86(ADD-POST-OPTIMIZER SI:FIND-LIST SEARCH-EMPTY-LIST) ; added 11/21/86(DEFUN SEARCH-EMPTY-LIST (FORM)  ;;     (ASSOC x 'NIL) ==> 'NIL  ;;  1/14/86 DNG - Original.  (IF (AND (EQUAL (THIRD FORM) '(QUOTE NIL))   (NULL (CDDDR FORM)))      (CONS 'PROGN (REST FORM)) ; in case 1st arg has side-effects    FORM));;;;        ==================================;;;;           Optimize type tests;;;;        ==================================;;; Open coding of TYPEP and COERCE.  Optimizers defined in SYS: SYS; TYPES.(ADD-OPTIMIZER TYPEP SI::TYPEP-TWO-ARGS SI:TYPEP-STRUCTURE SI:TYPEP-FLAVOR   SUBINSTANCE-OF-CLASS-SYMBOL-P)#-Elroy(WHEN-SUPPORTING-CROSS-COMPILATION ; temporary so optimizer in COLD file is done first  (WHEN (EQUAL (GET 'TYPEP 'OPTIMIZERS) '(SI::TYPEP-TWO-ARGS DEFTYPE-LOAD))    (SETF (GET 'TYPEP 'OPTIMIZERS) '(DEFTYPE-LOAD SI::TYPEP-TWO-ARGS))))(ADD-OPTIMIZER COERCE SI::COERCE-OPTIMIZER SI::COERCE-TO-ARRAY-OPTIMIZED              SI::COERCE-TO-CHARACTER SI::COERCE-TO-LIST)(DEFUN FOLD-TYPE-PREDICATE (FORM TEST-TYPE)  ;; FORM is a call to a predicate which tests for TEST-TYPE.  ;;  5/12/86 DNG - Original.  (DECLARE (INLINE QUOTEP))  (COND ((CDDR FORM) FORM); too many arguments((QUOTEP (SECOND FORM)); argument is a constant (FOLD-CONSTANTS FORM))((> (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH)    (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)) FORM)(T (LET (( ARG-TYPE (TYPE-OF-EXPRESSION (SECOND FORM)) ))     (COND ((MEMBER ARG-TYPE '(T UNKNOWN) :TEST #'EQ)    FORM)   ((OR (EQ ARG-TYPE TEST-TYPE)(SUBTYPEP ARG-TYPE TEST-TYPE)) ; test passes    `(PROGN ,(SECOND FORM) 'T))   ((SI:DISJOINT-TYPEP ARG-TYPE TEST-TYPE) ; test fails    `(PROGN ,(SECOND FORM) 'NIL))   (T FORM) )))));;;;        ==================================;;;;           Array optimizations;;;;        ==================================(ADD-POST-OPTIMIZER MAKE-ARRAY TRY-TO-USE-SIMPLE-MAKE-ARRAY SI:SIMPLE-MAKE-ARRAY)(DEFUN TRY-TO-USE-SIMPLE-MAKE-ARRAY (FORM)  ;;  9/27/86 DNG - Changed from a pre-optimizer to a post-optimizer.  ;; 10/14/86 DNG - Add handling for :LEADER-LIST option.  ;; 11/21/86 DNG - Convert array type symbol to its corresponding number.  ;; 11/22/86 DNG - Use SI:INTERNAL-MAKE-SIMPLE-VECTOR when appropriate.  (LET ((LEN (LENGTH FORM)))    (WHEN (OR (< LEN 2) (ODDP LEN))      (RETURN-FROM TRY-TO-USE-SIMPLE-MAKE-ARRAY FORM)))  (LET ((DIMENSIONS-FORM (SECOND FORM))(INITIAL-VALUE-FORM '(QUOTE NIL))(INITIAL-VALUE-SPECIFIED NIL)(AREA-FORM '(QUOTE NIL))(TYPE-FORM '(QUOTE ART-Q))(LEADER-LENGTH-FORM '(QUOTE NIL))(FILL-POINTER-FORM '(QUOTE NIL))(FILL-POINTER-SPECIFIED NIL)(NAMED-STRUCTURE-SYMBOL-FORM '(QUOTE NIL))(NAMED-STRUCTURE-SYMBOL-SPECIFIED  NIL)(OUT-OF-ORDER NIL))    (LOOP FOR (KEYWORD-FORM ARGUMENT-FORM) ON (CDDR FORM) BY #'CDDR DO      (IF (NOT (QUOTEP KEYWORD-FORM))  (RETURN-FROM TRY-TO-USE-SIMPLE-MAKE-ARRAY FORM)(CASE (SECOND KEYWORD-FORM)  ((:TYPE :ELEMENT-TYPE)   (IF (EQ (SECOND KEYWORD-FORM) ':ELEMENT-TYPE)       (SETQ TYPE-FORM     (POST-OPTIMIZE `(SI:ARRAY-TYPE-FROM-ELEMENT-TYPE ,ARGUMENT-FORM)))     (SETQ TYPE-FORM ARGUMENT-FORM))   (UNLESS (AND (INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM AREA-FORM)(INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM LEADER-LENGTH-FORM)(INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM INITIAL-VALUE-FORM)(INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM FILL-POINTER-FORM)(INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM NAMED-STRUCTURE-SYMBOL-FORM))     (SETQ OUT-OF-ORDER T)))  (:AREA   (SETQ AREA-FORM ARGUMENT-FORM)   (UNLESS (AND (INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM LEADER-LENGTH-FORM)(INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM INITIAL-VALUE-FORM)(INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM FILL-POINTER-FORM)(INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM NAMED-STRUCTURE-SYMBOL-FORM))     (SETQ OUT-OF-ORDER T)))  (:LEADER-LENGTH   (SETQ LEADER-LENGTH-FORM ARGUMENT-FORM)   (UNLESS (AND (INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM INITIAL-VALUE-FORM)(INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM FILL-POINTER-FORM)(INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM NAMED-STRUCTURE-SYMBOL-FORM))     (SETQ OUT-OF-ORDER T)))  ((:INITIAL-VALUE :INITIAL-ELEMENT)   (SETQ INITIAL-VALUE-FORM ARGUMENT-FORM INITIAL-VALUE-SPECIFIED T)   (UNLESS (AND (INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM FILL-POINTER-FORM)(INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM NAMED-STRUCTURE-SYMBOL-FORM))     (SETQ OUT-OF-ORDER T)))  (:FILL-POINTER   (SETQ FILL-POINTER-FORM ARGUMENT-FORM FILL-POINTER-SPECIFIED T)   (UNLESS (INDEPENDENT-EXPRESSIONS-P ARGUMENT-FORM NAMED-STRUCTURE-SYMBOL-FORM)     (SETQ OUT-OF-ORDER T)))  (:LEADER-LIST   (IF (AND (QUOTEP ARGUMENT-FORM)    (CONSP (SECOND ARGUMENT-FORM))    (= (LENGTH (SECOND ARGUMENT-FORM)) 1)    (NOT FILL-POINTER-SPECIFIED))       (SETQ FILL-POINTER-FORM `(QUOTE ,(FIRST (SECOND ARGUMENT-FORM)))     FILL-POINTER-SPECIFIED T)     (RETURN-FROM TRY-TO-USE-SIMPLE-MAKE-ARRAY FORM)))  (:NAMED-STRUCTURE-SYMBOL   (SETQ NAMED-STRUCTURE-SYMBOL-FORM ARGUMENT-FORM NAMED-STRUCTURE-SYMBOL-SPECIFIED T))  (OTHERWISE (RETURN-FROM TRY-TO-USE-SIMPLE-MAKE-ARRAY FORM)))))    (IF OUT-OF-ORDER;; Don't optimize if it means exchanging two subforms;; which could affect each other.FORM      (LET ( STARTFORM )(WHEN FILL-POINTER-SPECIFIED  (SETQ LEADER-LENGTH-FORM (IF (EQUAL LEADER-LENGTH-FORM '(QUOTE NIL))       '(QUOTE 1)     (POST-OPTIMIZE `(MAX '1 ,LEADER-LENGTH-FORM)))))(WHEN (AND (QUOTEP TYPE-FORM)   (>= (OPT-SPEED OPTIMIZE-SWITCH) (OPT-SAFETY OPTIMIZE-SWITCH))   (EQ TARGET-PROCESSOR HOST-PROCESSOR))  ;; convert array type symbol to the corresponding number  (LET ((NUM (FOLD-CONSTANTS `(SI:COMPUTE-LISPM-ARRAY-TYPE ,TYPE-FORM))))    (WHEN (QUOTEP NUM) ;unless error       (SETQ TYPE-FORM NUM))))(WHEN (QUOTEP DIMENSIONS-FORM)  (LET ((DIM (SECOND DIMENSIONS-FORM)))    (WHEN (AND (CONSP DIM)       (NULL (CDR DIM))       (FIXNUMP (CAR DIM)))      (SETQ DIMENSIONS-FORM `(QUOTE ,(CAR DIM))))))(SETQ STARTFORM      (COND(INITIAL-VALUE-SPECIFIED `(SI:SIMPLE-MAKE-ARRAY ,DIMENSIONS-FORM ,TYPE-FORM ,AREA-FORM,LEADER-LENGTH-FORM ,INITIAL-VALUE-FORM))((AND (COMPILING-FOR-V2)      (SI:SIMPLE-VECTOR-SIZE-P (QUOTE-NUMBER DIMENSIONS-FORM))      (INDEPENDENT-EXPRESSIONS-P AREA-FORM LEADER-LENGTH-FORM)) (COND ((NOT (EQUAL AREA-FORM '(QUOTE NIL)))`(SI:INTERNAL-MAKE-SIMPLE-VECTOR ,DIMENSIONS-FORM ,TYPE-FORM ,LEADER-LENGTH-FORM ,AREA-FORM))       ((NOT (EQUAL LEADER-LENGTH-FORM '(QUOTE NIL)))`(SI:INTERNAL-MAKE-SIMPLE-VECTOR ,DIMENSIONS-FORM ,TYPE-FORM ,LEADER-LENGTH-FORM))       (T `(SI:INTERNAL-MAKE-SIMPLE-VECTOR ,DIMENSIONS-FORM ,TYPE-FORM))))((NOT (EQUAL LEADER-LENGTH-FORM '(QUOTE NIL))) `(SI:SIMPLE-MAKE-ARRAY ,DIMENSIONS-FORM ,TYPE-FORM ,AREA-FORM,LEADER-LENGTH-FORM))((NOT (EQUAL AREA-FORM '(QUOTE NIL))) `(SI:SIMPLE-MAKE-ARRAY ,DIMENSIONS-FORM ,TYPE-FORM ,AREA-FORM))(T `(SI:SIMPLE-MAKE-ARRAY ,DIMENSIONS-FORM ,TYPE-FORM))))(IF (OR FILL-POINTER-SPECIFIED NAMED-STRUCTURE-SYMBOL-SPECIFIED)    (LET ((ARRAY-VAR (GENSYM)))      (P1 `(LET ((,ARRAY-VAR ,(MARK-P1-DONE STARTFORM)) (FILL-POINTER ,(MARK-P1-DONE FILL-POINTER-FORM)) (NAMED-STRUCTURE-SYMBOL ,(MARK-P1-DONE NAMED-STRUCTURE-SYMBOL-FORM)))     (DECLARE (ARRAY ,ARRAY-VAR))     (AND ,FILL-POINTER-SPECIFIED       (SETF (FILL-POINTER ,ARRAY-VAR)     FILL-POINTER))     (AND ,NAMED-STRUCTURE-SYMBOL-SPECIFIED       (MAKE-ARRAY-INTO-NAMED-STRUCTURE ,ARRAY-VAR NAMED-STRUCTURE-SYMBOL))     ,ARRAY-VAR)))  STARTFORM)))))(ADD-POST-OPTIMIZER SI::ARRAY-TYPE-FROM-ELEMENT-TYPE ARRAY-TYPE-OPT)(ADD-POST-OPTIMIZER SI::TYPE-CANONICALIZE  ARRAY-TYPE-OPT)(DEFUN ARRAY-TYPE-OPT (FORM &AUX ARG)  ;; 01/14/86 DNG - Original.  [fold standard types only]  ;; 08/29/86 DNG - Use new function TYPE-SPECIFIER-P to enable folding user-defined types.  ;; 10/15/86 DNG - Fold (ARRAY-TYPE-FROM-ELEMENT-TYPE '*) ==> ART-Q  (IF (AND (NULL (CDDR FORM))   ; not more than 1 argument   (QUOTEP (SETQ ARG (SECOND FORM)))   (OR (SI:TYPE-SPECIFIER-P (SECOND ARG))       (AND (EQ (FIRST FORM) 'SI::ARRAY-TYPE-FROM-ELEMENT-TYPE)    (EQ (SECOND ARG) '*))))      (FOLD-CONSTANTS FORM)    FORM))(ADD-POST-OPTIMIZER MAKE-STRING MAKE-STRING-SIMPLE-MAKE-ARRAY SI:SIMPLE-MAKE-ARRAY)(DEFUN MAKE-STRING-SIMPLE-MAKE-ARRAY (FORM)  ;;  9/27/86 DNG - Changed from a pre-optimizer to a post-optimizer.  (LET* ((LOSS `(MAKE-ARRAY ,(CADR FORM) :TYPE ART-STRING ,@(CDDR FORM))) (LOSER (TRY-TO-USE-SIMPLE-MAKE-ARRAY LOSS)))    (IF (EQ LOSS LOSER)FORM      LOSER)))(ADD-OPTIMIZER GLOBAL:AREF AREF-EXPANDER)(DEFUN AREF-EXPANDER (FORM)  (CASE (LENGTH FORM)    (3 (CONS 'GLOBAL:AR-1 (CDR FORM)))    (4 (CONS 'AR-2   (CDR FORM)))    (5 (CONS 'AR-3   (CDR FORM)))    (T FORM)))(ADD-OPTIMIZER COMMON-LISP-AREF COMMON-LISP-AREF-EXPANDER)(ADD-OPTIMIZER AREF COMMON-LISP-AREF-EXPANDER)(DEFUN COMMON-LISP-AREF-EXPANDER (FORM)  ;;  4/26/85 - Modified to use new Explorer instructions COMMON-LISP-AR-2  ;;            and COMMON-LISP-AR-3. This assumes microcode version 186 or later.  ;;            [ref bug report 1136]  ;; Note: The Common Lisp array accessors differ from the Zetalisp versions  ;;       only in that elements of an ART-STRING are returned as character  ;;       objects instead of fixnums.  The Lambda instructions AR-2 and AR-3  ;;       are actually the same as the Explorer COMMON-LISP-AR-2 and -3, which  ;;       means that 2 or 3 dimensional ART-STRING arrays in Zetalisp mode  ;;       return characters instead of fixnums on a Lambda.  (But there is no  ;;       reason for Zetalisp to use multidimensional ART-STRING anyway --  ;;       just use ART-8B.)  (LET ((NEW-FN  (CASE (LENGTH FORM)    (3 'COMMON-LISP-AR-1)    (4 (IF (COMPILING-FOR-EXPLORER-P)   'COMMON-LISP-AR-2 'AR-2))    (5 (IF (COMPILING-FOR-EXPLORER-P)   'COMMON-LISP-AR-3 'AR-3))    (T 'COMMON-LISP-AREF))))    (IF (EQ NEW-FN (FIRST FORM))FORM      (CONS NEW-FN (REST FORM)))))(ADD-OPTIMIZER ASET ASET-EXPANDER)(DEFUN ASET-EXPANDER (FORM)  (CASE (LENGTH FORM)    (4 (CONS 'AS-1 (CDR FORM)))    (5 (CONS 'AS-2 (CDR FORM)))    (6 (CONS 'AS-3 (CDR FORM)))    (T FORM)))(ADD-OPTIMIZER SET-AREF SET-AREF-EXPANDER)(DEFUN SET-AREF-EXPANDER (FORM)  (CASE (LENGTH FORM)    (4 (CONS 'SET-AR-1 (CDR FORM)))    (5 (CONS 'SET-AR-2 (CDR FORM)))    (6 (CONS 'SET-AR-3 (CDR FORM)))    (T FORM)))(ADD-OPTIMIZER ALOC ALOC-EXPANDER)(DEFUN ALOC-EXPANDER (FORM)  (CASE (LENGTH FORM)    (3 (CONS 'AP-1 (CDR FORM)))    (4 (CONS 'AP-2 (CDR FORM)))    (5 (CONS 'AP-3 (CDR FORM)))    (T FORM)))(ADD-POST-OPTIMIZER AS-1 STORE-TO-SET)(ADD-POST-OPTIMIZER STORE-ARRAY-LEADER STORE-TO-SET)(ADD-POST-OPTIMIZER %INSTANCE-SET STORE-TO-SET)(DEFUN STORE-TO-SET (FORM);   (operation value array index)  ;; Change AS-1 to SET-AR-1 to enable use of AREFI instruction  ;; for constant index.  ;;  8/19/85 - Original.  (LET ((ARGL (CDR FORM)))    (IF (AND (= (LENGTH ARGL) 3)     (QUOTEP (THIRD ARGL))   ; constant index      (INDEPENDENT-EXPRESSIONS-P (FIRST ARGL) (SECOND ARGL)));; safe to change evaluation order(LIST (CDR (ASSOC (FIRST FORM)  '((AS-1 . SET-AR-1)    (STORE-ARRAY-LEADER . SET-ARRAY-LEADER)    (%INSTANCE-SET . %SET-INSTANCE-REF))  :TEST #'EQ))      (SECOND ARGL)   ; array      (THIRD ARGL)   ; index      (FIRST ARGL))   ; value      FORM)));;;;        ==================================;;;;           Optimize string functions;;;;        ==================================(ADD-POST-OPTIMIZER STRING-SEARCH STRING-SEARCH-STRING-SEARCH-CHAR STRING-SEARCH-CHAR)(ADD-POST-OPTIMIZER SI:SEARCH*-STRING-NOCASE STRING-SEARCH-STRING-SEARCH-CHAR)(ADD-POST-OPTIMIZER SI:SEARCH*-STRING-CASE STRING-SEARCH-STRING-SEARCH-CHAR)(DEFUN STRING-SEARCH-STRING-SEARCH-CHAR (FORM)  ;;  5/02/86 - Changed from pre to post optimizer and updated.  ;;  6/05/86 - Eliminated use of obsolete function STRING-LENGTH.  ;;  2/23/87 - Fixed to not call STRING-SEARCH-CHAR with too many arguments.  ;;  2/26/87 - Modify to use for SI:SEARCH*-STRING-CASE and SI:SEARCH*-STRING-NOCASE.  (LET* ((KEY-ARG (SECOND FORM)) KEY-VALUE (CHAR-ARG   (COND ((AND (QUOTEP KEY-ARG)       (PROGN (SETQ KEY-VALUE (SECOND KEY-ARG))      (OR (AND (OR (STRINGP KEY-VALUE)   (SYMBOLP KEY-VALUE))       (= (LENGTH (STRING KEY-VALUE)) 1))  (AND (FIXNUMP KEY-VALUE)       (<= 0 KEY-VALUE 255)))))  `(QUOTE ,(CHARACTER KEY-VALUE))) ((EXPR-TYPE-P KEY-ARG 'CHARACTER)  KEY-ARG) (T (RETURN-FROM STRING-SEARCH-STRING-SEARCH-CHAR FORM)))) (LEN (LENGTH FORM)))    (COND ((AND (<= LEN 5)(NOT (EQ (FIRST FORM) 'SI:SEARCH*-STRING-CASE)))   `(STRING-SEARCH-CHAR ,CHAR-ARG . ,(CDDR FORM)))  ((AND (> LEN 5)(OR (NOT (EQUAL (SIXTH FORM) '(QUOTE 0))); KEY-FROM    (AND (> LEN 6) (NOT (EQUAL (SEVENTH FORM) '(QUOTE NIL)))))); KEY-TO   FORM)  (T `(STRING-SEARCH-CHAR ,CHAR-ARG; CHAR  ,(THIRD FORM); STRING  ,(OR (FOURTH FORM) '(QUOTE 0)); FROM  ,(OR (FIFTH FORM) '(QUOTE NIL)); TO  . ,(IF (EQ (FIRST FORM) 'SI:SEARCH*-STRING-CASE) '((QUOTE T))       (NTHCDR 7 FORM)); CONSIDER-CASE  )))))(ADD-POST-OPTIMIZER STRING-SEARCH  COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER STRING-REVERSE-SEARCH COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER STRING-EQUAL COERCES-ARG-1-TO-STRING)#+Elroy(ADD-POST-OPTIMIZER GLOBAL:STRING-EQUAL COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER STRING= COERCES-ARG-1-TO-STRING)#+Elroy(ADD-POST-OPTIMIZER GLOBAL:STRING= COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER SI:STRING-EQUAL* COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER SI:STRING=*  COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER STRING< COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER STRING> COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER STRING<= COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER STRING>= COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER STRING/= COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER STRING-LESSP COERCES-ARG-1-TO-STRING)(ADD-POST-OPTIMIZER STRING-GREATERP COERCES-ARG-1-TO-STRING);; These functions include a coercion of their first argument to a string,;; so (STRING-SEARCH (STRING x) ...) ==> (STRING-SEARCH x ...);; [The former form can result from optimization of a POSITION or SEARCH call.](DEFUN COERCES-ARG-1-TO-STRING ( FORM )  (LET (( ARG1 (SECOND FORM) ))    (IF (AND (CONSP ARG1)     (EQ (FIRST ARG1) 'STRING)     (= (LENGTH ARG1) 2))(LIST* (FIRST FORM) (SECOND ARG1) (CDDR FORM))      FORM)))(ADD-POST-OPTIMIZER STRING-SEARCHCOERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING-REVERSE-SEARCHCOERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING-SEARCH-CHARCOERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING-SEARCH-NOT-CHARCOERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING-REVERSE-SEARCH-CHARCOERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING-REVERSE-SEARCH-NOT-CHAR COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING-EQUAL COERCES-ARG-2-TO-STRING)#+Elroy(ADD-POST-OPTIMIZER GLOBAL:STRING-EQUAL COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING= COERCES-ARG-2-TO-STRING)#+Elroy(ADD-POST-OPTIMIZER GLOBAL:STRING= COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER SI:STRING-EQUAL* COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER SI:STRING=*  COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING< COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING> COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING<= COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING>= COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING/= COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING-LESSP COERCES-ARG-2-TO-STRING)(ADD-POST-OPTIMIZER STRING-GREATERP COERCES-ARG-2-TO-STRING);; (STRING-SEARCH x (STRING y) ...) ==> (STRING-SEARCH x y ...)(DEFUN COERCES-ARG-2-TO-STRING ( FORM )  (LET (( ARG2 (THIRD FORM) ))    (IF (AND (CONSP ARG2)     (EQ (FIRST ARG2) 'STRING)     (= (LENGTH ARG2) 2))(LIST* (FIRST FORM) (SECOND FORM) (SECOND ARG2) (CDDDR FORM))      FORM)));;;;        ==================================;;;;         Optimize variable binding forms;;;;        ==================================(ADD-POST-OPTIMIZER LET LET-OPT)(ADD-POST-OPTIMIZER LET* LET-OPT)(ADD-POST-OPTIMIZER LET-FOR-LAMBDA LET-OPT);;   1        2           3       4     5      6        7       8...;; (LET   lambda-list outer-vars vars bindp e-lex-cnt lex-cnt . body)(DEFUN LET-OPT (FORM &OPTIONAL DELETE-ALL) ;; 1/25/85 DNG - Call DISCARD on initial value of deleted variable. ;; 2/27/85 DNG - Fix for duplicated variable names. ;; 3/04/85 DNG - Move check for special variables referenced by the ;;               microcode from here to VARS-USED. ;; 1/09/86 DNG - Fix handling of doubly-defined variables. [SPR 1518] ;; 1/20/86 DNG - Another fix for handling of doubly-defined variables. ;; 9/16/86 DNG - Permit deleting variable initialized to (UNDEFINED-VALUE). ;; 9/25/86 DNG - Optimize out some variables which are used only once. ;;10/02/86 DNG - Don't call DISCARD on a value deleted by PROPAGATE-VALUES. ;;10/14/86 DNG - Optimize binding of *STANDARD-OUTPUT* around print functions. ;;10/18/86 DNG - Handle more cases of variables used once. ;;10/21/86 DNG - Fix for variable used once that depends on special variable bindings.  (DECLARE (SPECIAL PROPAGATE-ENABLE))  (UNLESS PROPAGATE-ENABLE    (RETURN-FROM LET-OPT FORM))  (LET ((VARS (FOURTH FORM))(VLIST (SECOND FORM))(CHANGED NIL)VUSED(BODY (NTHCDR 7 FORM))(NNEWVARS 0)(NEW-PROPAGATE 0))    (DO ((VS VARS) (VL VLIST (CDR VL)))((NULL VL))      (LOOP DO (SETQ V (FIRST VS)     VS (REST VS)     NNEWVARS (1+ NNEWVARS))    UNTIL (NEQ (VAR-KIND V) 'FEF-ARG-DELETED)))    (FLET ((USES-SPECIAL-BINDINGS-P (V OLD-VARS)     ;; Does the initial value of this variable use any special variables     ;; which are bound in this same LET?     (VARS-USED (SECOND (VAR-INIT V))(LET ((SPECIALS NIL))  (DO ((VS VARS (CDR VS)))      ((EQ VS OLD-VARS))    (WHEN (EQ (VAR-TYPE (CAR VS)) 'FEF-SPECIAL)      (PUSH (VAR-LAP-ADDRESS (CAR VS))    SPECIALS)))  SPECIALS)) ))    ;; delete unused variables from the lambda list    (SETQ VLIST      (LOOPFOR VLIST-TAIL ON VLISTFOR VAR = (FIRST VLIST-TAIL) ; each variable in lambda listDO(LOOP DO (SETQ V (NTH (SETQ NNEWVARS (1- NNEWVARS)) VARS))      UNTIL (NEQ (VAR-KIND V) 'FEF-ARG-DELETED)      FINALLY (UNLESS (EQ (VAR-NAME V)  (IF (ATOM VAR) VAR (FIRST VAR)))(WARN 'LET-OPT :BUG "Bug in ~S on ~S" 'LET-OPT VAR)(RETURN-FROM LET-OPT FORM)))IF (OR (AND (OR (NULL (SETQ USED (VAR-USE-COUNT V)))   ; never referenced(ZEROP USED)   ; value never usedDELETE-ALL)   ; called from DISCARD to throw all away    (MEMBER (VAR-KIND V)    '(FEF-ARG-INTERNAL-AUX FEF-ARG-FREE FEF-ARG-DELETED)    :TEST #'EQ)    (OR (EQ (VAR-TYPE V) 'FEF-LOCAL)DELETE-ALL(AND (OR (NEQ (FIRST FORM) 'LET*) (NULL (REST VLIST-TAIL)))     (OR (NULL BODY) (AND (NULL (REST BODY))      (OR ;; Check for references in the body form.(AND (< (OPT-SAFETY OPTIMIZE-SWITCH)(OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))     (NULL (VARS-USED (FIRST BODY)      (LIST (VAR-LAP-ADDRESS V)))));; Can binding be replaced by an optional argument?(AND (EQ (VAR-NAME V) '*STANDARD-OUTPUT*)     (MEMBER (CAR-SAFE (FIRST BODY))     '( PRIN1 PRINT PPRINT PRINC       WRITE-CHAR WRITE-STRING WRITE-LINE       WRITE-BYTE))     (= (LENGTH (FIRST BODY)) 2)     (INDEPENDENT-EXPRESSIONS-P       (SECOND (FIRST BODY)) (SECOND (VAR-INIT V)))     (PROGN       ;; (LET ((*STANDARD-OUTPUT* x)) (PRINT a)) ==> (PRINT a x)       ;; [such forms are created by the FORMAT optimizer]       (SETF (CDDR (FIRST BODY))     (LIST (SECOND (VAR-INIT V))))       (SETF VAR NIL)       T)))))))    (OR (ATOM VAR)DELETE-ALL(NO-SIDE-EFFECTS-P (SECOND VAR))))       (AND (EQL USED 1)    (MEMBER 'FEF-ARG-NOT-ALTERED (VAR-MISC V))    (<= (OPT-SAFETY OPTIMIZE-SWITCH)(OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))    (AND (NULL (REST BODY)) (CONSP (FIRST BODY)) (NOT (QUOTES-ANY-ARGS (FIRST (FIRST BODY)))) (NOT (USES-SPECIAL-BINDINGS-P V (THIRD FORM))) (DO ((INIT (SECOND (VAR-INIT V)))      (ARGS (REST (FIRST BODY)) (REST ARGS)))     ((NULL ARGS) NIL)   (COND ((EQ (FIRST ARGS) (VAR-LAP-ADDRESS V))  ;; (LET ((x (foo a))) (bar x)) ==> (bar (foo a))  (SETF (FIRST ARGS) INIT)  (SETF VAR NIL)  (RETURN T)) ((INDEPENDENT-EXPRESSIONS-P INIT (FIRST ARGS))) (T (RETURN NIL))))))       )   ; variable can be deletedDO (PROGN (DEBUG-ASSERT (OR (ATOM VAR)    (EQ (SECOND VAR) (SECOND (VAR-INIT V)))    (AND (EQUAL (SECOND VAR) '(UNDEFINED-VALUE)) (EQ (FIRST (VAR-INIT V)) 'FEF-INI-NONE))    (EQ (SECOND (VAR-INIT V)) 'DELETED-VALUE))NIL "init mismatch in LET-OPT for ~S" (VAR-NAME V))  ;; Now mark the variable deleted.  (SETF (VAR-KIND V) 'FEF-ARG-DELETED)  (UNLESS (OR (ATOM VAR)      (EQ (SECOND (VAR-INIT V)) 'DELETED-VALUE))    (DISCARD (SECOND VAR)))  (SETQ CHANGED T