;;; -*- Mode:Common-Lisp; Package:Compiler; Base:10 -*-

;;;			      RESTRICTED RIGHTS LEGEND
;;;
;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;			TEXAS INSTRUMENTS INCORPORATED.
;;;				 P.O. BOX 2909
;;;			      AUSTIN, TEXAS 78769
;;;				    MS 2151
;;;
;;; Copyright (C) 1986-1989 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 done after Explorer release 3.0 ------
;;;  6/24/87 DNG - Correct type declaration for *PRINT-BASE* [SPR 5023] and 
;;;		declare *ERROR-OUTPUT* to be type STREAM.
;;;  7/08/87 DNG - Fix CANONICALIZE-TYPE-FOR-COMPILER for SPR 5777.
;;;------------------ The following done after Explorer release 3.1 ------
;;;  9/29/87 DNG - Fix CANONICALIZE-TYPE-FOR-COMPILER for SPR 6572.
;;;------------------ The following done for Explorer release 4.0 ------
;;;  1/16/88 DNG - Fix CANONICALIZE-TYPE-FOR-COMPILER for SPR 6977.
;;;  2/22/88 CLM - Fix EXPR-TYPE-P for SPR 7312.
;;;------------------ The following done for Explorer release 4.1 ------
;;;  4/07/88 DNG - Fix CANONICALIZE-TYPE-FOR-COMPILER for SPR 7746.
;;;------------------ The following done for Explorer release 5.0 ------
;;;  8/04/88 DNG - Added a few more patterns.
;;;------------------ The following done for Explorer release 6.0 ------
;;;  2/17/89 DNG - Remove obsolete code for VM1.
;;;  3/15/89 DNG - Update CANONICALIZE-TYPE-FOR-COMPILER for CLOS.
;;;  4/28/89 DNG - Add environment argument to calls to TYPE-SPECIFIER-P, 
;;;		SUBTYPEP, and TYPE-CANONICALIZE.
;;;  5/03/89 DNG - Declared some more functions that return lists.
;;; ---------

;; 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.
  ;;  4/13/89 DNG - Adding setting of the OPTIMIZED-INTO property.
  (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 ))
    (UNLESS (OR (NULL CONDITION) (ATOM REPLACEMENT))
      (LET ((INTO (CAR REPLACEMENT)))
	(WHEN (AND (SYMBOLP INTO) (NOT (GET INTO 'P2)) (NOT (EQ INTO FUNCTION-NAME)))
	  (PUSH-NEW-PROPERTY FUNCTION-NAME INTO 'OPTIMIZED-INTO))))
    (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 )

(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.
  ;;  8/04/88 DNG - Optimize MAPCAR on NIL.  One more case of POSITION* to 
  ;;		STRING-SEARCH-CHAR.  Optimize STORE-CONDITIONAL for SPR 7645.
  ;;  2/17/89 DNG - Remove obsolete VM1 stuff.
  ;;  3/16/89 DNG - Add patterns for SI:STRING=*, GET-FROM-ENVIRONMENT, and SETPROP-IN-ENVIRONMENT .
  ;;  4/29/89 DNG - Add patterns for COERCE to FUNCTION (for ANSI CL).
  ;;  5/01/89 DNG - Add patterns for CONSTANTLY (for ANSI CL).
  ;;  5/07/89 DNG - Temporarily over-ride inline expansion of the STRING function. [SPR 9535]
  
  ;;  ---  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))
 (OPTIMIZE-PATTERN (CONCATENATE 'VECTOR VECTOR VECTOR VECTOR) (STRING-APPEND 2 3 4))
 (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 (DEL #'EQUAL T T T)		(GLOBAL:DELETE 2 3 4))

 (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)	)
 (OPTIMIZE-PATTERN (FILL T T ':START T) 	(SI:FILL* 1 2 4))
 (OPTIMIZE-PATTERN (FILL T T ':END T)		(SI:FILL* 1 2 '0 4))
 (OPTIMIZE-PATTERN (FILL T T ':START T ':END T) (SI:FILL* 1 2 4 6))
 (OPTIMIZE-PATTERN (FILL T T ':END T ':START T) (SI:FILL* 1 2 6 4))

 (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 (MAPCAR T 'NIL)		(PROGN 1 'NIL))

 (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)

 (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 (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 #'CHAR-EQUAL 'NIL 'NIL T T)
		   (STRING-SEARCH-CHAR 1 2 6 7)) ; added 8/4/88 DNG
 (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 (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 (REVERSE LIST)	(SI:REVERSE-LIST 1))
 (OPTIMIZE-PATTERN (REVERSE VECTOR)	(SI:REVERSE-VECTOR 1))
 (OPTIMIZE-PATTERN (NREVERSE LIST)	(SI:NREVERSE-LIST 1))
 (OPTIMIZE-PATTERN (NREVERSE VECTOR)	(SI:NREVERSE-VECTOR 1))

 (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  ---

 #.(when (<= (get-system-version :system) 6) ; temporary until SYS:STRING-AUX is defined in the previous release.
     '(WHEN (NULL (GET 'STRING 'POST-OPTIMIZERS)) ; this one must be defined first so invoked last
	(OPTIMIZE-PATTERN (STRING T) (FUNCALL #'(LAMBDA (X)
						  (COND ((SYMBOLP X) (SYMBOL-NAME X))
							((STRINGP X) X)
							(T (DONT-OPTIMIZE (STRING X)))))
					      1))))
 (OPTIMIZE-PATTERN (STRING STRING)	(PROGN 1))
 (OPTIMIZE-PATTERN (STRING SYMBOL)	(SYMBOL-NAME 1))

 (OPTIMIZE-PATTERN (STRING-SEARCH STRING STRING)
		   (SI:SEARCH*-STRING-NOCASE 1 2))
 (OPTIMIZE-PATTERN (STRING-SEARCH STRING STRING T T)
		   (SI:SEARCH*-STRING-NOCASE 1 2 3 4))
 (OPTIMIZE-PATTERN (STRING-SEARCH STRING STRING T T T T 'NIL)
		   (SI:SEARCH*-STRING-NOCASE 1 2 3 4 5 6))
 (OPTIMIZE-PATTERN (STRING-SEARCH STRING STRING T T T T (PASSES ALWAYS-TRUE))
		   (SI:SEARCH*-STRING-CASE 1 2 3 4 5 6))

 (OPTIMIZE-PATTERN (STRING-REVERSE-SEARCH STRING STRING)
		   (SI:SEARCH*-STRING-NOCASE-FROMEND 1 2))
 (OPTIMIZE-PATTERN (STRING-REVERSE-SEARCH STRING STRING T T T T 'NIL)
		   (SI:SEARCH*-STRING-NOCASE-FROMEND 1 2 4 3 5 6))
 (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))

  ;;  ---  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))

 (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))

 ;; 11/23/88 - added these for optimizing expansion of SYS:GET-FLAVOR.
 (OPTIMIZE-PATTERN (GET-FROM-ENVIRONMENT T T T 'NIL) (GET 1 2 3))
 (OPTIMIZE-PATTERN (SETPROP-IN-ENVIRONMENT T T T 'NIL T) (SYS:SETPROP 1 2 5))

 (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 (SI:STRING=* STRING STRING)	(EQUAL 1 2))

 (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))

 (OPTIMIZE-PATTERN (STORE-CONDITIONAL LOCATIVE T T)
		   (%STORE-CONDITIONAL 1 2 3)) ; added 8/4/88 by DNG for SPR 7645

 (OPTIMIZE-PATTERN (COERCE FUNCTION 'FUNCTION)	(PROGN 1))
 (OPTIMIZE-PATTERN (COERCE SYMBOL 'FUNCTION)	(SYMBOL-FUNCTION 1))

 (OPTIMIZE-PATTERN (SYS:CONSTANTLY 'NIL)	(PROGN #'IGNORE))
 (OPTIMIZE-PATTERN (SYS:CONSTANTLY 'T)		(PROGN #'SYS:CONSTANTLY-T))
 (OPTIMIZE-PATTERN (SYS:CONSTANTLY '0)		(PROGN #'SYS:CONSTANTLY-0))

 ;;  ---  more generic sequence optimizations  --- 

 (OPTIMIZE-PATTERN (ADJOIN T T ':TEST T)   (SI:ADJOIN-TEST 1 2 4))
 (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))
 (OPTIMIZE-PATTERN (SI:SUBST* T T T #'EQL)              (SI:SUBST-EQL 1 2 3))
 (OPTIMIZE-PATTERN (SI:SUBST* T T T #'EQUAL)            (SI:SUBST-EQUAL 1 2 3))
 
 (OPTIMIZE-PATTERN (SUBST-IF T T T)             (SI:SUBST-IF* 1 2 3))
 (OPTIMIZE-PATTERN (SUBST-IF T T T ':KEY T)     (SI:SUBST-IF* 1 2 3 5))
 (OPTIMIZE-PATTERN (SUBST-IF-NOT T T T)         (SI:SUBST-IF-NOT* 1 2 3)) 
 (OPTIMIZE-PATTERN (SUBST-IF-NOT T T T ':KEY T) (SI:SUBST-IF-NOT* 1 2 3 5) )

 (OPTIMIZE-PATTERN (NSUBST-IF T T T)             (SI:NSUBST-IF* 1 2 3) )
 (OPTIMIZE-PATTERN (NSUBST-IF T T T ':KEY T)     (SI:NSUBST-IF* 1 2 3 5) )
 (OPTIMIZE-PATTERN (NSUBST-IF-NOT T T T)         (SI:NSUBST-IF-NOT* 1 2 3))
 (OPTIMIZE-PATTERN (NSUBST-IF-NOT T T T ':KEY T) (SI:NSUBST-IF-NOT* 1 2 3 5))

 (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))
 (OPTIMIZE-PATTERN (MEMBER-IF T T ':KEY T)	(SI:MEMBER-IF* 1 2 4))
 (OPTIMIZE-PATTERN (MEMBER-IF-NOT T T)		(SI:MEMBER-IF-NOT* 1 2))
 (OPTIMIZE-PATTERN (MEMBER-IF-NOT T T ':KEY T) (SI:MEMBER-IF-NOT* 1 2 4))

 (VALUES)
); end of DEFINE-PATTERNS

(DEFINE-PATTERNS)
(FMAKUNBOUND 'DEFINE-PATTERNS) ; this only needs to be called once.

(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.
  ;; 11/05/87 - Check (SI:TYPE-SPECIFIER-P FORM-TYPE) before doing (TYPEP 'NIL FORM-TYPE). [SPR 6875]
  ;;  2/24/88 - If OPT-SAFETY is 3, do not allow optimizations. [SPR 7312]
  ;;  2/17/89 - Add recognition of MAKE-INSTANCE.
  ;;  4/10/89 - Use new function VAR-INIT-FORM .
  ;;  4/17/89 - Recognize that (FORMAT NIL ...) returns a string.
  ;;  4/25/89 - Add handling for %STANDARD-INSTANCE-REF and STANDARD-INSTANCE-ACCESS.
  ;;  4/26/89 - Add handling for %LET and %LET*.
  ;;  4/28/89 - Add use of *LOOP-VAR-BIT* to criteria for using the initial 
  ;;		value of a local variable.  Add special handling for SELF in a flavor 
  ;;		method.
  ;;  5/02/89 - Add handling for calls to SETF and LOCF functions.
  ;;  5/05/89 - Add handling for SET-AR-1 etc.
  ;;  5/09/89 - Check VAR-USE-COUNT before *LOOP-VAR-BIT* so it doesn't trap 
  ;;		on that variable being unbound when called from P2SELECT.
  (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) )
		  ((OR (= (OPT-SAFETY OPTIMIZE-SWITCH) 3)
		       (> (OPT-SAFETY OPTIMIZE-SWITCH)
			  (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)))
		   ;; Don't rely on user's declarations.
		   (GO NOTHING-KNOWN))
		  ((EQ FORM 'SELF)
		   (IF (AND SELF-FLAVOR-DECLARATION ; in a flavor method
			    (NULL (LOOKUP-VAR FORM))) ; a free reference
		       (PROGN (SETQ FORM-TYPE (CAR SELF-FLAVOR-DECLARATION))
			      (GO TYPE-KNOWN))
		     (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 (OR (= (OPT-SAFETY OPTIMIZE-SWITCH) 3)
			 (> (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 (VAR-DATA-TYPE V))
		     (WHEN (AND (EQ FORM-TYPE 'T)
				(MEMBER (VAR-INIT-KIND V) '(FEF-INI-COMP-C FEF-INI-SETQ)) ; not an argument
				;; If there is no possibility that the value has been altered,
				;; we can use the type of the initial value expression.
				(OR (MEMBER 'FEF-ARG-NOT-ALTERED (VAR-MISC V))
				    (AND (MEMBER (VAR-USE-COUNT V) '(NIL 0)) ; no assignment yet
					 (>= (CDDR FORM) *LOOP-VAR-BIT*)) ; not in a loop
				    (EQ (VAR-NAME V) '.VALUE.) ; used in type checking code
				    ))
		       (SETQ FORM (VAR-INIT-FORM 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 %LET*
		  SET-AR-1 SET-AR-2 SET-AR-3 SET-AREF)
		 ;; 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 *COMPILE-FILE-ENVIRONMENT*))
				   ((SUBTYPEP FORM-TYPE EXP-TYPE *COMPILE-FILE-ENVIRONMENT*)
				    (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)
				     (AND (TYPE-SPECIFIER-P FORM-TYPE *COMPILE-FILE-ENVIRONMENT*)
					  ;; FORM-TYPE acceptable to TYPEP [could be (VALUES ...) or (FUNCTION ...)]
					  (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))
			 (CASE (CAR-SAFE (SECOND FN))
			   ( SETF (SETQ FORM (THIRD FORM))
				  (GO START-OVER-WITH-NEW-FORM))
			   ( LOCF (SETQ FORM-TYPE 'LOCATIVE)
				  (GO TYPE-KNOWN))
			   (OTHERWISE (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)))))
		( MAKE-INSTANCE
		 (SETQ FORM-TYPE (IF (QUOTEP (SECOND FORM))
				     (SECOND (SECOND FORM))
				   '(NOT NULL)))
		 (GO TYPE-KNOWN))
		( %STANDARD-INSTANCE-REF
		 ;; (%STANDARD-INSTANCE-REF object mapping-table class-name slot-name)
		 (LET* ((CLASS (TICLOS:CLASS-NAMED (FOURTH FORM) T *COMPILE-FILE-ENVIRONMENT*))
			(SD (AND CLASS (FIND (FIFTH FORM) (IF (CLOS:CLASS-FINALIZED-P CLASS)
							      (TICLOS:CLASS-SLOTS CLASS)
							    (TICLOS:CLASS-DIRECT-SLOTS CLASS))
					     :KEY #'TICLOS:SLOT-DEFINITION-NAME :TEST #'EQ))))
		   (IF (NULL SD)
		       (GO NOTHING-KNOWN)
		     (PROGN (SETQ FORM-TYPE (TICLOS:SLOT-DEFINITION-TYPE SD))
			    (GO TYPE-KNOWN)))))
		( TICLOS:STANDARD-INSTANCE-ACCESS 
		 ;; (STANDARD-INSTANCE-ACCESS object slot-name)
		 (IF (QUOTEP (THIRD FORM))
		     (LET ((TYPE (TYPE-OF-EXPRESSION (SECOND FORM))))
		       (IF (EQ TYPE 'T)
			   (GO NOTHING-KNOWN)
			 (LET* ((CLASS (TICLOS:CLASS-NAMED TYPE T *COMPILE-FILE-ENVIRONMENT*))
				(SD (AND CLASS (FIND (SECOND (THIRD FORM))
						     (IF (TICLOS:CLASS-FINALIZED-P CLASS)
							 (TICLOS:CLASS-SLOTS CLASS)
						       (TICLOS:CLASS-DIRECT-SLOTS CLASS))
						     :KEY #'TICLOS:SLOT-DEFINITION-NAME :TEST #'EQ))))
			   (IF (NULL SD)
			       (GO NOTHING-KNOWN)
			     (PROGN (SETQ FORM-TYPE (TICLOS:SLOT-DEFINITION-TYPE SD))
				    (GO TYPE-KNOWN))))))
		   (GO NOTHING-KNOWN)))
		( THE
		 (SETQ FORM-TYPE (SECOND FORM))
		 (GO TYPE-KNOWN))
		( FORMAT
		 (IF (EQUAL (SECOND FORM) '(QUOTE NIL))
		     (PROGN (SETQ FORM-TYPE 'STRING) (GO TYPE-KNOWN))
		   (GO NOTHING-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 *COMPILE-FILE-ENVIRONMENT*))))
		;; Not obvious; have to do it the hard way.
		(T (SUBTYPEP FORM-TYPE TYPE *COMPILE-FILE-ENVIRONMENT*) )))
	
     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 NUMBER
		STRING VECTOR ARRAY
		CONS NULL LIST
		T-OR-NIL SYMBOL
		CHARACTER 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.
  ;;  7/08/87 DNG - Fix to accept FUNCTION types.  [SPR 5777]
  ;;  9/29/87 DNG - Fix for FUNCTION in OR types.  [SPR 6572]
  ;;  1/16/88 DNG - Add handling for name defined by DEFTYPE to be a FUNCTION 
  ;;		type. [SPR 6977]  Permit returning (FUNCTION ...) type list since 
  ;;		EXPR-TYPE-P can now handle it.
  ;;  4/07/88 DNG - Use GETDECL instead of GET.  [SPR 7746]
  ;;  8/15/88 DNG - Return CLOS class names instead of T.
  ;; 10/25/88 DNG - Reference BUILT-IN-CLASS instead of STANDARD-TYPE-CLASS.
  ;; 12/19/88 DNG - Suppress warning on undefined types in a DEFSUBST.  [SPR 9150]
  ;;  4/25/89 DNG - Permit returning a class object.
 (MULTIPLE-VALUE-BIND (USABLEP LEGALP)
      (TYPE-SPECIFIER-P TYPE *COMPILE-FILE-ENVIRONMENT*)
  (COND (USABLEP ; fully defined
	 (IF (AND (SYMBOLP TYPE)
		  (MEMBER TYPE INTERESTING-TYPES :TEST #'EQ))
	     TYPE
	   (LET ((CANONIZED (TYPE-CANONICALIZE TYPE *COMPILE-FILE-ENVIRONMENT*)))
	     (DOLIST (X INTERESTING-TYPES)
	       (WHEN (SUBTYPEP CANONIZED X *COMPILE-FILE-ENVIRONMENT*)
		 (RETURN-FROM CANONICALIZE-TYPE-FOR-COMPILER
		   (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))))
	     (LET ((CLASS (IF (SYS:CLASSP TYPE)
			      TYPE
			    (AND (SYMBOLP TYPE)
				 (FBOUNDP 'TICLOS:CLASS-NAMED)
				 (TICLOS:CLASS-NAMED TYPE T *COMPILE-FILE-ENVIRONMENT*)))))
	       (COND ((NULL CLASS) T)
		     ((TYPEP-STRUCTURE-OR-FLAVOR CLASS 'TICLOS:BUILT-IN-CLASS) T)
		     (T CLASS))))))
	 ((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 with
			DO (RETURN-FROM CANONICALIZE-TYPE-FOR-COMPILER 'UNKNOWN)
			ELSE
			COLLECT (CANONICALIZE-TYPE-FOR-COMPILER ITEM CONTEXT NIL)))))
	 ((EQ TYPE 'FUNCTION)
	  ;; Legal for declarations even though TYPEP doesn't currently accept it [ref SPR 5778].
	  T) ; not currently interesting.
	 ((AND (CONSP TYPE)
	       (EQ (FIRST TYPE) 'FUNCTION)
	       (= (LENGTH TYPE) 3)
	       (LISTP (SECOND TYPE)))
	  ;; Legal for declarations even though TYPEP doesn't accept it.
	  (LIST (FIRST TYPE)
		(LET ((KEY NIL))
		  (LOOP FOR ITEM IN (SECOND TYPE)	; argument types
			COLLECT (COND ((MEMBER ITEM LAMBDA-LIST-KEYWORDS :TEST #'EQ)
				       (WHEN (EQ ITEM '&KEY) (SETQ KEY T))
				       ITEM)
				      ((AND KEY (LISTP ITEM) (SYMBOLP (FIRST ITEM)))
				       (LIST (FIRST ITEM)
					     (CANONICALIZE-TYPE-FOR-COMPILER (SECOND ITEM) TYPE)))
				      (T (CANONICALIZE-TYPE-FOR-COMPILER ITEM TYPE)))))
		(CANONICALIZE-TYPE-FOR-COMPILER (THIRD TYPE) TYPE T) ; result type
		))
	 (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)
	 ((AND (SYMBOLP TYPE)
	       (GETDECL TYPE 'SI:TYPE-EXPANDER NIL *COMPILE-FILE-ENVIRONMENT*))
	  ;; Here for a name defined by DEFTYPE to be a FUNCTION type.  [SPR 6977]
	  (CANONICALIZE-TYPE-FOR-COMPILER (TYPE-CANONICALIZE TYPE *COMPILE-FILE-ENVIRONMENT*)
					  CONTEXT VALUES-PERMITTED-P))
	 ((AND (MEMBER (CAR-SAFE TYPE) '(OR AND) :TEST #'EQ)
	       (CONSP (CDR TYPE)))
	  ;; If one of the elements of the OR is a FUNCTION type, TYPE-SPECIFIER-P 
	  ;; will have rejected it, but we still need to allow it.  [SPR 6572]
	  (LET ((UNION NIL))
	    (DOLIST (X (REST TYPE))
	      (LET ((CANONIZED (CANONICALIZE-TYPE-FOR-COMPILER X TYPE VALUES-PERMITTED-P)))
		(COND ((SUBTYPEP CANONIZED UNION *COMPILE-FILE-ENVIRONMENT*))
		      ((SUBTYPEP UNION CANONIZED *COMPILE-FILE-ENVIRONMENT*)
		       (SETQ UNION CANONIZED))
		      (T (SETQ UNION T)) )))
	    UNION))
	 (T ;; Permit forward type references in a DEFSUBST since the type may be known when it is expanded.
	    (unless (and (symbolp type) (compiland-subst-flag *current-compiland*))
	      (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.
  ;;  4/28/89 DNG - Show original type in error message.
  ;;  5/03/89 DNG - Save the original type in the DECLARED-TYPE property.
  (LET ((CANON (CANONICALIZE-TYPE-FOR-COMPILER TYPE 'PROCLAIM)))
    (UNLESS (OR (EQ CANON 'UNKNOWN)
		(EQ CANON 'NIL))
      (DOLIST (NAME VAR-NAMES)
	(IF (SYMBOLP NAME)
	    (IF UNDO-DECLARATIONS-FLAG
		(SETF (GETDECL NAME 'VARIABLE-TYPE) CANON
		      (GETDECL NAME 'DECLARED-TYPE) TYPE)
	      (PROGN (SETF (GET-FOR-TARGET NAME 'VARIABLE-TYPE) CANON)
		     (IF (AND (EQUAL TYPE CANON)
			      (EQ TARGET-PROCESSOR HOST-PROCESSOR))
			 (REMPROP NAME 'DECLARED-TYPE)
		       (SETF (GET-FOR-TARGET NAME 'DECLARED-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.
  ;;  4/28/89 DNG - Support (DECLARE (FUNCTION {var-name}*)).
  ;;  5/02/89 DNG - Add recording for non-symbol function specs.
  (BLOCK ESCAPE
    (LET ( ARG-TYPES RESULT-TYPE FUNCTION-NAMES )
      (CASE (FIRST DECL)
	    ( FTYPE
	     (SETQ FUNCTION-NAMES (CDDR DECL))
	     (LET (( FUNCTION-TYPE (TYPE-CANONICALIZE (SECOND DECL) *COMPILE-FILE-ENVIRONMENT*)))
	       (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))
	     (WHEN (OR (NULL (CDDR DECL))
		       (AND (SYMBOLP ARG-TYPES) (NOT (NULL ARG-TYPES))))
	       ;; Must be using (DECLARE (FUNCTION X Y Z)) as an abbreviation for
	       ;; (DECLARE (TYPE FUNCTION X Y Z)).  This isn't consistent with my 
	       ;; interpretation of CLtL, but it has been adopted by X3J13.
	       (WHEN (EQ LOCAL-FUNCTION-ALIST 'GLOBAL) ; if called from PROCLAIM
		 (RECORD-SPECIAL-VAR-TYPE (FIRST DECL) (REST DECL)))
	       ;; Else just ignore it here; PROCESS-BINDING-DECLARATIONS will handle it.
	       (RETURN-FROM ESCAPE))
	     (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))
					(TYPE-SPECIFIER-P (SECOND ARG) *COMPILE-FILE-ENVIRONMENT*))
				   (TYPE-SPECIFIER-P ARG *COMPILE-FILE-ENVIRONMENT*))
			 (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 (VAR-DATA-TYPE (SECOND TEMP)) 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)
	       (WHEN (AND (EQ TARGET-PROCESSOR HOST-PROCESSOR)
			  (LISTP ARG-TYPES)
			  (NOT (DECLARED-DEFINITION FUNCTION-NAME)))
		 ;; record for COMPILATION-DEFINEDP .
		 (FUNCTION-SPEC-PUTPROP-IN-ENVIRONMENT
		   FUNCTION-NAME ARG-TYPES 'FUNCTION-ARG-TYPES *LOCAL-ENVIRONMENT*)
		 ))
	      (T (WARN 'DECLARE-FTYPE :IGNORABLE-MISTAKE
		       "Invalid function spec ~S in declaration ~S."
		       FUNCTION-NAME DECL))))))
  LOCAL-DECLS)

(DEFPROP RETURN-FROM	NIL	FUNCTION-RESULT-TYPE)
(DEFPROP GO		NIL	FUNCTION-RESULT-TYPE)
(DEFPROP *THROW		NIL	FUNCTION-RESULT-TYPE)
(DEFPROP THROW		NIL	FUNCTION-RESULT-TYPE)

(DEFPROP MAKE-ARRAY		ARRAY   FUNCTION-RESULT-TYPE)
(DEFPROP SI:SIMPLE-MAKE-ARRAY	ARRAY	FUNCTION-RESULT-TYPE)
(DEFPROP SI:COERCE-TO-ARRAY-OPTIMIZED ARRAY FUNCTION-RESULT-TYPE)
(DEFPROP VECTOR			VECTOR	FUNCTION-RESULT-TYPE)
(DEFPROP STRING-APPEND		VECTOR	FUNCTION-RESULT-TYPE)
(DEFPROP STRING-NCONC		VECTOR	FUNCTION-RESULT-TYPE)
(DEFPROP SI:REVERSE-VECTOR	VECTOR	FUNCTION-RESULT-TYPE)
(DEFPROP SI:DELETE-VECTOR	VECTOR	FUNCTION-RESULT-TYPE)
(DEFPROP SI:DELETE-IF-VECTOR	VECTOR	FUNCTION-RESULT-TYPE)
(DEFPROP SI:DELETE-IF-NOT-VECTOR VECTOR	FUNCTION-RESULT-TYPE)
(DEFPROP SI:REMOVE-VECTOR	VECTOR	FUNCTION-RESULT-TYPE)
(DEFPROP SI:REMOVE-IF-VECTOR	VECTOR	FUNCTION-RESULT-TYPE)
(DEFPROP SI:REMOVE-IF-NOT-VECTOR VECTOR	FUNCTION-RESULT-TYPE)
(DEFPROP SI:DELETE-DUPLICATES-VECTOR VECTOR FUNCTION-RESULT-TYPE)
(DEFPROP SI:REMOVE-DUPLICATES-VECTOR VECTOR FUNCTION-RESULT-TYPE)

(DEFPROP STRING			STRING	FUNCTION-RESULT-TYPE)
(DEFPROP MAKE-STRING		STRING	FUNCTION-RESULT-TYPE)
(DEFPROP SYMBOL-NAME		STRING	FUNCTION-RESULT-TYPE)
(DEFPROP SUBSTRING 		STRING	FUNCTION-RESULT-TYPE)
(DEFPROP NSUBSTRING 		STRING	FUNCTION-RESULT-TYPE)
(DEFPROP STRING-TRIM 		STRING	FUNCTION-RESULT-TYPE)
(DEFPROP STRING-LEFT-TRIM	STRING	FUNCTION-RESULT-TYPE)
(DEFPROP STRING-RIGHT-TRIM	STRING	FUNCTION-RESULT-TYPE)
(DEFPROP STRING-REMOVE-FONTS	STRING	FUNCTION-RESULT-TYPE)
(DEFPROP STRING-PLURALIZE	STRING	FUNCTION-RESULT-TYPE)
(DEFPROP STRING-SELECT-A-OR-AN	STRING	FUNCTION-RESULT-TYPE)
(DEFPROP STRING-APPEND-A-OR-AN	STRING	FUNCTION-RESULT-TYPE)
(DEFPROP SUBSTRING-AFTER-CHAR	STRING	FUNCTION-RESULT-TYPE)
(DEFPROP PRIN1-TO-STRING	STRING	FUNCTION-RESULT-TYPE)
(DEFPROP PRINC-TO-STRING	STRING	FUNCTION-RESULT-TYPE)
(DEFPROP WRITE-TO-STRING	STRING	FUNCTION-RESULT-TYPE)

(DEFPROP LIST		LIST	FUNCTION-RESULT-TYPE)
(DEFPROP LIST*		LIST	FUNCTION-RESULT-TYPE)
(DEFPROP MAKE-LIST	LIST	FUNCTION-RESULT-TYPE)
(DEFPROP %MAKE-LIST	LIST	FUNCTION-RESULT-TYPE)
(DEFPROP APPEND		LIST	FUNCTION-RESULT-TYPE)
(DEFPROP SI:*APPEND	LIST	FUNCTION-RESULT-TYPE)
(DEFPROP NCONC		LIST	FUNCTION-RESULT-TYPE)
(DEFPROP SI:*NCONC	LIST	FUNCTION-RESULT-TYPE)
(DEFPROP COPY-LIST	LIST	FUNCTION-RESULT-TYPE)
(DEFPROP COPY-TREE	LIST	FUNCTION-RESULT-TYPE)
(DEFPROP SI:COERCE-TO-LIST LIST	FUNCTION-RESULT-TYPE)
(DEFPROP FIRSTN		LIST	FUNCTION-RESULT-TYPE)
(DEFPROP DELQ		LIST	FUNCTION-RESULT-TYPE)
(DEFPROP REMQ		LIST	FUNCTION-RESULT-TYPE)
(DEFPROP MEMBER		LIST	FUNCTION-RESULT-TYPE)
(DEFPROP MEMQ		LIST	FUNCTION-RESULT-TYPE)
(DEFPROP SI:MEMBER-EQL	LIST	FUNCTION-RESULT-TYPE) 
(DEFPROP SI:MEMBER*	LIST	FUNCTION-RESULT-TYPE) ; 5/3/89
(DEFPROP SI:MEMBER-TEST	LIST	FUNCTION-RESULT-TYPE) ; 5/3/89
(DEFPROP MAPLIST	LIST	FUNCTION-RESULT-TYPE)
(DEFPROP MAPCAR		LIST	FUNCTION-RESULT-TYPE)
(DEFPROP MAPCON		LIST	FUNCTION-RESULT-TYPE)
(DEFPROP MAPCAN		LIST	FUNCTION-RESULT-TYPE)
(DEFPROP SI:REVERSE-LIST	LIST	FUNCTION-RESULT-TYPE)
(DEFPROP SI:DELETE-LIST		LIST	FUNCTION-RESULT-TYPE)
(DEFPROP SI:DELETE-LIST-EQ	LIST	FUNCTION-RESULT-TYPE)
(DEFPROP SI:DELETE-LIST-EQL	LIST	FUNCTION-RESULT-TYPE)
(DEFPROP SI:DELETE-LIST-EQUAL	LIST	FUNCTION-RESULT-TYPE)
(DEFPROP SI:DELETE-IF-LIST	LIST	FUNCTION-RESULT-TYPE)
(DEFPROP SI:DELETE-IF-NOT-LIST	LIST	FUNCTION-RESULT-TYPE)
(DEFPROP SI:REMOVE-LIST		LIST	FUNCTION-RESULT-TYPE)
(DEFPROP SI:REMOVE-LIST-EQ	LIST	FUNCTION-RESULT-TYPE)
(DEFPROP SI:REMOVE-LIST-EQL	LIST	FUNCTION-RESULT-TYPE)
(DEFPROP SI:REMOVE-LIST-EQUAL	LIST	FUNCTION-RESULT-TYPE)
(DEFPROP SI:REMOVE-IF-LIST	LIST	FUNCTION-RESULT-TYPE)
(DEFPROP SI:REMOVE-IF-NOT-LIST	LIST	FUNCTION-RESULT-TYPE)
(DEFPROP SI:DELETE-DUPLICATES-LIST LIST	FUNCTION-RESULT-TYPE)
(DEFPROP SI:DELETE-DUPLICATES-LIST-EQL LIST FUNCTION-RESULT-TYPE)
(DEFPROP SI:REMOVE-DUPLICATES-LIST LIST	FUNCTION-RESULT-TYPE)
(DEFPROP SI:REMOVE-DUPLICATES-LIST-EQL LIST FUNCTION-RESULT-TYPE)

;; 5/3/89 DNG added next 8
(DEFPROP SI:UNION*		LIST FUNCTION-RESULT-TYPE)
(DEFPROP SI:NUNION*		LIST FUNCTION-RESULT-TYPE)
(DEFPROP SI:INTERSECTION*	LIST FUNCTION-RESULT-TYPE)
(DEFPROP SI:NINTERSECTION*	LIST FUNCTION-RESULT-TYPE)
(DEFPROP SI:SET-DIFFERENCE*	LIST FUNCTION-RESULT-TYPE)
(DEFPROP SI:NSET-DIFFERENCE*	LIST FUNCTION-RESULT-TYPE)
(DEFPROP SI:SET-EXCLUSIVE-OR* 	LIST FUNCTION-RESULT-TYPE)
(DEFPROP SI:NSET-EXCLUSIVE-OR*	LIST FUNCTION-RESULT-TYPE)

(DEFPROP CONS		CONS	FUNCTION-RESULT-TYPE)
(DEFPROP NCONS		CONS	FUNCTION-RESULT-TYPE)
(DEFPROP ADJOIN		CONS	FUNCTION-RESULT-TYPE)

(DEFPROP LENGTH		FIXNUM	FUNCTION-RESULT-TYPE)
(DEFPROP STRING-LENGTH	FIXNUM	FUNCTION-RESULT-TYPE)
(DEFPROP %DATA-TYPE    	FIXNUM	FUNCTION-RESULT-TYPE)
(DEFPROP LDB		FIXNUM	FUNCTION-RESULT-TYPE)
(DEFPROP SIGNED-LDB	FIXNUM	FUNCTION-RESULT-TYPE)
(DEFPROP CHAR-INT	FIXNUM	FUNCTION-RESULT-TYPE)
(DEFPROP COUNT		FIXNUM	FUNCTION-RESULT-TYPE)
(DEFPROP COUNT-IF	FIXNUM	FUNCTION-RESULT-TYPE)
(DEFPROP COUNT-IF-NOT	FIXNUM	FUNCTION-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 +		NUMBER	FUNCTION-RESULT-TYPE)
(DEFPROP -		NUMBER	FUNCTION-RESULT-TYPE)
(DEFPROP 1+		NUMBER	FUNCTION-RESULT-TYPE)
(DEFPROP 1-		NUMBER	FUNCTION-RESULT-TYPE)
(DEFPROP *		NUMBER	FUNCTION-RESULT-TYPE)

(DEFPROP CHARACTER    CHARACTER	FUNCTION-RESULT-TYPE)
(DEFPROP INT-CHAR     CHARACTER	FUNCTION-RESULT-TYPE)
(DEFPROP SI:COERCE-TO-CHARACTER CHARACTER FUNCTION-RESULT-TYPE)

(DEFPROP TAGBODY	NULL	FUNCTION-RESULT-TYPE)

(DEFPROP FUNCTION 		FUNCTION FUNCTION-RESULT-TYPE)
(DEFPROP BREAKOFF-FUNCTION	FUNCTION FUNCTION-RESULT-TYPE)
(DEFPROP LEXICAL-CLOSURE	FUNCTION FUNCTION-RESULT-TYPE)

(DEFPROP FIND-SYMBOL (VALUES SYMBOL SYMBOL PACKAGE) FUNCTION-RESULT-TYPE)
;;  4/26/89 DNG - Added the next 4.
(DEFPROP MAKE-SYMBOL	SYMBOL	FUNCTION-RESULT-TYPE)
(DEFPROP COPY-SYMBOL	SYMBOL	FUNCTION-RESULT-TYPE)
(DEFPROP GENSYM		SYMBOL	FUNCTION-RESULT-TYPE)
(DEFPROP GENTEMP	SYMBOL	FUNCTION-RESULT-TYPE)

(DEFPROP NOT		T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP ATOM		T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP EQ		T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP EQL		T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP EQUAL		T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP EQUALP		T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP INTERNAL-<	T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP INTERNAL->	T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP INTERNAL-=	T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP <		T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP >		T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP =		T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP NUMBERP	T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP REALP		T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP INTEGERP	T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP FIXNUMP	T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP FLOATP		T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP COMPLEXP	T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP ZEROP		T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP MINUSP		T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP PLUSP		T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP CHARACTERP	T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP SYMBOLP	T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP GLOBAL:LISTP	T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP COMMON-LISP-LISTP T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP LISTP		T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP ENDP		T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP STRINGP	T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP STRING=	T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP STRING-EQUAL	T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP %STRING-EQUAL	T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP GLOBAL:STRING=	T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP GLOBAL:STRING-EQUAL T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP ARRAYP		T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP VECTORP	T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP BOUNDP		T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP FBOUNDP	T-OR-NIL	FUNCTION-RESULT-TYPE)

;; The following 5 added 12/8/86
(DEFPROP INTERNAL-CHAR-EQUAL T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP CHAR-EQUAL	T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP CHAR-NOT-EQUAL	T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP CHAR-GREATERP	T-OR-NIL	FUNCTION-RESULT-TYPE)
(DEFPROP CHAR-LESSP	T-OR-NIL	FUNCTION-RESULT-TYPE)

(DEFPROP XOR		T-OR-NIL	FUNCTION-RESULT-TYPE) ; 12/16/88

;; The following 5 added 8/4/88 as part of SPR 7645.
(DEFPROP CAR-LOCATION		LOCATIVE	FUNCTION-RESULT-TYPE)
(DEFPROP VARIABLE-LOCATION	LOCATIVE	FUNCTION-RESULT-TYPE)
(DEFPROP ALOC			LOCATIVE	FUNCTION-RESULT-TYPE)
(DEFPROP AP-LEADER		LOCATIVE	FUNCTION-RESULT-TYPE)
(DEFPROP SI::CDR-LOCATION-FORCE	LOCATIVE	FUNCTION-RESULT-TYPE)


;;;   ---  Common Lisp special variables  ---

(PROCLAIM '(TYPE (INTEGER 2 36) *READ-BASE*))
(PROCLAIM '(TYPE (OR (INTEGER 2 36) SYMBOL) *PRINT-BASE*)) ; SI:PRINT-FIXNUM allows symbol

(PROCLAIM '(TYPE STREAM *STANDARD-INPUT* *STANDARD-OUTPUT* *QUERY-IO* *DEBUG-IO*
		        *TERMINAL-IO* *TRACE-OUTPUT* *ERROR-OUTPUT*))

;;;   ---  Zetalisp special variables  ---

(PROCLAIM '(TYPE (INTEGER 2 36) IBASE))
(PROCLAIM '(TYPE (OR (INTEGER 2 36) SYMBOL) BASE))
(PROCLAIM '(TYPE STREAM STANDARD-INPUT STANDARD-OUTPUT QUERY-IO DEBUG-IO
		        TERMINAL-IO TRACE-OUTPUT))