;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 126.116
;;; Reason:
;;;  Eliminate gratuitous use of WITH-STACK-LIST* in TYPEP.
;;; Written 18-Oct-88 21:26:42 by KEITH at site Gigamos Cambridge
;;; while running on Tonic from band 1
;;; with Experimental System 126.115, Experimental ZWEI 126.21, Experimental ZMail 74.9, Experimental Local-File 76.0, Experimental File-Server 25.0, Experimental Lambda-Diag 18.0, Experimental Unix-Interface 15.0, Experimental Tape 26.4, Microcode 1762, SDU Boot Tape 3.14, SDU ROM 102.



; From modified file DJ: L.SYS; TYPES.LISP#109 at 18-Oct-88 21:29:03
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; TYPES  "


(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 (tem structure-desc dtp
	(type1 (if (consp type) (car type) type)))
    (cond ((not type-specified-p)
	   (setq dtp (%data-type object))
	   ;; Cannot use TYPE-OF, since we must
	   ;; for back-compatibility return keywords.
	   (cond ((eq dtp dtp-instance)
		  (%p-contents-offset
		    (instance-flavor object)
		    %instance-descriptor-typename))
		 ((eq dtp dtp-array-pointer)
		  (cond ((named-structure-p object))
			((stringp object) :string)
			(t :array)))
;		 ((eq dtp dtp-entity)
;		  (class-symbol object))
		 ((eq dtp dtp-extended-number) 
		  (select (%p-ldb-offset %%header-type-field object 0)
		    (%header-type-flonum :flonum)
		    (%header-type-bignum :bignum)
		    (%header-type-rational :rational)
		    (%header-type-complex :complex)
		    (otherwise :random)))
		 ((cdr (assq dtp typep-one-arg-alist)))
		 (t :random)))
	  ((setq dtp (or (rassq type type-of-alist) (rassq type typep-one-arg-alist)))
	   (eq (%data-type object) (car dtp)))
	  ;;>> Doesn't check wna to predicate function
	  ((setq tem (get type1 'type-predicate))
	   (if (atom type)
	       (funcall tem object)
	     (apply tem object (cdr type))))
	  ((setq tem (get type1 'type-alias-for))
	   (if (atom type)
	       (typep object tem)
	     (with-list* (tem tem (cdr type))
	       (typep object tem))))
	  ;;>> Doesn't check wna to expander function
	  ((setq tem (get type1 'type-expander))
	   (typep object (apply tem (if (atom type) nil (cdr type)))))
	  ((get type1 'si:flavor)
	   (typep-structure-or-flavor
	     object
	     (dont-optimize (flavor-name (get-flavor-tracing-aliases type1)))))
	  ((or (and (setq structure-desc (get type1 'si::defstruct-description))
		    (defstruct-description-named-p structure-desc))
	       (get type1 'defstruct-named-p))
	   (typep-structure-or-flavor object type1))
;	  ((and (symbolp type1) (fboundp 'class-symbolp) (class-symbolp type1))
;	   (and (entityp object)
;		(subclass-of-class-symbol-p (class object) type1)))
	  (t (typep object (cerror t nil 'invalid-type-specifier
				   "~S is not a valid type specifier" type))))))

;;; As of system 98, this is used only by old compiled expansions of TYPEP.

))