LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760030413. :SYSTEM-TYPE :LOGICAL :VERSION 11. :TYPE "LISP" :NAME "TYPEOPT" :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 2758302998. :AUTHOR "REL3" :LENGTH-IN-BYTES 47392. :LENGTH-IN-BLOCKS 47. :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) 1986,1987 Texas Instruments Incorporated. All rights reserved.;;;;   *-----------------------------------------------------------*;;;;   |   --  TI Explorer Lisp Compiler  --   |;;;;   |  This file defines a pattern-matching optimizer and    |;;;;   |  associated routines for testing the type of a form.   |;;;;   *-----------------------------------------------------------*;;;  4/21/86 DNG - Original version included in release 3 compiler.;;;  4/24/86 DNG - Add declaration of result type of some common functions.;;;  6/21/86 DNG - Modified to include the pattern list in the POST-OPTIMIZERS;;; property instead of as a separate property.;;;  7/17/86 DNG - Support optional CONDITION argument to OPTIMIZE-PATTERN.;;;  8/09/86 DNG - New definition of EXPR-TYPE-P.;;;  8/29/86 DNG - Add support for function type declarations.;;; 10/22/86 DNG - Moved definition of macro OPTIMIZE-PATTERN to file P1DEFS.;;; 12/08/86 DNG - Fix SUBSEQ optimization.  Declare result type for CHAR-EQUAL etc.;;; 12/09/86 DNG - Optimize UNWIND-PROTECT with only one argument.;;; 12/10/86 DNG - Optimize ELT instead of COMMON-LISP-ELT.;;; 12/22/86 DNG - Optimize ADJUST-ARRAY to ADJUST-ARRAY-SIZE; declare +, -, etc. to return a NUMBER.;;;  1/15/87 DNG - More optimization patterns for CONCATENATE, POSITION, and SEARCH.;;;  2/26/87 DNG - Update CANONICALIZE-TYPE-FOR-COMPILER for SATISFIES types.;;;  3/13/87 DNG - Revise optimization patterns for SEARCH and FILL.;;; ---------;; The following function should only be used by the macro OPTIMIZE-PATTERN .(DEFUN ADD-OPTIMIZE-PATTERN ( FUNCTION-NAME TEMPLATE REPLACEMENT     &OPTIONAL (PERMUTATIONS NIL) (CONDITION T))  ;;  6/21/86 DNG - Modified to include the pattern list in the POST-OPTIMIZERS  ;; property instead of as a separate property.  ;;  7/17/86 DNG - Support optional CONDITION argument.  ;;  7/21/86 DNG - Update existing pattern when either condition or replacement match.  (LET* (( PROP (GET FUNCTION-NAME 'POST-OPTIMIZERS) ) ( POSTOPT  (AND (CONSP PROP)       (DOLIST ( X PROP NIL ) (WHEN (AND (CONSP X)    (EQ (FIRST X) 'PATTERN-OPTIMIZER))   (RETURN X)))) ) ( DEFAULT-CONS-AREA BACKGROUND-CONS-AREA ))    (DOLIST ( P (SECOND POSTOPT) )      (WHEN (AND (EQUAL TEMPLATE (FIRST P)) (OR (EQUAL REPLACEMENT (SECOND P))     (EQUAL CONDITION    (IF (CDDDR P) (FOURTH P) T))));; Update existing pattern list(UNLESS (EQUAL REPLACEMENT (SECOND P))  (SETF (SECOND P) REPLACEMENT))(UNLESS (EQUAL PERMUTATIONS (THIRD P))  (SETF (THIRD P)  PERMUTATIONS))(UNLESS (EQUAL CONDITION (FOURTH P))  (IF (< (LENGTH P) 4)      (SETF (CDDDR P) (LIST CONDITION))    (SETF (FOURTH P) CONDITION)))(RETURN-FROM ADD-OPTIMIZE-PATTERN FUNCTION-NAME) ))    (UNLESS (NULL CONDITION)      ;; Define new pattern list      (LET (( PATTERN (LIST TEMPLATE REPLACEMENT PERMUTATIONS CONDITION) ))(IF POSTOPT    (PUSH PATTERN (SECOND POSTOPT))  ;; Use FUNCALL to force the argument to be evaluated even though  ;; ADD-POST-OPTIMIZER is a special form.  (FUNCALL #'ADD-POST-OPTIMIZER FUNCTION-NAME   (LIST 'PATTERN-OPTIMIZER (LIST PATTERN)))))))  FUNCTION-NAME )(DEFSUBST VM1 ()  "True when compiling to run under Explorer release 2, NIL for release 3."  #+Elroy NIL  #-Elroy (NOT (COMPILING-FOR-V2)) )(DEFUN DEFINE-PATTERNS ()  ;; Collect the patterns into a single FEF so that  ;; EQUAL lists will not be duplicated.  ;;  5/10/86 - Add patterns for GET and TIME. [previously handled in P1OPT]  ;;  5/16/86 - Handle :START and :END options for FILL.  ;;  5/21/86 - Don't create calls to GLOBAL:REM, which has been removed from the kernel.  ;;  6/05/86 - More cases of SEARCH to STRING-SEARCH and POSITION to STRING-SEARCH-CHAR.  ;;  6/09/86 - Remove optimizations to use DEL-IF, DEL-IF-NOT, REM-IF, and  ;;REM-IF-NOT because these are not in the rel3 kernel.  ;;  7/18/86 - Use (VM1) condition for optimizations previously commented out; add a  ;;few new optimizations conditioned on (COMPILING-FOR-V2).  ;;  9/20/86 - Optimize EVERY, SOME, NOTANY, NOTEVERY, and SI:EVAL1.  ;;  9/23/86 CLM - More generic sequence patterns: ADJOIN, DELETE, REMOVE, SUBST, etc.  ;; 10/01/86 CLM - Added patterns for DELETE-LIST, REMOVE-LIST and SUBST to generate the  ;;                -EQL forms when it's possible to use the default test value.  ;; 10/14/86 DNG - Optimize WRITE to PRIN1 or PRINC.  ;; 10/22/86 DNG - Fix to reference SI:MEMBER-IF* instead of MEMBER-IF*.  ;; 11/18/86 CLM - Add pattern (SI:SUBST* T T T #'EQL/EQUAL) => (SI:SUBST-EQL/EQUAL T T T)  ;; 11/18/86 DNG - Optimize SI:ASSOC-EQL and SI:ASSOC-EQUAL to ASSQ.  ;; 11/19/86 DNG - CONCATENATE two lists with APPEND and COPY-LIST.  ;;Optimize STRING= to EQUAL.  ;; 12/08/86 DNG - When optimizing SUBSEQ to NTHCDR, need to use COPY-LIST too.  ;; 12/09/86 DNG - Optimize UNWIND-PROTECT with only one argument.  ;; 12/10/86 DNG - COMMON-LISP-ELT is now just ELT.  ;; 12/22/86 DNG - Optimize ADJUST-ARRAY to ADJUST-ARRAY-SIZE .  ;;  1/15/87 DNG - More patterns for CONCATENATE, POSITION, and SEARCH.  ;;  3/12/87 DNG - Optimize POSITION* with :START option.  ;;  3/13/87 DNG - Revised optimization of SEARCH and FILL.    ;;  ---  Sequence functions  --- (OPTIMIZE-PATTERN (COPY-SEQ LIST)(COPY-LIST 1)) (OPTIMIZE-PATTERN (CONCATENATE 'STRING STRING STRING) (STRING-APPEND 2 3)) (OPTIMIZE-PATTERN (CONCATENATE 'STRING STRING STRING STRING) (STRING-APPEND 2 3 4)) (OPTIMIZE-PATTERN (CONCATENATE 'STRING STRING STRING STRING STRING)           (STRING-APPEND 2 3 4 5)) (OPTIMIZE-PATTERN (CONCATENATE 'STRING STRING STRING STRING STRING STRING)           (STRING-APPEND 2 3 4 5 6)) (OPTIMIZE-PATTERN (CONCATENATE 'VECTOR VECTOR VECTOR) (STRING-APPEND 2 3) (COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (CONCATENATE 'VECTOR VECTOR VECTOR VECTOR) (STRING-APPEND 2 3 4)(COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (CONCATENATE 'LIST LIST LIST)   (FUNCALL #'(LAMBDA (LIST1 LIST2)(APPEND LIST1 (COPY-LIST LIST2)))    2 3)) (OPTIMIZE-PATTERN (CONCATENATE 'LIST VECTOR) (SI:COERCE-TO-LIST 2)) (OPTIMIZE-PATTERN (CONCATENATE 'VECTOR LIST)   (SI:COERCE-TO-ARRAY-OPTIMIZED 2 'ART-Q)) (OPTIMIZE-PATTERN (CONCATENATE 'STRING LIST)   (SI:COERCE-TO-ARRAY-OPTIMIZED 2 'ART-STRING)) (OPTIMIZE-PATTERN (CONCATENATE 'LIST LIST) (COPY-LIST 2)) (OPTIMIZE-PATTERN (CONCATENATE 'VECTOR VECTOR) (COPY-SEQ 2)) (OPTIMIZE-PATTERN (DELETE-IF T LIST)(DEL-IF 1 2) (VM1)) (OPTIMIZE-PATTERN (DELETE-IF-NOT T LIST) (DEL-IF-NOT 1 2) (VM1)) (OPTIMIZE-PATTERN (DEL #'EQ T T)(DELQ 2 3) (VM1)) (OPTIMIZE-PATTERN (DEL #'EQUAL T T)(GLOBAL:DELETE 2 3)(VM1)) (OPTIMIZE-PATTERN (DEL #'EQUAL T T T)(GLOBAL:DELETE 2 3 4)) (OPTIMIZE-PATTERN (DELETE T LIST ':TEST T) (DEL 4 1 2)   (VM1)) (OPTIMIZE-PATTERN (DELETE T LIST ':TEST T ':COUNT T) (DEL 4 1 2 6) (VM1)) (OPTIMIZE-PATTERN (DELETE T LIST ':COUNT T ':TEST T) (DEL 6 1 2 4) (VM1)) (OPTIMIZE-PATTERN (DELETE (PASSES EQ-COMPARABLE-P) LIST) (DELQ 1 2)  (VM1)) #-Elroy (OPTIMIZE-PATTERN (COMMON-LISP-ELT LIST (PASSES QUOTE-NUMBER)) (NTH 2 1)) (OPTIMIZE-PATTERN (ELT LIST (PASSES QUOTE-NUMBER))(NTH 2 1)) ;; the following lambda expression will be expanded inline (OPTIMIZE-PATTERN (EVERY T LIST) (FUNCALL #'(LAMBDA ( PREDICATE LIST )       (DOLIST ( ELEMENT LIST T ) (OR (FUNCALL PREDICATE ELEMENT)     (RETURN NIL))))   1 2)    OPEN-CODE-MAP-SWITCH) (OPTIMIZE-PATTERN (FILL T T) (SI:FILL* 1 2)(COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (FILL T T ':START T) (SI:FILL* 1 2 4)(COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (FILL T T ':END T)(SI:FILL* 1 2 '0 4)(COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (FILL T T ':START T ':END T) (SI:FILL* 1 2 4 6)(COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (FILL T T ':END T ':START T) (SI:FILL* 1 2 6 4)(COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (SI:FILL* ARRAY T) (ARRAY-INITIALIZE 1 2)) (OPTIMIZE-PATTERN (SI:FILL* ARRAY T T) (ARRAY-INITIALIZE 1 2 3)) (OPTIMIZE-PATTERN (SI:FILL* ARRAY T T T)(ARRAY-INITIALIZE 1 2 3 4)) (OPTIMIZE-PATTERN (SI:FILL* LIST T) (SI:FILL-LIST 1 2)) (OPTIMIZE-PATTERN (SI:FILL* LIST T T) (SI:FILL-LIST 1 2 3)) (OPTIMIZE-PATTERN (SI:FILL* LIST T T T)(SI:FILL-LIST 1 2 3 4)) (OPTIMIZE-PATTERN (MAKE-SEQUENCE 'LIST T)(MAKE-LIST 2)) ;; Note: more complicated cases of MAKE-SEQUENCE are handled by trying inline expansion. (OPTIMIZE-PATTERN (MAP 'LIST T LIST)(MAPCAR 2 3)) (OPTIMIZE-PATTERN (MAP 'LIST T LIST LIST)(MAPCAR 2 3 4)) (OPTIMIZE-PATTERN (MAP 'NIL T LIST)(MAPC 2 3)(NULL P1VALUE)) (OPTIMIZE-PATTERN (MAP 'NIL T LIST LIST)(MAPC 2 3 4)(NULL P1VALUE)) (OPTIMIZE-PATTERN (NOTANY T LIST) (FUNCALL #'(LAMBDA ( PREDICATE LIST )(DOLIST ( ELEMENT LIST T )  (AND (FUNCALL PREDICATE ELEMENT)       (RETURN NIL))))    1 2)   OPEN-CODE-MAP-SWITCH)  (OPTIMIZE-PATTERN (NOTEVERY T LIST) (FUNCALL #'(LAMBDA ( PREDICATE LIST )   (DOLIST ( ELEMENT LIST NIL )     (OR (FUNCALL PREDICATE ELEMENT) (RETURN T))))       1 2)    OPEN-CODE-MAP-SWITCH) #-Elroy (OPTIMIZE-PATTERN (POSITION T LIST ':TEST #'EQ) (FIND-POSITION-IN-LIST 1 2)) #-Elroy (OPTIMIZE-PATTERN (POSITION (PASSES EQ-COMPARABLE-P) LIST) (FIND-POSITION-IN-LIST 1 2)) (OPTIMIZE-PATTERN (SI:POSITION* T LIST #'EQ) (FIND-POSITION-IN-LIST 1 2) ) (OPTIMIZE-PATTERN (SI:POSITION* (PASSES EQ-COMPARABLE-P) LIST) (FIND-POSITION-IN-LIST 1 2)   ) (OPTIMIZE-PATTERN (POSITION T LIST ':TEST #'EQUAL) (FIND-POSITION-IN-LIST-EQUAL 1 2) (VM1)) (OPTIMIZE-PATTERN (SI:POSITION* T LIST #'EQUAL) (FIND-POSITION-IN-LIST-EQUAL 1 2)) (OPTIMIZE-PATTERN (SI:POSITION* T STRING #'CHAR-EQUAL) (STRING-SEARCH-CHAR 1 2) ) (OPTIMIZE-PATTERN (SI:POSITION* T STRING 'NIL 'NIL #'CHAR-EQUAL)   (STRING-SEARCH-NOT-CHAR 1 2)         ) (OPTIMIZE-PATTERN (SI:POSITION* T STRING #'CHAR-EQUAL 'NIL 'NIL T T (PASSES ALWAYS-TRUE))   (STRING-REVERSE-SEARCH-CHAR 1 2 7 6)     ) (OPTIMIZE-PATTERN (SI:POSITION* T STRING 'NIL 'NIL #'CHAR-EQUAL T T (PASSES ALWAYS-TRUE))   (STRING-REVERSE-SEARCH-NOT-CHAR 1 2 7 6) ) (OPTIMIZE-PATTERN (SI:POSITION* T STRING #'EQL 'NIL 'NIL T T (PASSES ALWAYS-TRUE))   (STRING-REVERSE-SEARCH-CHAR 1 2 7 6 'T)     ) (OPTIMIZE-PATTERN (SI:POSITION* T STRING 'NIL 'NIL #'EQL T T (PASSES ALWAYS-TRUE))   (STRING-REVERSE-SEARCH-NOT-CHAR 1 2 7 6 'T) ) (OPTIMIZE-PATTERN (SI:POSITION* T STRING #'CHAR= 'NIL 'NIL T T (PASSES ALWAYS-TRUE))   (STRING-REVERSE-SEARCH-CHAR 1 2 7 6 'T)     ) (OPTIMIZE-PATTERN (SI:POSITION* T STRING 'NIL 'NIL #'CHAR= T T (PASSES ALWAYS-TRUE))   (STRING-REVERSE-SEARCH-NOT-CHAR 1 2 7 6 'T) ) (OPTIMIZE-PATTERN (SI:POSITION* T STRING #'CHAR=)   (STRING-SEARCH-CHAR 1 2 '0 'NIL 'T)  ) (OPTIMIZE-PATTERN (SI:POSITION* T STRING #'CHAR= 'NIL 'NIL T T)   (STRING-SEARCH-CHAR 1 2 6 7 'T)      ) (OPTIMIZE-PATTERN (SI:POSITION* T STRING 'NIL 'NIL #'CHAR-EQUAL T)   (STRING-SEARCH-NOT-CHAR 1 2 6)         ) (OPTIMIZE-PATTERN (SI:POSITION* T STRING #'CHAR-EQUAL 'NIL 'NIL T)   (STRING-SEARCH-CHAR 1 2 6) ) (OPTIMIZE-PATTERN (SI:POSITION* CHARACTER STRING)   (STRING-SEARCH-CHAR 1 2 '0 'NIL 'T)) (OPTIMIZE-PATTERN (SI:POSITION* CHARACTER STRING #'EQL 'NIL 'NIL T T)   (STRING-SEARCH-CHAR 1 2 6 7 'T)) (OPTIMIZE-PATTERN (SI:POSITION* T T #'EQL)  (SI:POSITION* 1 2)) (OPTIMIZE-PATTERN (REDUCE T 'NIL)(FUNCALL 1)) (OPTIMIZE-PATTERN (REDUCE T 'NIL ':INITIAL-VALUE T)(PROGN 1 4)) (OPTIMIZE-PATTERN (REMOVE-IF T LIST)(REM-IF 1 2) (VM1)) (OPTIMIZE-PATTERN (REMOVE-IF-NOT T LIST) (REM-IF-NOT 1 2) (VM1)) (OPTIMIZE-PATTERN (GLOBAL:REM #'EQ T T)(REMQ 2 3)) (OPTIMIZE-PATTERN (GLOBAL:REM #'EQUAL T T)(GLOBAL:REMOVE 2 3)) (OPTIMIZE-PATTERN (GLOBAL:REM #'EQUAL T T T)(GLOBAL:REMOVE 2 3 4)) (OPTIMIZE-PATTERN (REMOVE T LIST ':TEST T) (GLOBAL:REM 4 1 2)  (VM1)) (OPTIMIZE-PATTERN (REMOVE T LIST ':TEST T ':COUNT T) (GLOBAL:REM 4 1 2 6)(VM1)) (OPTIMIZE-PATTERN (REMOVE T LIST ':COUNT T ':TEST T) (GLOBAL:REM 6 1 2 4)(VM1))  (OPTIMIZE-PATTERN (REMOVE (PASSES EQ-COMPARABLE-P) LIST)(REMQ 1 2) (VM1)) (OPTIMIZE-PATTERN (REVERSE LIST)(SI:REVERSE-LIST 1)(COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (REVERSE VECTOR)(SI:REVERSE-VECTOR 1)(COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (NREVERSE LIST)(SI:NREVERSE-LIST 1)(COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (NREVERSE VECTOR)(SI:NREVERSE-VECTOR 1)(COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (SI:SEARCH*-VECTOR-FROMEND T T #'EQ)(SI:SEARCH*-STRING-CASE-FROMEND 1 2)) (OPTIMIZE-PATTERN (SI:SEARCH*-VECTOR-FROMEND STRING STRING #'CHAR=)(SI:SEARCH*-STRING-CASE-FROMEND 1 2)) (OPTIMIZE-PATTERN (SI:SEARCH*-VECTOR-FROMEND STRING STRING)(SI:SEARCH*-STRING-CASE-FROMEND 1 2)) (OPTIMIZE-PATTERN (SI:SEARCH*-VECTOR-FROMEND STRING STRING #'CHAR-EQUAL)(SI:SEARCH*-STRING-NOCASE-FROMEND 1 2)) (OPTIMIZE-PATTERN (SI:SEARCH*-VECTOR-EQL STRING STRING T T T T (PASSES ALWAYS-TRUE))   (SI:SEARCH*-STRING-CASE-FROMEND 1 2 3 4 5 6)) ;;(defun search*-vector-eql (x y       &optional    start2 end2 start1 end1 from-end) (OPTIMIZE-PATTERN (SI:SEARCH*-VECTOR-FROMEND T T #'EQL T T)(SI:SEARCH*-VECTOR-EQL 1 2 4 5 '0 'NIL 'T)) (OPTIMIZE-PATTERN (SI:SEARCH*-VECTOR-FROMEND T T #'EQL T T T T)(SI:SEARCH*-VECTOR-EQL 1 2 4 5 6 7 'T)) ;;(defun search*-list (x y &optional (test #'eql) start2 end2 start1 end1 from-end key test-not) ;;(defun search*-list-eq-or-eql (x y eq-p &optional start2 end2 start1 end1 from-end) (OPTIMIZE-PATTERN (SI:SEARCH*-LIST T T #'EQ)(SI:SEARCH*-LIST-EQ-OR-EQL 1 2 'T)) (OPTIMIZE-PATTERN (SI:SEARCH*-LIST T T #'EQL)(SI:SEARCH*-LIST-EQ-OR-EQL 1 2)) (OPTIMIZE-PATTERN (SI:SEARCH*-LIST T T)(SI:SEARCH*-LIST-EQ-OR-EQL 1 2)) (OPTIMIZE-PATTERN (SI:SEARCH*-LIST T T #'EQ T T T T T)   (SI:SEARCH*-LIST-EQ-OR-EQL 1 2 'T 4 5 6 7 8)) (OPTIMIZE-PATTERN (SI:SEARCH*-LIST T T #'EQL T T T T T)   (SI:SEARCH*-LIST-EQ-OR-EQL 1 2 'NIL 4 5 6 7 8)) (OPTIMIZE-PATTERN (SOME T LIST) (FUNCALL #'(LAMBDA ( PREDICATE LIST )       (DOLIST ( ELEMENT LIST NIL ) (RETURN (OR (FUNCALL PREDICATE ELEMENT)     (GO CONTINUE))) CONTINUE))   1 2)   OPEN-CODE-MAP-SWITCH) (OPTIMIZE-PATTERN (SUBSEQ LIST T) (FUNCALL #'(LAMBDA (START LIST)     (COPY-LIST (NTHCDR START LIST))) 2 1)) (OPTIMIZE-PATTERN (SUBSEQ LIST '0 T) (FIRSTN 3 1))  ;;  ---  String functions  --- (OPTIMIZE-PATTERN (STRING STRING)(PROGN 1)) (OPTIMIZE-PATTERN (STRING-SEARCH STRING STRING)   (SI:SEARCH*-STRING-NOCASE 1 2) (COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (STRING-SEARCH STRING STRING T T)   (SI:SEARCH*-STRING-NOCASE 1 2 3 4) (COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (STRING-SEARCH STRING STRING T T T T 'NIL)   (SI:SEARCH*-STRING-NOCASE 1 2 3 4 5 6) (COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (STRING-SEARCH STRING STRING T T T T (PASSES ALWAYS-TRUE))   (SI:SEARCH*-STRING-CASE 1 2 3 4 5 6) (COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (STRING-REVERSE-SEARCH STRING STRING)   (SI:SEARCH*-STRING-NOCASE-FROMEND 1 2) (COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (STRING-REVERSE-SEARCH STRING STRING T T T T 'NIL)   (SI:SEARCH*-STRING-NOCASE-FROMEND 1 2 4 3 5 6) (COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (STRING-REVERSE-SEARCH STRING STRING T T T T (PASSES ALWAYS-TRUE))   (SI:SEARCH*-STRING-CASE-FROMEND 1 2 4 3 5 6) (COMPILING-FOR-V2))  ;;  ---  Numeric functions  --- (OPTIMIZE-PATTERN (*BOOLE '1 T T) (LOGAND 2 3)) (OPTIMIZE-PATTERN (*BOOLE '6 T T) (LOGXOR 2 3)) (OPTIMIZE-PATTERN (*BOOLE '7 T T) (LOGIOR 2 3)) (OPTIMIZE-PATTERN (GCD INTEGER) (ABS 1))  ;;  ---  Other functions  --- (OPTIMIZE-PATTERN (ADJUST-ARRAY VECTOR NUMBER) (GLOBAL:ADJUST-ARRAY-SIZE 1 2)) (OPTIMIZE-PATTERN (APPLY #'VALUES T) (VALUES-LIST 2)) (OPTIMIZE-PATTERN (SI:ASSOC-EQL (PASSES EQ-COMPARABLE-P) T) (ASSQ 1 2)) (OPTIMIZE-PATTERN (SI:ASSOC-EQUAL SYMBOL T)(ASSQ 1 2)) (OPTIMIZE-PATTERN (SI:ASSOC-EQUAL FIXNUM T)(ASSQ 1 2)) (OPTIMIZE-PATTERN (SI:ASSOC-EQUAL CHARACTER T)(ASSQ 1 2)) (OPTIMIZE-PATTERN (GLOBAL:ASSOC SYMBOL T)(ASSQ 1 2)) (OPTIMIZE-PATTERN (SI:EVAL1 T) (SI:*EVAL 1) (COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (GET T T)(INTERNAL-GET-2 1 2)) (OPTIMIZE-PATTERN (GET T T T)(INTERNAL-GET-3 1 2 3)) (OPTIMIZE-PATTERN (INTERNAL-GET-3 T T 'NIL) (INTERNAL-GET-2 1 2)) (OPTIMIZE-PATTERN (SI:GET-LOCATION T T 'NIL) (SI:GET-LOCATION 1 2)) (OPTIMIZE-PATTERN (FORMAT:FORMAT-GET-STREAM STREAM) (PROGN 1)) ; to help FORMAT:COMMON-LISP-FORMAT-OPTIMIZER (OPTIMIZE-PATTERN (STRING= STRING STRING)(EQUAL 1 2)) ; 2 to 3 times faster (OPTIMIZE-PATTERN (TIME) (TIME-IN-60THS)) (OPTIMIZE-PATTERN (UNWIND-PROTECT T)(PROGN 1)) (OPTIMIZE-PATTERN (WRITE T ':ESCAPE 'NIL)(PRINC 1)) (OPTIMIZE-PATTERN (WRITE T ':ESCAPE (PASSES ALWAYS-TRUE))(PRIN1 1)) ;;  ---  more generic sequence optimizations  ---  (OPTIMIZE-PATTERN (ADJOIN T T ':TEST T)   (SI:ADJOIN-TEST 1 2 4)      (COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (SI:ADJOIN* T T T)      (SI:ADJOIN-TEST 1 2 3)      )   (OPTIMIZE-PATTERN (SI:SUBST* T T T)            (SI:SUBST-EQL 1 2 3)   (COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (SI:SUBST* T T T #'EQL)              (SI:SUBST-EQL 1 2 3)  (COMPILING-FOR-V2) ) (OPTIMIZE-PATTERN (SI:SUBST* T T T #'EQUAL)            (SI:SUBST-EQUAL 1 2 3)  (COMPILING-FOR-V2) )  (OPTIMIZE-PATTERN (SUBST-IF T T T)             (SI:SUBST-IF* 1 2 3)          (COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (SUBST-IF T T T ':KEY T)     (SI:SUBST-IF* 1 2 3 5)        (COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (SUBST-IF-NOT T T T)         (SI:SUBST-IF-NOT* 1 2 3)      (COMPILING-FOR-V2))  (OPTIMIZE-PATTERN (SUBST-IF-NOT T T T ':KEY T) (SI:SUBST-IF-NOT* 1 2 3 5)    (COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (NSUBST-IF T T T)             (SI:NSUBST-IF* 1 2 3)         (COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (NSUBST-IF T T T ':KEY T)     (SI:NSUBST-IF* 1 2 3 5)       (COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (NSUBST-IF-NOT T T T)         (SI:NSUBST-IF-NOT* 1 2 3)     (COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (NSUBST-IF-NOT T T T ':KEY T) (SI:NSUBST-IF-NOT* 1 2 3 5)   (COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (SI:DELETE-LIST T T)            (SI:DELETE-LIST-EQL 1 2)     ) (OPTIMIZE-PATTERN (SI:DELETE-LIST T T #'EQ)       (SI:DELETE-LIST-EQ 1 2)      ) (OPTIMIZE-PATTERN (SI:DELETE-LIST T T #'EQ T)     (SI:DELETE-LIST-EQ 1 2 4)    ) (OPTIMIZE-PATTERN (SI:DELETE-LIST T T #'EQL)      (SI:DELETE-LIST-EQL 1 2)     ) (OPTIMIZE-PATTERN (SI:DELETE-LIST T T #'EQL T)    (SI:DELETE-LIST-EQL 1 2 4)   ) (OPTIMIZE-PATTERN (SI:DELETE-LIST T T #'EQUAL)    (SI:DELETE-LIST-EQUAL 1 2)   )  (OPTIMIZE-PATTERN (SI:DELETE-LIST T T #'EQUAL T)  (SI:DELETE-LIST-EQUAL 1 2 4) ) (OPTIMIZE-PATTERN (SI:REMOVE-LIST T T)            (SI:REMOVE-LIST-EQL 1 2)     ) (OPTIMIZE-PATTERN (SI:REMOVE-LIST T T #'EQ)       (SI:REMOVE-LIST-EQ 1 2)      ) (OPTIMIZE-PATTERN (SI:REMOVE-LIST T T #'EQ T)     (SI:REMOVE-LIST-EQ 1 2 4)    ) (OPTIMIZE-PATTERN (SI:REMOVE-LIST T T #'EQL)      (SI:REMOVE-LIST-EQL 1 2)     ) (OPTIMIZE-PATTERN (SI:REMOVE-LIST T T #'EQL T)    (SI:REMOVE-LIST-EQL 1 2 4)   ) (OPTIMIZE-PATTERN (SI:REMOVE-LIST T T #'EQUAL)    (SI:REMOVE-LIST-EQUAL 1 2)   ) (OPTIMIZE-PATTERN (SI:REMOVE-LIST T T #'EQUAL T)  (SI:REMOVE-LIST-EQUAL 1 2 4) ) (OPTIMIZE-PATTERN (MEMBER-IF T T)(SI:MEMBER-IF* 1 2)(COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (MEMBER-IF T T ':KEY T)(SI:MEMBER-IF* 1 2 4)(COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (MEMBER-IF-NOT T T)(SI:MEMBER-IF-NOT* 1 2)(COMPILING-FOR-V2)) (OPTIMIZE-PATTERN (MEMBER-IF-NOT T T ':KEY T) (SI:MEMBER-IF-NOT* 1 2 4)(COMPILING-FOR-V2)) (VALUES)); end of DEFINE-PATTERNS(DEFINE-PATTERNS)(DEFUN PATTERN-OPTIMIZER ( FORM PATTERN-LIST )  ;;  3/26/86 DNG - Original.  ;;  7/14/86 DNG - Support optional CONDITION argument on OPTIMIZE-PATTERN.  #-compiler:debug  (DECLARE (OPTIMIZE SPEED))  (LET (( NARGS (LENGTH (REST FORM)) ))    (DECLARE (FIXNUM NARGS))    (DOLIST ( PATTERN PATTERN-LIST FORM )      (WHEN (= NARGS (LENGTH (FIRST PATTERN)))(BLOCK MATCH  (LET (( TYPED-ARGS NIL ) ( TYPED-PATTERN NIL ))    (DECLARE (LIST TYPED-ARGS TYPED-PATTERN))    (DO ((APS (FIRST PATTERN) (REST APS)) (ARGS (REST FORM) (REST ARGS)) (AP))((NULL APS))      (DECLARE (LIST APS ARGS))      (SETQ AP (FIRST APS))      (COND ((EQ AP 'T))   ; T matches anything    ((ATOM AP)   ; type name symbol     #+compiler:debug     (UNLESS (SYMBOLP AP)       (WARN 'PATTERN-OPTIMIZER :BUG     "invalid pattern: ~S" AP)       (RETURN-FROM MATCH))     ;; In order to make this as fast as possible, defer type     ;; checking until after making sure that the simpler things     ;; match first.     (WHEN (NULL TYPED-ARGS)       (SETQ TYPED-ARGS ARGS     TYPED-PATTERN APS)))    ((EQ (FIRST AP) 'QUOTE)   ; a particular constant needed     (UNLESS (EQUAL AP (FIRST ARGS))       (RETURN-FROM MATCH)))    ((EQ (FIRST AP) 'FUNCTION)   ; #'f matches #'f or 'f     (LET ((ARG (FIRST ARGS)))       (UNLESS (AND (CONSP ARG)    (MEMBER (FIRST ARG) '(QUOTE FUNCTION) :TEST #'EQ)    (EQUAL (SECOND ARG) (SECOND AP))) (RETURN-FROM MATCH))))     ((EQ (FIRST AP) 'PASSES)     ;; This is similar to the SATISFIES type construct, except     ;; that the function is applied to the form rather than to     ;; its value.     (WHEN (NULL TYPED-ARGS)       (SETQ TYPED-ARGS ARGS     TYPED-PATTERN APS)))    (T #+compiler:debug       (WARN 'PATTERN-OPTIMIZER :BUG     "invalid pattern: ~S" AP)       (RETURN-FROM MATCH)) )        )    ;; At this point, we have the correct number of arguments and any    ;; required constants have matched.    (WHEN (CDDDR PATTERN) ; check for additional conditions      (LET (( CONDITION (FOURTH PATTERN) ))(UNLESS (COND ((EQ CONDITION T) T) ; handle most common cases first      ((SYMBOLP CONDITION)       (SYMBOL-VALUE CONDITION))      ((AND (CONSP CONDITION)    (NULL (CDR CONDITION)))       (FUNCALL (CAR CONDITION)))      (T (EVAL CONDITION)))  ;; condition failed  (RETURN-FROM MATCH) )))    ;; Now perform any necessary type checking.    (DOLIST ( AP TYPED-PATTERN )      (COND ((EQ AP 'T))   ; T matches anything    ((ATOM AP)   ; type name symbol     (UNLESS (EXPR-TYPE-P (FIRST TYPED-ARGS) AP)       (RETURN-FROM MATCH)) )    ((EQ (FIRST AP) 'PASSES)     ;; This is similar to the SATISFIES type construct, except     ;; that the function is applied to the form rather than to     ;; its value.     (UNLESS (FUNCALL (SECOND AP) (FIRST TYPED-ARGS))       (RETURN-FROM MATCH))) )      (SETQ TYPED-ARGS (REST TYPED-ARGS)) ))  ;; If we reach here, we have succeeded in matching the pattern.  (DOLIST ( PERMUTATION (THIRD PATTERN) )    ;; Going to change the order of evaluation; better make    ;; sure that is safe to do.    (LET (( ARG (NTH (FIRST PERMUTATION) FORM) ))      (UNLESS (AND (CONSP ARG)   (MEMBER (FIRST ARG)   '(QUOTE FUNCTION BREAKOFF-FUNCTION LEXICAL-CLOSURE)   :TEST #'EQ))(DOLIST ( OTHER (REST PERMUTATION) )  (UNLESS (INDEPENDENT-EXPRESSIONS-P ARG (NTH OTHER FORM))    (RETURN-FROM MATCH) )))))   ;; Now we can actually do the optimization.  (RETURN-FROM PATTERN-OPTIMIZER    (LET (( NEW-FORM (COPY-LIST (SECOND PATTERN)) ))      (DECLARE (LIST NEW-FORM))      (DO ((PS (REST NEW-FORM) (REST PS)))  ((NULL PS))(DECLARE (LIST PS))(IF (FIXNUMP (FIRST PS))    (SETF (FIRST PS)  (NTH (FIRST PS) FORM))  #+compiler:debug  (assert (member (car-safe (first ps)) '(quote function)))  ))      NEW-FORM))   )   ; end of BLOCK MATCH))   ; end of outer DOLIST    ))(DEFUN EXPR-TYPE-P ( ORIGINAL-FORM TYPE )  "Test whether a Lisp form [after P1] always produces a value of the indicated type."  ;; When the second argument is a type specifier, return true if the value of  ;;   FORM is known to always be of type TYPE.  ;; When the second argument is RETURN-THE-TYPE, return a type specifier for  ;;   the type of FORM, or T if no type information is available.  This should only  ;;   be used by the macro TYPE-OF-EXPRESSION.  ;; Note: the type NIL indicates a form that does not return [for example, GO].  ;;  ;;  4/21/86 - Original for release 3.  ;;  4/28/86 - Add special handling for DEFCONSTANT symbols.  ;;  5/08/86 - Add special handling for COND form.  ;;  5/10/86 - Add special handling for PROGN, PROG1, etc.  ;;  6/30/86 - Re-designed, combining EXPR-TYPE-P and TYPE-OF-EXPRESSION.  ;;  8/09/86 - Replaced use of UNKNOWN with T [except in THE-EXPR].  ;;  8/26/86 - Get type of BREAKOFF-FUNCTION from COMPILAND-PLIST.  ;;  8/29/86 - Use array element type.  ;; 10/11/86 - For a local variable which is not altered, can get type from initial value.  (DECLARE (ARGLIST FORM TYPE))  (LET ( (FORM ORIGINAL-FORM) FORM-TYPE FORM-VALUE (THE-EXPR-FORM NIL) )    (TAGBODY(WHEN (NULL FORM) ; if run past end of argument list then match fails.  #+compiler:debug  (assert (not (EQL TYPE RETURN-THE-TYPE)))  (RETURN-FROM EXPR-TYPE-P NIL) )(WHEN (EQ TYPE 'T)   ; T matches anything  (RETURN-FROM EXPR-TYPE-P T) )     START-OVER-WITH-NEW-FORM(IF (ATOM FORM)    (COND ((AND (SYMBOLP FORM)(GET-FOR-TARGET FORM 'SYSTEM-CONSTANT)(BOUNDP-FOR-TARGET FORM))   ;; Check value of DEFCONSTANT   (SETQ FORM-VALUE (SYMEVAL-FOR-TARGET FORM))   (GO VALUE-KNOWN) )  ((> (OPT-SAFETY OPTIMIZE-SWITCH)      (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))   ;; Don't rely on user's declarations.   (GO NOTHING-KNOWN))  ;; Else fetch the variable's type declaration.  ((SYMBOLP FORM)   (SETQ FORM-TYPE (IF (OR UNDO-DECLARATIONS-FLAG LOCAL-DECLARATIONS)     (GETDECL FORM 'VARIABLE-TYPE 'T)   (GET-FOR-TARGET FORM 'VARIABLE-TYPE 'T)))   (GO TYPE-KNOWN))  (T (BARF FORM 'TYPE-OF-EXPRESSION 'BARF)))  (CASE (FIRST FORM)( QUOTE (SETQ FORM-VALUE (SECOND FORM)) (GO VALUE-KNOWN) )( LOCAL-REF   ; local variable (IF (> (OPT-SAFETY OPTIMIZE-SWITCH)(OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))     ;; Don't rely on user's declarations.     (GO NOTHING-KNOWN)   ;; Else fetch the variable's type declaration.   (LET ((V (SECOND FORM)))     (SETQ FORM-TYPE   (GETF (VAR-DECLARATIONS V) 'TYPE 'T))     (WHEN (AND (EQ FORM-TYPE 'T)(MEMBER 'FEF-ARG-NOT-ALTERED (VAR-MISC V))(SETQ FORM (SECOND (VAR-INIT V))))       (GO START-OVER-WITH-NEW-FORM))     (GO TYPE-KNOWN))))( VALUES (RETURN-FROM EXPR-TYPE-P   (COND ((AND (CONSP TYPE)       (EQ (FIRST TYPE) 'VALUES))  (EVERY #'EXPR-TYPE-P (REST FORM) (REST TYPE))) ((AND (CDR FORM) (NULL (CDDR FORM)))  (SETQ FORM (SECOND FORM))  (GO START-OVER-WITH-NEW-FORM)) ((EQL TYPE RETURN-THE-TYPE)  (CONS 'VALUES(MAPCAR #'TYPE-OF-EXPRESSION (REST FORM)) )) (T NIL))))( SETQ (DO ((ARGS (REST FORM) (CDDR ARGS)))     ((NULL (CDDR ARGS))      (RETURN-FROM EXPR-TYPE-P(IF (EQL TYPE RETURN-THE-TYPE)    (LET (( EXP-TYPE (TYPE-OF-EXPRESSION (SECOND ARGS)) ))      (IF (EQ EXP-TYPE 'T)  (PROGN (SETQ FORM (FIRST ARGS)) (GO START-OVER-WITH-NEW-FORM))EXP-TYPE ))  (OR (EXPR-TYPE-P (SECOND ARGS) TYPE)      (EXPR-TYPE-P (FIRST ARGS) TYPE)))))   ))(( PROGN PROGN-WITH-DECLARATIONS LET LET* LET-FOR-LAMBDA ) ;; use type of last argument (SETQ FORM (CAR (LAST (CDR FORM)))) (GO START-OVER-WITH-NEW-FORM))(( PROG1 SUBSEQ COPY-SEQ REVERSE NREVERSE REMOVE-DUPLICATES DELETE-DUPLICATES ) ;; use type of first argument (SETQ FORM (SECOND FORM)) (GO START-OVER-WITH-NEW-FORM))( COND (LET (( LAST-TEST NIL ))   (IF (EQL TYPE RETURN-THE-TYPE)       (PROGN (DOLIST ( CLAUSE (REST FORM) )   (LET (( EXP-TYPE (TYPE-OF-EXPRESSION (FIRST (LAST CLAUSE))) ))     (COND ((EQ EXP-TYPE 'T)    (SETQ FORM-TYPE EXP-TYPE)    (GO TYPE-KNOWN))   ((NULL FORM-TYPE)    (SETQ FORM-TYPE EXP-TYPE))   ((EQUAL FORM-TYPE EXP-TYPE))   ((SUBTYPEP EXP-TYPE FORM-TYPE))   ((SUBTYPEP FORM-TYPE EXP-TYPE)    (SETQ FORM-TYPE EXP-TYPE))   ((EQ (CAR-SAFE FORM-TYPE) 'OR)    (SETQ FORM-TYPE `(OR ,EXP-TYPE . ,(REST FORM-TYPE))))   (T (SETQ FORM-TYPE `(OR ,EXP-TYPE ,FORM-TYPE))) ))   (SETQ LAST-TEST (FIRST CLAUSE)) ) (UNLESS (OR (ALWAYS-TRUE LAST-TEST)     (TYPEP 'NIL FORM-TYPE))   (SETQ FORM-TYPE `(OR NULL ,FORM-TYPE))) (GO TYPE-KNOWN) )     (PROGN       (DOLIST ( CLAUSE (REST FORM) ) (UNLESS (EXPR-TYPE-P (FIRST (LAST CLAUSE)) TYPE)   (RETURN-FROM EXPR-TYPE-P NIL)) (SETQ LAST-TEST (FIRST CLAUSE)) )       (RETURN-FROM EXPR-TYPE-P (IF (ALWAYS-TRUE LAST-TEST)     T   (TYPEP 'NIL TYPE) ))))))( THE-EXPR (LET (( EXP-TYPE (EXPR-TYPE FORM) ))   (IF (EQ EXP-TYPE 'UNKNOWN)       (PROGN (SETQ THE-EXPR-FORM FORM)      (SETQ FORM (EXPR-FORM FORM))      (GO START-OVER-WITH-NEW-FORM))     (PROGN (SETQ FORM-TYPE EXP-TYPE)    (GO TYPE-KNOWN)))))(( FUNCALL APPLY LEXPR-FUNCALL REDUCE ) (LET (( FN (SECOND FORM) ))   ; function to be called   (IF (AND (CONSP FN)    (OR (EQ (FIRST FN) 'FUNCTION)(EQ (FIRST FN) 'QUOTE)))       (IF (SYMBOLP (SECOND FN))   (PROGN     (SETQ FORM-TYPE   (GETDECL (SECOND FN) 'FUNCTION-RESULT-TYPE 'T))     (GO TYPE-KNOWN)) (GO NOTHING-KNOWN))     (LET (( FT (TYPE-OF-EXPRESSION FN) ))       (IF (AND (CONSP FT)(EQ (FIRST FT) 'FUNCTION)(CDDR FT))   (PROGN (SETQ FORM-TYPE (THIRD FT))  (GO TYPE-KNOWN)) (GO NOTHING-KNOWN) )))))( COERCE (IF (QUOTEP (THIRD FORM))     (PROGN (SETQ FORM-TYPE (SECOND (THIRD FORM)))    (GO TYPE-KNOWN))   (GO NOTHING-KNOWN) ))(( CONCATENATE MAKE-SEQUENCE MAP ) (SETQ FORM-TYPE (IF (QUOTEP (SECOND FORM))     (OR (SECOND (SECOND FORM)) 'NULL) ; (MAP 'NIL ...)=>NIL   'SEQUENCE)) (GO TYPE-KNOWN))(( REMOVE DELETE REMOVE-IF REMOVE-IF-NOT DELETE-IF DELETE-IF-NOT ) ;; result has same type as second argument (SETQ FORM (THIRD FORM)) (GO START-OVER-WITH-NEW-FORM) )( BREAKOFF-FUNCTION ;; get type saved by REF-LOCAL-FUNCTION-VAR  (SETQ FORM-TYPE       (GETF (COMPILAND-PLIST (SECOND FORM)) 'TYPE 'FUNCTION)) (GO TYPE-KNOWN))(( COMMON-LISP-AR-1 COMMON-LISP-AR-2 COMMON-LISP-AR-3 AREF GLOBAL:AR-1 AR-2 ) (LET ((ARRAY-TYPE (TYPE-OF-EXPRESSION (SECOND FORM))))  (COND ((AND (CONSP ARRAY-TYPE)      (MEMBER (FIRST ARRAY-TYPE) '(ARRAY VECTOR SIMPLE-ARRAY))      (NOT (MEMBER (SECOND ARRAY-TYPE) '(T * NIL)))) (SETQ FORM-TYPE (SECOND ARRAY-TYPE)) (GO TYPE-KNOWN))((EQ ARRAY-TYPE 'STRING) (SETQ FORM-TYPE (IF (EQ (FIRST FORM) 'GLOBAL:AR-1)     'FIXNUM   'CHARACTER)) (GO TYPE-KNOWN))(T (GO NOTHING-KNOWN)))))#+compiler:debug   ; temporary for manual testing( THE (SETQ FORM-TYPE (SECOND FORM)) (GO TYPE-KNOWN))(OTHERWISE (SETQ FORM-TYPE       (IF (OR (EQ UNDO-DECLARATIONS-FLAG 'FUNCTION-RESULT-TYPE)       LOCAL-DECLARATIONS)   (GETDECL (FIRST FORM) 'FUNCTION-RESULT-TYPE 'T) (GET-FOR-TARGET (FIRST FORM) 'FUNCTION-RESULT-TYPE 'T))) (GO TYPE-KNOWN))))     TYPE-KNOWN(WHEN THE-EXPR-FORM  ;; Record what we learned so we won't have to traverse that tree again.  (SETF (EXPR-TYPE THE-EXPR-FORM) FORM-TYPE))(RETURN-FROM EXPR-TYPE-P  (COND ((EQL TYPE RETURN-THE-TYPE) FORM-TYPE);; To save time, try to handle the simple cases here without calling SUBTYPE.((EQ FORM-TYPE 'T) NIL)((EQ FORM-TYPE 'NIL) T)((EQUAL FORM-TYPE TYPE) T)((AND (CONSP FORM-TYPE)      (EQ (FIRST FORM-TYPE) TYPE)) T);; SUBTYPEP doesn't handle VALUES type specifiers((EQ (CAR-SAFE FORM-TYPE) 'VALUES) (COND ((EQ (CAR-SAFE TYPE) 'VALUES)(EVERY #'SUBTYPEP (REST FORM-TYPE) (REST TYPE)))       ((NULL (REST FORM-TYPE)) NIL)       (T (SUBTYPEP (SECOND FORM-TYPE) TYPE))));; Not obvious; have to do it the hard way.(T (SUBTYPEP FORM-TYPE TYPE) )))     NOTHING-KNOWN        (RETURN-FROM EXPR-TYPE-P  (IF (EQL TYPE RETURN-THE-TYPE)      'T    NIL))   ; match fails     VALUE-KNOWN(RETURN-FROM EXPR-TYPE-P          (IF (EQL TYPE RETURN-THE-TYPE)      (IF (NULL FORM-VALUE)  'NULL(TYPE-OF FORM-VALUE))    (TYPEP FORM-VALUE TYPE) )))))(DEFPARAMETER INTERESTING-TYPES      `(FIXNUM INTEGER SHORT-FLOAT NUMBERSTRING VECTOR ARRAYCONS NULL LISTT-OR-NIL SYMBOLCHARACTER SEQUENCE LOCATIVE STREAM)  "The data types the compiler cares about for optimization criteria."  ;; note that overlapping types must be listed with most specific first.  )(DEFUN CANONICALIZE-TYPE-FOR-COMPILER ( TYPE &OPTIONAL CONTEXT VALUES-PERMITTED-P )  ;;  8/29/86 DNG - Original.  ;; 10/07/86 DNG - New optional arg VALUES-PERMITTED-P.  ;;  2/11/87 DNG - For a valid type that is not a subtype of any INTERESTING-TYPES,  ;;return T instead of the canonicalized type since it is not of any  ;;use for optimization but might lead to trouble when checking initial  ;;values against their type declarations. (MULTIPLE-VALUE-BIND (USABLEP LEGALP)      (SI:TYPE-SPECIFIER-P TYPE)  (COND (USABLEP ; fully defined (IF (AND (SYMBOLP TYPE)  (MEMBER TYPE INTERESTING-TYPES :TEST #'EQ))     TYPE   (LET ((CANONIZED (SI:TYPE-CANONICALIZE TYPE)))     (DOLIST (X INTERESTING-TYPES T)       (WHEN (SUBTYPEP CANONIZED X) (RETURN   (IF (AND (MEMBER X '(ARRAY VECTOR))    (CONSP CANONIZED)    (NOT (MEMBER (SECOND CANONIZED) '(T * NIL))))       (LIST* (FIRST CANONIZED)      (CANONICALIZE-TYPE-FOR-COMPILER (SECOND CANONIZED) TYPE)      (CDDR CANONIZED))     X))))))) ((AND (CONSP TYPE)       (EQ (CAR TYPE) 'VALUES)       VALUES-PERMITTED-P)  (IF (= (LENGTH TYPE) 2)      (CANONICALIZE-TYPE-FOR-COMPILER (SECOND TYPE) CONTEXT NIL)    (CONS 'VALUES  (LOOP FOR ITEM IN (CDR TYPE)IF (MEMBER ITEM '(&OPTIONAL &REST &KEY));; legal but not worth bothering withDO (RETURN-FROM CANONICALIZE-TYPE-FOR-COMPILER 'UNKNOWN)ELSECOLLECT (CANONICALIZE-TYPE-FOR-COMPILER ITEM CONTEXT NIL))))) (LEGALP  ;; Here for a SATISFIES type that uses a predicate that isn't defined yet.  ;; The compiler doesn't have any use for SATISFIES types anyway.  T) (T (WARN 'CANONICALIZE-TYPE-FOR-COMPILER ':IGNORABLE-MISTAKE  (IF (OR (SYMBOLP TYPE)  (AND (CONSP TYPE)       (SYMBOLP (FIRST TYPE))       (NEQ (FIRST TYPE) 'QUOTE) ))      "Undefined type specifier ~S in ~S"    "Invalid type specifier syntax ~S in ~S")  TYPE CONTEXT)    (IF (SYMBOLP TYPE)TYPE      'UNKNOWN)))))(DEFUN RECORD-SPECIAL-VAR-TYPE (TYPE VAR-NAMES)  ;; Called by PROCLAIM to record the type of a special variable for use by EXPR-TYPE-P.  ;;  8/27/86 DNG - Original.  ;; 10/11/86 DNG - Use CANONICALIZE-TYPE-FOR-COMPILER .  ;; 10/15/86 DNG - NIL is not a valid type for a variable.  (LET ((TYPE (CANONICALIZE-TYPE-FOR-COMPILER TYPE 'PROCLAIM)))    (UNLESS (OR (EQ TYPE 'UNKNOWN)(EQ TYPE 'NIL))      (DOLIST (NAME VAR-NAMES)(IF (SYMBOLP NAME)    (IF UNDO-DECLARATIONS-FLAG(SETF (GETDECL NAME 'VARIABLE-TYPE) TYPE)      (SETF (GET-FOR-TARGET NAME 'VARIABLE-TYPE)    TYPE) )  (WARN 'RECORD-SPECIAL-VAR-TYPE ':IMPOSSIBLE"Invalid variable name in (PROCLAIM '(TYPE ~S ~S))" TYPE NAME) ))      )))(DEFUN DECLARE-FTYPE (DECL &OPTIONAL (LOCAL-FUNCTION-ALIST 'GLOBAL) LOCAL-DECLS)  ;; Process declarations FTYPE and FUNCTION.  ;;  8/29/86 DNG - Original.  ;;  9/08/86 DNG - Set FUNCTION-ARG-TYPES property in target environment.  ;;  9/09/86 DNG - Give warning in cold-load file.  ;; 10/07/86 DNG - Permit VALUES list as result type.  (BLOCK ESCAPE    (LET ( ARG-TYPES RESULT-TYPE FUNCTION-NAMES )      (CASE (FIRST DECL)    ( FTYPE     (SETQ FUNCTION-NAMES (CDDR DECL))     (LET (( FUNCTION-TYPE (SI:TYPE-CANONICALIZE (SECOND DECL))))       (UNLESS (AND (CONSP FUNCTION-TYPE)    (EQ (FIRST FUNCTION-TYPE) 'FUNCTION)    (= (LENGTH FUNCTION-TYPE) 3)) (WARN 'FTYPE ' :IGNORABLE-MISTAKE       "Invalid function~A type in declaration: ~S" "" DECL) (RETURN-FROM ESCAPE) )       (SETQ ARG-TYPES (SECOND FUNCTION-TYPE))       (SETQ RESULT-TYPE (THIRD FUNCTION-TYPE)) ))    ( FUNCTION     (SETQ FUNCTION-NAMES (LIST (SECOND DECL)))     (SETQ ARG-TYPES (THIRD DECL))     (SETQ RESULT-TYPE   (IF (= (LENGTH DECL) 4)       (FOURTH DECL)     (CONS 'VALUES (CDDDR DECL)))) )    #+compiler:debug    ( T (BARF (FIRST DECL) 'DECLARE-FTYPE 'BARF)))      (SETQ RESULT-TYPE (CANONICALIZE-TYPE-FOR-COMPILER RESULT-TYPE DECL T))      (WHEN (EQ RESULT-TYPE 'UNKNOWN)(RETURN-FROM ESCAPE))      (UNLESS (AND (LISTP ARG-TYPES)   (LET ((KEY NIL))     (DOLIST (ARG ARG-TYPES T)       (UNLESS (OR (MEMBER ARG LAMBDA-LIST-KEYWORDS :TEST #'EQ)   (AND KEY (LISTP ARG) (SYMBOLP (FIRST ARG))(SI:TYPE-SPECIFIER-P (SECOND ARG)))   (SI:TYPE-SPECIFIER-P ARG)) (RETURN NIL))       (WHEN (EQ ARG '&KEY) (SETQ KEY T)) )))(WARN 'FTYPE ' :IGNORABLE-MISTAKE      "Invalid function~A type in declaration: ~S" " argument" DECL)(SETQ ARG-TYPES ':ERROR))      (DOLIST ( FUNCTION-NAME FUNCTION-NAMES )(COND ((SYMBOLP FUNCTION-NAME)       (IF (LISTP LOCAL-FUNCTION-ALIST)   ;; called from PROCESS-PERVASIVE-DECLARATIONS   (LET (( TEMP (ASSOC FUNCTION-NAME LOCAL-FUNCTION-ALIST :TEST #'EQ) ) ( VALUE (LIST 'FUNCTION ARG-TYPES RESULT-TYPE)))     (IF TEMP (SETF (GETF (VAR-DECLARATIONS (SECOND TEMP)) 'TYPE)       VALUE)       (PUSH (LIST 'FUNCTION-RESULT-TYPE FUNCTION-NAME VALUE)     LOCAL-DECLS)       )) ;; else called from PROCLAIM (IF UNDO-DECLARATIONS-FLAG     (PROGN       (WHEN SI:FILE-IN-COLD-LOAD (WARN 'DECLARE-FTYPE ':IMPLAUSIBLE       "Warning: (PROCLAIM '~A) has no effect at cold-load time."       DECL))       (SETF (GETDECL FUNCTION-NAME 'FUNCTION-RESULT-TYPE)     RESULT-TYPE)       (SETF UNDO-DECLARATIONS-FLAG 'FUNCTION-RESULT-TYPE)       (WHEN (AND (LISTP ARG-TYPES)  (NOT (DECLARED-DEFINITION FUNCTION-NAME))) ;; remember argument list for CHECK-NUMBER-OF-ARGS (SETF (GETDECL FUNCTION-NAME 'FUNCTION-ARG-TYPES) ARG-TYPES)))   (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))     (SETF (GET-FOR-TARGET FUNCTION-NAME 'FUNCTION-RESULT-TYPE)   RESULT-TYPE)     (WHEN (AND (LISTP ARG-TYPES)(NOT (DECLARED-DEFINITION FUNCTION-NAME)))       ;; remember argument list for CHECK-NUMBER-OF-ARGS       (SETF (GET-FOR-TARGET FUNCTION-NAME 'FUNCTION-ARG-TYPES)     ARG-TYPES))))))      ((SI:VALIDATE-FUNCTION-SPEC FUNCTION-NAME))      (T (WARN 'DECLARE-FTYPE :IGNORABLE-MISTAKE       "Invalid function spec ~S in declaration ~S."       FUNCTION-NAME DECL))))))  LOCAL-DECLS)(DEFPROP RETURN-FROMNILFUNCTION-RESULT-TYPE)(DEFPROP GONILFUNCTION-RESULT-TYPE)(DEFPROP *THROWNILFUNCTION-RESULT-TYPE)(DEFPROP THROWNILFUNCTION-RESULT-TYPE)(DEFPROP MAKE-ARRAYARRAY   FUNCTION-RESULT-TYPE)(DEFPROP SI:SIMPLE-MAKE-ARRAYARRAYFUNCTION-RESULT-TYPE)(DEFPROP SI:COERCE-TO-ARRAY-OPTIMIZED ARRAY FUNCTION-RESULT-TYPE)(DEFPROP VECTORVECTORFUNCTION-RESULT-TYPE)(DEFPROP STRING-APPENDVECTORFUNCTION-RESULT-TYPE)(DEFPROP STRING-NCONCVECTORFUNCTION-RESULT-TYPE)(DEFPROP SI:REVERSE-VECTORVECTORFUNCTION-RESULT-TYPE)(DEFPROP SI:DELETE-VECTORVECTORFUNCTION-RESULT-TYPE)(DEFPROP SI:DELETE-IF-VECTORVECTORFUNCTION-RESULT-TYPE)(DEFPROP SI:DELETE-IF-NOT-VECTOR VECTORFUNCTION-RESULT-TYPE)(DEFPROP SI:REMOVE-VECTORVECTORFUNCTION-RESULT-TYPE)(DEFPROP SI:REMOVE-IF-VECTORVECTORFUNCTION-RESULT-TYPE)(DEFPROP SI:REMOVE-IF-NOT-VECTOR VECTORFUNCTION-RESULT-TYPE)(DEFPROP SI:DELETE-DUPLICATES-VECTOR VECTOR FUNCTION-RESULT-TYPE)(DEFPROP SI:REMOVE-DUPLICATES-VECTOR VECTOR FUNCTION-RESULT-TYPE)(DEFPROP STRINGSTRINGFUNCTION-RESULT-TYPE)(DEFPROP MAKE-STRINGSTRINGFUNCTION-RESULT-TYPE)(DEFPROP SYMBOL-NAMESTRINGFUNCTION-RESULT-TYPE)(DEFPROP SUBSTRING STRINGFUNCTION-RESULT-TYPE)(DEFPROP NSUBSTRING STRINGFUNCTION-RESULT-TYPE)(DEFPROP STRING-TRIM STRINGFUNCTION-RESULT-TYPE)(DEFPROP STRING-LEFT-TRIMSTRINGFUNCTION-RESULT-TYPE)(DEFPROP STRING-RIGHT-TRIMSTRINGFUNCTION-RESULT-TYPE)(DEFPROP STRING-REMOVE-FONTSSTRINGFUNCTION-RESULT-TYPE)(DEFPROP STRING-PLURALIZESTRINGFUNCTION-RESULT-TYPE)(DEFPROP STRING-SELECT-A-OR-ANSTRINGFUNCTION-RESULT-TYPE)(DEFPROP STRING-APPEND-A-OR-ANSTRINGFUNCTION-RESULT-TYPE)(DEFPROP SUBSTRING-AFTER-CHARSTRINGFUNCTION-RESULT-TYPE)(DEFPROP PRIN1-TO-STRINGSTRINGFUNCTION-RESULT-TYPE)(DEFPROP PRINC-TO-STRINGSTRINGFUNCTION-RESULT-TYPE)(DEFPROP WRITE-TO-STRINGSTRINGFUNCTION-RESULT-TYPE)(DEFPROP LISTLISTFUNCTION-RESULT-TYPE)(DEFPROP LIST*LISTFUNCTION-RESULT-TYPE)(DEFPROP MAKE-LISTLISTFUNCTION-RESULT-TYPE)(DEFPROP %MAKE-LISTLISTFUNCTION-RESULT-TYPE)(DEFPROP APPENDLISTFUNCTION-RESULT-TYPE)(DEFPROP SI:*APPENDLISTFUNCTION-RESULT-TYPE)(DEFPROP NCONCLISTFUNCTION-RESULT-TYPE)(DEFPROP SI:*NCONCLISTFUNCTION-RESULT-TYPE)(DEFPROP COPY-LISTLISTFUNCTION-RESULT-TYPE)(DEFPROP COPY-TREELISTFUNCTION-RESULT-TYPE)(DEFPROP SI:COERCE-TO-LIST LISTFUNCTION-RESULT-TYPE)(DEFPROP FIRSTNLISTFUNCTION-RESULT-TYPE)(DEFPROP DELQLISTFUNCTION-RESULT-TYPE)(DEFPROP REMQLISTFUNCTION-RESULT-TYPE)(DEFPROP MEMBERLISTFUNCTION-RESULT-TYPE)(DEFPROP MEMQLISTFUNCTION-RESULT-TYPE)(DEFPROP SI:MEMBER-EQLLISTFUNCTION-RESULT-TYPE)(DEFPROP MAPLISTLISTFUNCTION-RESULT-TYPE)(DEFPROP MAPCARLISTFUNCTION-RESULT-TYPE)(DEFPROP MAPCONLISTFUNCTION-RESULT-TYPE)(DEFPROP MAPCANLISTFUNCTION-RESULT-TYPE)(DEFPROP SI:REVERSE-LISTLISTFUNCTION-RESULT-TYPE)(DEFPROP SI:DELETE-LISTLISTFUNCTION-RESULT-TYPE)(DEFPROP SI:DELETE-LIST-EQLISTFUNCTION-RESULT-TYPE)(DEFPROP SI:DELETE-LIST-EQLLISTFUNCTION-RESULT-TYPE)(DEFPROP SI:DELETE-LIST-EQUALLISTFUNCTION-RESULT-TYPE)(DEFPROP SI:DELETE-IF-LISTLISTFUNCTION-RESULT-TYPE)(DEFPROP SI:DELETE-IF-NOT-LISTLISTFUNCTION-RESULT-TYPE)(DEFPROP SI:REMOVE-LISTLISTFUNCTION-RESULT-TYPE)(DEFPROP SI:REMOVE-LIST-EQLISTFUNCTION-RESULT-TYPE)(DEFPROP SI:REMOVE-LIST-EQLLISTFUNCTION-RESULT-TYPE)(DEFPROP SI:REMOVE-LIST-EQUALLISTFUNCTION-RESULT-TYPE)(DEFPROP SI:REMOVE-IF-LISTLISTFUNCTION-RESULT-TYPE)(DEFPROP SI:REMOVE-IF-NOT-LISTLISTFUNCTION-RESULT-TYPE)(DEFPROP SI:DELETE-DUPLICATES-LIST LISTFUNCTION-RESULT-TYPE)(DEFPROP SI:DELETE-DUPLICATES-LIST-EQL LIST FUNCTION-RESULT-TYPE)(DEFPROP SI:REMOVE-DUPLICATES-LIST LISTFUNCTION-RESULT-TYPE)(DEFPROP SI:REMOVE-DUPLICATES-LIST-EQL LIST FUNCTION-RESULT-TYPE)(DEFPROP CONSCONSFUNCTION-RESULT-TYPE)(DEFPROP NCONSCONSFUNCTION-RESULT-TYPE)(DEFPROP ADJOINCONSFUNCTION-RESULT-TYPE)(DEFPROP LENGTHFIXNUMFUNCTION-RESULT-TYPE)(DEFPROP STRING-LENGTHFIXNUMFUNCTION-RESULT-TYPE)(DEFPROP %DATA-TYPE    FIXNUMFUNCTION-RESULT-TYPE)(DEFPROP LDBFIXNUMFUNCTION-RESULT-TYPE)(DEFPROP SIGNED-LDBFIXNUMFUNCTION-RESULT-TYPE)(DEFPROP CHAR-INTFIXNUMFUNCTION-RESULT-TYPE)(DEFPROP COUNTFIXNUMFUNCTION-RESULT-TYPE)(DEFPROP COUNT-IFFIXNUMFUNCTION-RESULT-TYPE)(DEFPROP COUNT-IF-NOTFIXNUMFUNCTION-RESULT-TYPE)(DEFPROP FIND-POSITION-IN-LIST(OR FIXNUM NULL)FUNCTION-RESULT-TYPE)(DEFPROP FIND-POSITION-IN-LIST-EQUAL (OR FIXNUM NULL)FUNCTION-RESULT-TYPE)(DEFPROP POSITION(OR FIXNUM NULL)FUNCTION-RESULT-TYPE)(DEFPROP si:POSITION*(OR FIXNUM NULL)FUNCTION-RESULT-TYPE)(DEFPROP POSITION-IF(OR FIXNUM NULL)FUNCTION-RESULT-TYPE)(DEFPROP POSITION-IF-NOT(OR FIXNUM NULL)FUNCTION-RESULT-TYPE)(DEFPROP SEARCH(OR FIXNUM NULL)FUNCTION-RESULT-TYPE)(DEFPROP MISMATCH(OR FIXNUM NULL)FUNCTION-RESULT-TYPE);; The following 5 added 12/22/86 for use with the ADJUST-ARRAY optimization.(DEFPROP +NUMBERFUNCTION-RESULT-TYPE)(DEFPROP -NUMBERFUNCTION-RESULT-TYPE)(DEFPROP 1+NUMBERFUNCTION-RESULT-TYPE)(DEFPROP 1-NUMBERFUNCTION-RESULT-TYPE)(DEFPROP *NUMBERFUNCTION-RESULT-TYPE)(DEFPROP CHARACTER    CHARACTERFUNCTION-RESULT-TYPE)(DEFPROP INT-CHAR     CHARACTERFUNCTION-RESULT-TYPE)(DEFPROP SI:COERCE-TO-CHARACTER CHARACTER FUNCTION-RESULT-TYPE)(DEFPROP TAGBODYNULLFUNCTION-RESULT-TYPE)(DEFPROP FUNCTION FUNCTION FUNCTION-RESULT-TYPE)(DEFPROP BREAKOFF-FUNCTIONFUNCTION FUNCTION-RESULT-TYPE)(DEFPROP LEXICAL-CLOSUREFUNCTION FUNCTION-RESULT-TYPE)(DEFPROP FIND-SYMBOL (VALUES SYMBOL SYMBOL PACKAGE) FUNCTION-RESULT-TYPE)(DEFPROP NOTT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP ATOMT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP EQT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP EQLT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP EQUALT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP EQUALPT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP INTERNAL-<T-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP INTERNAL->T-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP INTERNAL-=T-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP <T-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP >T-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP =T-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP NUMBERPT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP REALPT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP INTEGERPT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP FIXNUMPT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP FLOATPT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP COMPLEXPT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP ZEROPT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP MINUSPT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP PLUSPT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP CHARACTERPT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP SYMBOLPT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP GLOBAL:LISTPT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP COMMON-LISP-LISTP T-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP LISTPT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP ENDPT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP STRINGPT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP STRING=T-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP STRING-EQUALT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP %STRING-EQUALT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP GLOBAL:STRING=T-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP GLOBAL:STRING-EQUAL T-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP ARRAYPT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP VECTORPT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP BOUNDPT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP FBOUNDPT-OR-NILFUNCTION-RESULT-TYPE);; The following 5 added 12/8/86(DEFPROP INTERNAL-CHAR-EQUAL T-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP CHAR-EQUALT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP CHAR-NOT-EQUALT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP CHAR-GREATERPT-OR-NILFUNCTION-RESULT-TYPE)(DEFPROP CHAR-LESSPT-OR-NILFUNCTION-RESULT-TYPE);;;   ---  Common Lisp special variables  ---(PROCLAIM '(TYPE (INTEGER 2 36) *READ-BASE* *PRINT-BASE*))(PROCLAIM '(TYPE STREAM *STANDARD-INPUT* *STANDARD-OUTPUT* *QUERY-IO* *DEBUG-IO*        *TERMINAL-IO* *TRACE-OUTPUT*));;;   ---  Zetalisp special variables  ---(PROCLAIM '(TYPE (INTEGER 2 36) IBASE BASE))(PROCLAIM '(TYPE STREAM STANDARD-INPUT STANDARD-OUTPUT QUERY-IO DEBUG-IO        TERMINAL-IO TRACE-OUTPUT))Given the name of a misc-op, return the code that represents it in the LAP code."  ;; 10/11/86 - Original.  (IF (COMPILING-FOR-V2)      (MISC-OP-EVAL MISC-NAME)    (LAP-VALUE MISC-NAME)))#+compiler:debug ; for compatibility with release 1 and 2 DEFMIC file.;World-load version of DEFMIC. (Other versions in COLD-BAND;PARAMETERS and micro-assembler.);Store into MICRO-CODE-ENTRY-ARGLIST-AREA;Put on QLVAL and QINTCMP properties(DEFMACRO DEFMIC (NAME OPCODE ARGLIST  &OPTIONAL (LISP-FUNCTION-P T) (NOT-LISP-CALLABLE-P NIL))  "Define a function that is microcoded.  Used only in SYS:COLD-BAND;DEFMIC."  ;;  6/26/85 - MISC-INSN property doesn't need to be target-dependent.  ;;  7/01/85 - Avoid storing redundant ARGLIST pro