;;; -*- Mode:Common-Lisp; Package:COMPILER; Base:10; Patch-file:T -*-

;;; Reason: A couple more minor compiler fixes.

;;;                           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, M/S 2151             
;;;   AUSTIN, TEXAS 78769                 
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Patch file for REL6H version 6.15
;;; Written 05/08/89 23:28:42 by GRAY,
;;; while running on Kelvin from band LOD2
;;; With Inconsistent REL6H 6.14, Experimental SYSTEM 6.0, Experimental VIRTUAL-MEMORY 6.0,
;;;  Experimental EH 6.0, Experimental MAKE-SYSTEM 6.0, Experimental MICRONET 6.0,
;;;  Experimental LOCAL-FILE 6.0, Experimental BASIC-PATHNAME 6.0, Experimental NETWORK-SUPPORT-COLD 6.0,
;;;  Experimental BASIC-NAMESPACE 6.0, Experimental NETWORK-NAMESPACE 6.0, Experimental DISK-IO 6.0,
;;;  Experimental DISK-LABEL 6.0, Experimental BASIC-FILE 6.0, Experimental MAC-PATHNAME 6.0,
;;;  Experimental NETWORK-PATHNAME 6.0, Experimental COMPILER 6.0, Experimental TV 6.0,
;;;  Experimental DATALINK 6.0, Experimental CHAOSNET 6.0, Experimental GC 6.0, Experimental MEMORY-AUX 6.0,
;;;  Experimental NVRAM 6.0, Experimental SYSLOG 6.0, Experimental STREAMER-TAPE 6.0,
;;;  Experimental CLEH 1.0, Experimental UCL 6.0, Experimental INPUT-EDITOR 6.0, Experimental METER 6.0,
;;;  Experimental ZWEI 6.0, Experimental DEBUG-TOOLS 6.0, Experimental NETWORK-SUPPORT 6.0,
;;;  Experimental NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0, Experimental FONT-EDITOR 6.0,
;;;  Experimental SERIAL 6.0, Experimental PRINTER 6.0, Experimental MAC-PRINTER-TYPES 6.0,
;;;  Experimental PRINTER-TYPES 6.0, Experimental IMAGEN 6.0, Experimental SUGGESTIONS 6.0,
;;;  Experimental MAIL-DAEMON 6.0, Experimental MAIL-READER 6.0, Experimental TELNET 6.0,
;;;  Experimental VT100 6.0, Experimental NAMESPACE-EDITOR 6.0, Experimental PROFILE 6.0,
;;;  VISIDOC 6.0, Experimental CLX 5.0, Experimental CLUE 20.0, Experimental X11M 3.0,
;;;  Experimental RPC 6.0, Experimental NFS 6.0, Experimental BUG 11.4, IP 3.45, Experimental DOCUMENTER 619.0,
;;;  Experimental TI-CLOS 18.0,  microcode 426, Band Name: Rel6H,Scribe,&c, u426 5/4

(EVAL-WHEN (EVAL COMPILE LOAD)
  (PROCLAIM '(SPECIAL SYS:LOCAL-FOR-FIRST-MAPPING-TABLE SYS:LOCALS-FOR-MAPPING-TABLE-BASE))
  (DEFPROP SYS:LOCAL-FOR-FIRST-MAPPING-TABLE T COMPILER:SYSTEM-CONSTANT)
  (DEFPROP SYS:LOCALS-FOR-MAPPING-TABLE-BASE T COMPILER:SYSTEM-CONSTANT)
  )

#!C
; From file P1FUNS.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1FUNS.#"


(DEFUN RECEIVE-CLOS-MAPS (LL)
  ;;  5/05/88 DNG - Original.
  ;;  5/09/88 DNG - Moved (PUSH VAR VARS) into MAKE-MAP-HOME .
  ;;  5/10/88 DNG - Warn about method args declared SPECIAL.
  ;;  5/23/88 CLM - Save the number of mapping-tables in a new field,
  ;;                  :MAP-SLOTS, in the debug-info.
  ;;  5/23/88 DNG - Use TICLOS::SPECIALIZERS declaration saved by PROCESS-PERVASIVE-DECLARATIONS.
  ;;  6/03/88 CLM - Changed to never delete the Continuation, even if not referenced later.
  ;; 11/22/88 DNG - Don't warn about special arguments whose class is T.
  ;;  4/28/89 DNG - Store class in both VAR-DATA-TYPE and VAR-DECLARATIONS.  
  ;;		Permit specializer name to be an anonymous class object.
  ;;  4/28/89 DNG - Don't warn about special arguments for any built-in class.
  ;;  5/05/89 DNG - Don't do CLASS-OF on an EQL form that has not yet been evaluated.
  ;;  5/08/89 DNG - Fix to not error on an argument declared type STREAM.
  (LET ((SPECIFIERS (OR (GETF (COMPILAND-PLIST *CURRENT-COMPILAND*) 'TICLOS::SPECIALIZERS)
			(LET ((FNAME (COMPILAND-FUNCTION-NAME *CURRENT-COMPILAND*)))
			  (AND (CONSP FNAME)
			       (EQ (CAR FNAME) 'TICLOS:METHOD)
			       (CAR (LAST FNAME)))))))
    (UNLESS (NULL SPECIFIERS)
      ;; This function is for a CLOS method.
      (LET ((SLOT-NUMBER SYS:LOCAL-FOR-FIRST-MAPPING-TABLE)
	    (count 0))
	(DO ((LL-TAIL LL (REST LL-TAIL))
	     (SPEC-TAIL SPECIFIERS (REST SPEC-TAIL)))
	    ((NULL SPEC-TAIL))
	  (WHEN (MEMBER (FIRST LL-TAIL) LAMBDA-LIST-KEYWORDS :TEST #'EQ)
	    (SETQ LL-TAIL NIL))
	  (LET* ((ARG-NAME (FIRST LL-TAIL))
		 (CLASS-NAME (IF (TICLOS::INDIVIDUAL-TYPEP (FIRST SPEC-TAIL))
				 (LET ((EXP (TICLOS::INDIVIDUAL-TYPE (FIRST SPEC-TAIL))))
				   (DECLARE (NOTINLINE SELF-EVALUATING-P TICLOS:CLASS-OF)) ; don't need speed here.
				   (IF (OR QC-FILE-LOAD-FLAG (SELF-EVALUATING-P EXP))
				       (TICLOS:CLASS-OF EXP)
				     ;; Else the form may not have been evaluated yet.
				     'T))
			       (FIRST SPEC-TAIL)))
		 (MAP-VAR (MAKE-MAP-HOME (IF (OR (NULL ARG-NAME)
						 (NULL (SYMBOL-PACKAGE ARG-NAME)))
					     (GENSYM)
					   (INTERN (STRING-APPEND "map for " ARG-NAME)))
					 SLOT-NUMBER)))
	    (UNLESS (NULL ARG-NAME)
	      (LET ((VAR (LOOKUP-VAR ARG-NAME VARS)))
		(WHEN (AND (EQ (VAR-TYPE VAR) 'FEF-SPECIAL)
			   (NOT (TYPEP (TICLOS:CLASS-NAMED CLASS-NAME T *COMPILE-FILE-ENVIRONMENT*)
				       'TICLOS:BUILT-IN-CLASS)))
		  (WARN 'RECEIVE-CLOS-MAPS :IMPLAUSIBLE
			"Method argument ~S is special; this will prevent optimization of slot accesses."
			ARG-NAME))
		(SETF (GETF (VAR-DECLARATIONS VAR) 'MAPPING-TABLE) MAP-VAR)
		(LET ((DECLARED-TYPE (VAR-DATA-TYPE VAR)))
		  (COND ((NOT (OR (EQ DECLARED-TYPE CLASS-NAME)
				  (SUBTYPEP DECLARED-TYPE CLASS-NAME *COMPILE-FILE-ENVIRONMENT*)
				  (SUBTYPEP CLASS-NAME DECLARED-TYPE *COMPILE-FILE-ENVIRONMENT*)))
			 (WARN 'RECEIVE-CLOS-MAPS :IMPLAUSIBLE
			       "Parameter ~S DECLAREd type ~S, inconsistent with specializer ~S."
			       ARG-NAME DECLARED-TYPE (FIRST SPEC-TAIL)))
			((AND (EQ CLASS-NAME 'T)
			      (SYS:CLASSP DECLARED-TYPE)
			      (NOT (TYPEP (TICLOS:CLASS-NAMED DECLARED-TYPE T *COMPILE-FILE-ENVIRONMENT*)
					  'TICLOS:BUILT-IN-CLASS)))
			 (WARN 'RECEIVE-CLOS-MAPS :IMPLAUSIBLE
			       "Parameter ~S has been DECLAREd to be of type ~S, so
you might as well say that it is specialized on that class, which will enable
more efficient code to be generated for slot accesses."
			      ARG-NAME (TICLOS:CLASS-PROPER-NAME DECLARED-TYPE)))))
		(SETF (VAR-DATA-TYPE VAR) CLASS-NAME)
		(SETF (GETF (VAR-DECLARATIONS VAR) 'TYPE) CLASS-NAME)
		)))
	  (SETQ SLOT-NUMBER (MAX SYS:LOCALS-FOR-MAPPING-TABLE-BASE
				 (1+ SLOT-NUMBER)))
	  (incf count)
	  )					; end DO
	(LET ((VAR  (MAKE-MAP-HOME '.NEXT-METHOD-LIST. SLOT-NUMBER)))
	  (SETF (VAR-KIND VAR) 'FEF-ARG-KEY) ; never delete* (old - delete if not referenced later)
	  ;;add new field to debug-info list indicating number of mapping-tables
	  (push `(:map-slots . ,count) (compiland-debug-info *current-compiland*))
	  )
	)))
  (VALUES))

))

#!C
; From file TYPEOPT.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; TYPEOPT.#"


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


))