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

;;; Reason: Fix function TYPEP to handle hybrid classes correctly.  
;;; [partial fix for SPR 9713]

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

;;; Written 06/20/89 17:05:23 by GRAY,
;;; while running on Kelvin from band LOD2
;;; With Inconsistent SYSTEM 6.7, VIRTUAL-MEMORY 6.1, EH 6.3, MAKE-SYSTEM 6.0, MICRONET 6.0,
;;;  LOCAL-FILE 6.0, BASIC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.1,
;;;  NETWORK-NAMESPACE 6.0, DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.2, MAC-PATHNAME 6.0,
;;;  NETWORK-PATHNAME 6.0, Inconsistent COMPILER 6.4, TV 6.10, DATALINK 6.0, CHAOSNET 6.0,
;;;  GC 6.3, MEMORY-AUX 6.0, NVRAM 6.0, SYSLOG 6.0, STREAMER-TAPE 6.2, UCL 6.0, INPUT-EDITOR 6.0,
;;;  METER 6.0, ZWEI 6.3, Inconsistent DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.0,
;;;  DATALINK-DISPLAYS 6.0, FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.1, MAC-PRINTER-TYPES 6.1,
;;;  PRINTER-TYPES 6.0, IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.0,
;;;  TELNET 6.0, VT100 6.0, NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.2, Inconsistent TI-CLOS 6.8,
;;;  CLEH 6.4, IP 3.46, Experimental BUG 11.10, Experimental CLX 6.1, CLUE 6.5, X11M 6.1,
;;;  Experimental DOCUMENTER 619.0,  microcode 429, Band Name: 6.0 SLE 6/5 + u429 6/8

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


;;  5/20/89 DNG - Fix treatment of hybrid classes.  [SPR 9713]
(defun typep (object &optional (type nil type-specified-p))
  "T if OBJECT fits the data type specifier TYPE.
An obsolete mode of use is with one argument;
then the value is a type specifier describing OBJECT."
  (declare (arglist object type))
  (let (predicate
	expander
	structure-desc
	type-symbol
	(type type)
	dtp)
    (declare (inline get-flavor ticlos:clos-instance-p))
    (cond
      ((not type-specified-p)
       (setq dtp (%data-type object))
       ;; Cannot use TYPE-OF, since we must
       ;; for back-compatibility return keywords.
       (cond
	 ((= dtp dtp-instance)
	  (%p-contents-offset (instance-flavor object) %instance-descriptor-typename))
	 ((= dtp dtp-array)
	  (cond
	    ((named-structure-p object))
	    ((stringp object) :string)
	    (t :array)))
	 ((= dtp dtp-extended-number)
	  (select (%p-ldb-offset %%header-type-field object 0)
	    (%header-type-bignum :bignum)
	    (%header-type-rational :rational)
	    (%header-type-complex :complex)
	    (%header-type-double-float 'double-float)
	    (otherwise :random)))
	 ((cdr (assoc dtp typep-one-arg-alist :test #'eq)))
	 (t :random)))
      ((classp type) ; when 2nd arg is a class object
       (or (typep-structure-or-flavor object type) ; for CLOS or structure instances
	    ;; If given a flavor class, test for flavor by name.
	    (and (instancep object)
		  (or (typep-structure-or-flavor type 'ticlos:flavor-class)
		       (typep-structure-or-flavor type 'ticlos:hybrid-class))
		  (setq dtp (ticlos:class-description-name
			        (ticlos:class-description type)))
		  (typep-structure-or-flavor object dtp))))
      ((setq predicate (get (setq type-symbol
				   (if (atom type) type (car type)))
			    'type-predicate))
       (if (atom type)
	   (funcall predicate object)
	   (apply predicate object (cdr type))))
      ((and (atom type)
	     (setq dtp
		   (or (rassoc type type-of-alist :test #'eq)
		       (rassoc type typep-one-arg-alist :test #'eq))))
       (= (%data-type object) (car dtp)))
      ((setq expander (getdecl type-symbol 'type-expander))
       (typep object (apply expander (if (atom type)
					 ()
					 (cdr type)))))
      ((and (ticlos:clos-instance-p object)
	     (setq dtp (get type-symbol ticlos::class-property)))
       (typep-structure-or-flavor object dtp))
      ((get-flavor type-symbol)
       (typep-structure-or-flavor object type-symbol))
      ((or
	 (and (setq structure-desc (get type-symbol 'defstruct-description))
	      (defstruct-description-named-p structure-desc))
	 (get type-symbol 'defstruct-named-p))
       (typep-structure-or-flavor object type-symbol))
      ((and (symbolp type) (get type ticlos::class-property))
       nil)
      (t
       (typep object
	      (cerror t () 'wrong-type-arg "~1@*~S is not a type known to TYPEP" 'typep type))))))
))



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

;; 6/20/89 DNG - Fix for when the second argument is the name of a hybrid class.
(defun typep-two-args (form &aux opt type pred dtp tem)
  (cond
    ((and (= (length form) 3) (constantp (caddr form)))
     (setq type (compiler:eval-for-target (caddr form)))
     ;;This takes care of constants evaluation
     (cond
       ((symbolp type)
	(cond
	  ((setq opt (get type 'type-optimizer)) (funcall opt form))
	  ((and (setq pred (get type 'type-predicate)) (symbolp pred)) `(,pred ,(cadr form))) ;; clm 03/06/89
	  ((setq dtp (rassoc type symbolic-type-of-alist :test #'eq))
	   `(= (%data-type ,(cadr form)) ,(car dtp)))
	  ((compilation-flavor type (just-compiling))
	   ;; type is the name of a flavor.
	   (if (typep-structure-or-flavor (ticlos:class-named type t compiler:*compile-file-environment*)
					  'ticlos:standard-class)
	       ;; For a hybrid class, have to check both ways because we don't know 
	       ;; at compile time whether the object is a flavor instance or a CLOS 
	       ;; instance.
	       (let ((g (gensym)))
		 `(let ((,g ,(cadr form)))
		    (or (typep-structure-or-flavor
			  ,g (sys:eval-at-load-time (ticlos:class-named ',type :create)))
			(typep-structure-or-flavor ,g ',type))))
	     `(typep-structure-or-flavor ,(cadr form) ',type)))
	  ((getdecl type 'defstruct-description) `(typep-structure-or-flavor ,(cadr form) ',type))
	  ((typep-structure-or-flavor (ticlos:class-named type t compiler:*compile-file-environment*)
				      'ticlos:standard-class)
	   `(typep-structure-or-flavor ,(cadr form)
				       (sys:eval-at-load-time (ticlos:class-named ',type :create))))
	  ((setq tem (get type 'type-alias-for)) `(typep ,(cadr form) ',tem))
	  ((setq tem (getdecl type 'type-expander)) `(typep ,(cadr form) ',(funcall tem)))
	  (t form)))
       ((classp type)
	`(typep-structure-or-flavor ,(cadr form) ',type))
       ((consp type)
	(cond
	  ((setq opt (get (car type) 'type-optimizer)) (apply opt form (cdr type)))
	  ((setf tem (getdecl (car type) 'type-expander))
	   `(typep ,(cadr form) ',(apply tem (cdr type))))
	  (t form)))
       (t form)))
    (t form)))
))