;-*-cold-load:t; Mode:Common-Lisp; Package: SI; Base: 10; Cold-load: T-*-

;;;                           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) 1985-1989 Texas Instruments Incorporated. All rights reserved.

;;; Changes:
;;; 9/25 PHD: Added support for cli:float.
;;; 8/4/86 PDC Added support for Compile time DEFTYPE (get type 'type-expander) => 
;;;             (getdecl type 'type-expander)
;;; 7/8/88 CLM: Changed TYPEP to improve performance in cases like (TYPEP A B)
;;;             where A and B are variables and B refers to a type that has no
;;;             predicate. (sprs 8228 and 4821)
;;; 4/10/89 DNG - Added environment arguments to TYPE-SPECIFIER-P, SUBTYPEP, etc.
;;; 4/25/89 DNG - Add support for using class objects as type specifiers.

;Each defined type can have any of these three properties:
;TYPE-PREDICATE - value is a function to test an object for membership in the type.
;  It gets the object as first arg, and any elements of the type specifier
;  except for the keyword itself as additional args.
;TYPE-OPTIMIZER - value is an optimizer function for compiling calls to TYPEP.
;  Its first argument is the expression which calls TYPEP.
;  Its remaining args are the elements of the type specifier, except the first.
;  It can return the original call to TYPEP if it has nothing better to optimize to.
;TYPE-EXPANDER - value is an expander function to compute a new type specifier.
;  It gets one argument, the type specifier, and returns a new type specifier.

;Interpreted calls to TYPEP use TYPE-PREDICATE and TYPE-EXPANDER props.
;Compilation uses TYPE-OPTIMIZER and TYPE-EXPANDER props.
;Compilation can also use the TYPE-PREDICATE prop--
; compiling a call to that function rather than to TYPEP,
; but only if the property is a symbol.

;;; CAUTION: you cannot simply define any new type with a TYPE-PREDICATE
;;; because it needs to be wired into the SUBTYPEP data structures.
;;; Defining types with TYPE-EXPANDERs (ie, use of DEFTYPE) is ok
;;; because they will get expanded by SUBTYPEP, so they don't really
;;; pose a new problem.

;These properties are also used:
;TYPE-NAME - value is a string, including an article, which
; is used as the name of this type when it appears as an atom.
;TYPE-NAME-FUNCTION - value is a function to compute the name
; of types which are lists starting with this symbol.


(defmacro deftype (name arglist &body body)
  "Defines NAME as a data type name for use in TYPEP, etc.
A list starting with NAME, used as a type specifier,
expands by binding the args in ARGLIST and then evaluating the BODY.
The value of BODY should be another type specifier.
Any optional arguments in ARGLIST which do not have default values specified
will be bound to * by default, rather than NIL."
  (let ((argcopy (copy-list arglist))
	optionalf)
    (do ((tail argcopy (cdr tail)))
	((null tail))
      (cond
	((eq (car tail) '&optional) (setq optionalf t))
	((member (car tail) '(&key &rest &aux) :test #'eq) (return))
	((and optionalf (atom (car tail))
	      (not (member (car tail) lambda-list-keywords :test #'eq)))
	 (setf (car tail) (list (car tail) ''*)))))
    `(progn
       	 ;;PHD 3/20/87 clear up other properties.

       (eval-when (compile)			; PDC 8/4/86
	 (putdecl ',name 'type-predicate nil)
	 (putdecl ',name 'type-alias-for nil)
	 (putdecl ',name 'type-optimizer nil)
	 (putdecl ',name 'type-expander #'(lambda ,argcopy ,@body)))
       (eval-when (load eval)
	 (remprop ',name 'type-predicate)
	 (remprop ',name 'type-alias-for)
	 (remprop ',name 'type-optimizer))
       (defun (:property ,name type-expander) ,argcopy
	 ,@body)
       ',name)))

;;;03/16/89 clm - Integrated into Kernel for CLOS.
(defsubst classp (object)
  ;; Is the argument a CLOS class object?
  (typep-structure-or-flavor object 'ticlos:class))

;;;03/18/89 DNG - Integrated into Kernel for CLOS -- needed by CLASS-NAMED below.
;;; 5/03/89 DNG - Changed from DEFVAR to DEFCONSTANT.
(defconstant ticlos::class-property 'ticlos::class-def "Symbol property holding class definition")
(eval-when (compile)
  (compiler-let ((INHIBIT-STYLE-WARNINGS-SWITCH T))
    (assert (not (compiler:external-symbol-p ticlos::class-property)))))


;;; 08/04/88 clm - if requested (by passing :CREATE as the first optional arg)
;;; create a dummy class for CLASS-NAME.  This may be needed if 
;;; class-name was known when the file was compiled but not when the xld 
;;; is loaded.
;;  9/23/88 DNG - When creating, let class-options default.
;;  9/24/88 DNG - Signal error for invalid argument type.  
;;  9/26/88 DNG - Added handling for alias flavors that aren't in *ALL-FLAVOR-NAMES* .
;; 10/14/88 DNG - Redesigned to use environments.
;; 11/10/88 DNG - Add use of MAKE-CLASS-FOR-STRUCTURE .
;; 11/23/88 DNG - Use GET-FLAVOR instead of GETDECL.
;; 12/01/88 DNG - Use function ADD-NAMED-CLASS-INTERNAL instead of TICLOS::ADD-NAMED-CLASS.
;; 12/12/88 DNG - Add a doc string.
;; 03/16/89 clm - Integrated into Kernel.
;;  3/22/89 DNG - Add :BUILD flag for use by TICLOS::%DEFSTRUCT-CLASS .
;;  5/01/89 DNG - Add use of DWIMIFY-PACKAGE.
(defun ticlos:class-named (class-name &optional noerrorp environment)
  "Return the class object whose name is the first argument.  If the argument 
is a symbol, its class object is returned.  If the argument is a class object, 
then it is simply returned.  If no such class exists, an error is signalled 
unless the second argument is true, in which case NIL will be returned."
  (if (symbolp class-name)
      (let ((cl (compiler:get-from-environment class-name ticlos::class-property nil 
					       environment)))
	(or cl
	    (and (member noerrorp '(nil :build))
		 (get class-name 'si:defstruct-description)
		 (let ((default-cons-area background-cons-area))
		   (ticlos:make-class-for-structure class-name)
		   (get class-name ticlos::class-property)))
	    (let ((fl (get-flavor class-name environment)))
	      (and fl
		   (not (eq (sys:flavor-name fl) class-name))
		   ;; an alias flavor
		   (ticlos:class-named (sys:flavor-name fl) noerrorp environment)))
	    ;;if the class was defined at compile time, but is not
	    ;;defined at load time, create a dummy class for class-name
	    ;;trusting in redefinition later
	    (and (eq noerrorp :create)
		 (ticlos:add-named-class-internal    ;;the main part of defclass
		   'ticlos:standard-class
		   class-name nil nil nil environment))
	    (unless noerrorp
	      (catch-error-restart ((error) "Look for classes with the same name in a different package.")
		(error "Class named ~S does not exist." class-name))
	      (ticlos:class-named (dwimify-package class-name 'ticlos:find-class) nil environment))
	    nil))
    (if (sys:typep-structure-or-flavor class-name 'ticlos:class)
	class-name
      (error "~S is neither a class object or class name." class-name))))


;; This is for use in the FLAVOR file because Genasys can't load calls to #'(SETF ...) functions.
;;  3/18/89 DNG - Original.
(defun set-class-named (class-name environment class-object)
  (compiler:putprop-in-environment class-name class-object ticlos::class-property environment)
  class-object)

;;From Steele's 1985 "clarifications" list
;;01/05/87 CLM for PDD/PHD - added check for type-predicate property.
;;10/26/88 DNG - Use *compile-file-environment*.
;;03/16/89 clm - Integrated CLOS changes into Kernel.
;; 4/10/89 DNG - Add optional environment argument.
;; 4/25/89 DNG - Recognize a class object as a valid type specifier.
;; 5/04/89 DNG - Bind *LOCAL-ENVIRONMENT* around calls to validator functions 
;;		so that the correct environment will be used by any recursive calls to 
;;		TYPE-SPECIFIER-P from the validator.
(defun type-specifier-p (type &optional (environment compiler:*local-environment*))
  "Returns T on valid type specifiers, NIL on any other object."
  (multiple-value-bind
    (expanded-type error-p )
      (ignore-errors (type-canonicalize type environment))
    (if error-p nil
	(let (fn)
	  (when (member expanded-type '(nil structure ratio atom bignum null random-state t
					    common	;(or number ...... )
					    fat-char	;(and character (satisfies ....)
					    keyword	;(and symbol (satisfies keywordp ))
					    list	;(or null cons)
					    number	; (or complex real)
					    real	; (or rational float)
					    ))
	    (return-from type-specifier-p t))
	  (typecase expanded-type
	    (symbol (not (null
			   (cond
			     ((setq fn (get expanded-type 'type-validator))
			      (let ((compiler:*local-environment* environment))
				(funcall fn)))
			     ((rassoc expanded-type type-of-alist
				      :test #'(lambda (expanded-type cons)
						(if (consp cons)
						    (member expanded-type cons :test #'eq)
						    (eq expanded-type cons))))
			      t)
			     ((getdecl expanded-type 'type-predicate nil environment) t)
			     ((get-flavor expanded-type environment) t)
			     ;; check for typed structure
			     ((getdecl expanded-type 'defstruct-description nil environment) t)
			     ((ticlos:class-named expanded-type t environment) t)
			     ))))
	    (list (and (setq fn (get (first expanded-type) 'type-validator))
		       (let ((compiler:*local-environment* environment))
			 (apply fn (rest expanded-type)))))
	    (ticlos:class t)
	    (t nil))))))

(defun commonp (object)
  "T if OBJECT is a kind of object which Common Lisp defines.
This is everything except locatives, stack groups, lexical-closures,
closures, compiled and microcode functions, and flavor instances
(except for a few flavors which implement Common Lisp types)."
  (if (instancep object)
      (or (pathnamep object) (streamp object) (hash-table-p object))
      (if (typep object 'compiled-function)
	  (streamp object)
	  (not (member (%data-type object) '(#.dtp-locative #.dtp-stack-group #.dtp-lexical-closure
					     #.dtp-closure  #.dtp-function #.dtp-u-entry)
		       :test #'eq))))) 




;; TYPE-OF
;; If the cdr of the entry is a list then the first element is the Zetalisp type 
;; and the second is the common-lisp type
;;PAD 2/3/87  Added stack-list
(defparameter type-of-alist
	      '((#.dtp-symbol . symbol)
		(#.dtp-character . (global:character cli:character))
		(#.dtp-list . cons)
		(#.dtp-stack-list . cons)
		(#.dtp-fix . fixnum)
		(#.dtp-single-float . (flonum single-float))
		(#.dtp-locative . locative)
	        (#.dtp-function . compiled-function)
		(#.dtp-closure . closure)
	        (#.dtp-lexical-closure . lexical-closure)
		(#.dtp-instance . instance)
		(#.dtp-u-entry . microcode-function)
	        (#.dtp-short-float . short-float)
		(#.dtp-stack-group . stack-group)))

(defparameter symbolic-type-of-alist
	      ;; This one is necessary for cross compilation when the types change
	      ;; It is used by the typep optimizer
	      '((dtp-symbol . symbol) (dtp-character global:character character) (dtp-list . cons)
		(dtp-fix . fixnum) (dtp-single-float flonum single-float) (dtp-locative . locative)
		(dtp-fef-pointer . compiled-function) (dtp-closure . closure) (dtp-lexical-closure . lexical-closure)
		(dtp-instance . instance) (dtp-u-entry . microcode-function)
		(dtp-small-flonum . short-float) (dtp-stack-group . stack-group) (dtp-symbol . :symbol)
		(dtp-character . :character) (dtp-list . :cons) (dtp-fix . :fixnum)
		(dtp-single-float . :flonum) (dtp-locative . :locative)
		(dtp-fef-pointer . :compiled-function) (dtp-closure . :closure) 
		(dtp-instance . :instance) (dtp-u-entry . :microcode-function)
		(dtp-small-flonum . :small-flonum)
		(dtp-stack-group . :stack-group))) 


;;PAD 2/3/87 Return t instead of random if type not found
;;GBK 3/21/89 Return class object if not in class list
;;DNG 4/10/89 Fix for instances in cold load when class objects haven't been created yet.
(defun type-of (object &aux (dtp (%data-type object)) types)
  "Returns a type-specifier describing the type OBJECT belongs to.
For example, (TYPE-OF 5) is FIXNUM"
  (cond
    ((= dtp dtp-instance)
     (LET* ((my-class-description (instance-flavor object))
	    (my-class (%p-contents-offset my-class-description
					  %clos-instance-descriptor-class-object))
	    (my-name (%p-contents-offset my-class-description
					 %instance-descriptor-typename)))
       (IF (or (EQ my-class (ticlos::class-named my-name t))
	       (not (classp my-class)))
	   my-name
	   my-class)))
    ((= dtp dtp-array)
     (cond
       ((named-structure-p object))
       ((stringp object) (if (zetalisp-on-p)
			     'global:string
			     'string))
       (t 'array)))
    ((= dtp dtp-extended-number)
     (select (%p-ldb-offset %%header-type-field object 0)
       (%header-type-double-float 'double-float)
       (%header-type-bignum 'bignum)
       (%header-type-rational 'ratio)
       (%header-type-complex 'complex)
       (otherwise t)))
    ((setf types (cdr (assoc dtp type-of-alist :test #'eq)))
     (if (consp types)
	 (if (zetalisp-on-p)
	     (first types)
	     (second types))
	 types))
    (t t))) 

;;PAD 2/3/87 Added stack-list
(defparameter typep-one-arg-alist
	  '((#.dtp-symbol . :symbol)
	    (#.dtp-character . :character)
	    (#.dtp-list . :cons)
	    (#.dtp-stack-list . :cons)
	    (#.dtp-fix . :fixnum)
	    (#.dtp-single-float . :flonum)
	    (#.dtp-locative . :locative)
	    (#.dtp-function . :compiled-function)
	    (#.dtp-closure . :closure)
	    (#.dtp-lexical-closure . :lexical-closure)
	    (#.dtp-instance . :instance)
	    (#.dtp-u-entry . :microcode-function)
	    (#.dtp-short-float . :small-flonum)
	    (#.dtp-stack-group . :stack-group))) 

;;clm 7/8/88 - these added for performance improvements.
(defconstant reordered-type-of-alist
    (delete-if #'consp 
	       (mapcar #'(lambda (element) (cons (rest element)
						 (first element)))
		       type-of-alist)
	       :key #'car)
  "Like TYPE-OF-ALIST, but is of the form (TYPE . NUMBER), and deals
   only with single types."
  )

(defconstant reordered-typep-one-arg-alist
    (delete-if #'consp 
	       (mapcar #'(lambda (element) (cons (rest element)
						 (first element)))
		       typep-one-arg-alist)
	       :key #'car)
  "Like TYPEP-ONE-ARG-ALIST, but is of the form (TYPE . NUMBER), and deals
   only with single types."
  )

;;  8/10/88 DNG - Use TYPEP-STRUCTURE-OR-FLAVOR instead of TYPEP for CLASS 
;;		test to avoid bootstrapping problems.
;; 10/25/88 DNG - Modifed to call CLASS-NAMED once instead of twice.
;; 03/16/89 clm - Integrated CLOS changes into Kernel.
(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 type)
	dtp)
    (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)
       (typep-structure-or-flavor object type))
      ((setq predicate (get (if (atom type)
				type
				(car type))
			    'type-predicate))
       (if (atom type)
	   (funcall predicate object)
	   (apply predicate object (cdr 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 (if (atom type)	;PDC 8/4/86
				   type
				   (car type))
			       'type-expander))
       (typep object (apply expander (if (atom type)
					 ()
					 (cdr type)))))
      ((progn
	 (unless (symbolp type)
	   (setq type (car type)))
	 (get type 'flavor))
       (typep-structure-or-flavor object type))
      ((or
	 (and (setq structure-desc (get type 'defstruct-description))
	      (defstruct-description-named-p structure-desc))
	 (get type 'defstruct-named-p))
       (typep-structure-or-flavor object type))
      ((setq dtp (ticlos:class-named type t))
       (typep-structure-or-flavor object dtp))
      (t
       (typep object
	      (cerror t () 'wrong-type-arg "~1@*~S is not a type known to TYPEP" 'typep type)))))) 

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

;;;(defun typep-structure (x type &aux xname d)
;;;  (cond
;;;    ((setq xname (named-structure-p x))
;;;     (do ()
;;;	 ((eq xname type)
;;;	  t)
;;;       (or
;;;	(and (setq d (get xname 'defstruct-description)) (defstruct-description-named-p d)
;;;	   (setq xname (car (defstruct-description-include d))))
;;;	(return ()))))
;;;    ((and (setq d (get type 'defstruct-description)) (defstruct-description-named-p d)) nil)
;;;    (t (typep x type)))) 			;Optimization turned out to be wrong
						



(defun (:property satisfies type-predicate) (object predicate)
  (unless (and (symbolp predicate)
	       (fboundp predicate))
    (error "predicate ~S should be a predicate name for (satisfies predicate) " predicate))
  (funcall predicate object)) 


(defun (:property satisfies type-optimizer) (expression predicate)
  `(,predicate ,(cadr expression))) 


(defun (:property or type-predicate) (object &rest types)
  (dolist (disjunct types)
    (when (typep object disjunct)
      (return t)))) 


(defun (:property or type-optimizer) (expression &rest types)
  (let ((object (cadr expression)))
    (once-only (object) (cons 'or (mapcar #'(lambda (type)
					      `(typep ,object ',type))
					  types))))) 


(defun (:property and type-predicate) (object &rest types)
  (dolist (conjunct types t)
    (unless (typep object conjunct)
      (return ())))) 


(defun (:property and type-optimizer) (expression &rest types)
  (let ((object (cadr expression)))
    (once-only (object) (cons 'and (mapcar #'(lambda (type)
					       `(typep ,object ',type))
					   types))))) 


(defun (:property not type-predicate) (object type)
  (not (typep object type))) 


(defun (:property not type-optimizer) (expression type)
  `(not (typep ,(cadr expression) ',type))) 


(defun (:property global:member type-predicate) (object &rest members)
  (not (null (member object members)))) 



(defun (:property member type-predicate) (object &rest members)
  (not (null (member object members)))) 


(defun (:property global:member type-optimizer) (expression &rest members)
  `(member ,(cadr expression) ',(copy-list members))) 



(defun (:property member type-optimizer) (expression &rest members)
  `(member ,(cadr expression) ',(copy-list members))) 


(defun (:property array type-predicate) (object &optional (element-type '*) (dimensions '*))
  (and (arrayp object)
     (or (eq element-type '*)
	(equal (type-canonicalize (array-element-type object)) (type-canonicalize element-type)))
     (or (eq dimensions '*)
	(if (numberp dimensions)
	  (= dimensions (array-rank object))
	  (and (= (length dimensions) (array-rank object))
	     (dotimes (i (array-rank object) t)
	       (unless (or (eq (nth i dimensions) '*) (= (nth i dimensions) (array-dimension object i))
		   (return ()))))))))) 


(defun (:property array type-optimizer) (expression &rest args)
  (if (null args)
    `(arrayp ,(cadr expression))
    expression)) 


(defun (:property simple-array type-predicate) (object &optional (element-type '*) (dimensions '*))
  (and (simple-array-p object)
     (or (eq element-type '*)
	(equal (type-canonicalize (array-element-type object)) (type-canonicalize element-type)))
     (or (eq dimensions '*)
	(if (numberp dimensions)
	  (= dimensions (array-rank object))
	  (and (= (length dimensions) (array-rank object))
	     (dotimes (i (array-rank object) t)
	       (unless (or (eq (nth i dimensions) '*) (= (nth i dimensions) (array-dimension object i))
		   (return ()))))))))) 


(defun (:property simple-array type-optimizer) (expression &rest args)
  (if (null args)
    `(simple-array-p ,(cadr expression))
    expression)) 


(defun (:property vector type-predicate) (object &optional (element-type '*) (size '*))
  (and (vectorp object)
     (or (eq element-type '*)
	(equal (type-canonicalize (array-element-type object)) (type-canonicalize element-type)))
     (or (eq size '*) (= size (array-total-size object))))) 


(defun (:property vector type-optimizer) (expression &rest args)
  (if (null args)
    `(vectorp ,(cadr expression))
    expression)) 


(defun (:property vector type-expander) (&optional (element-type '*) (size '*))
  `(array ,element-type (,size))) 


(defun (:property simple-vector type-predicate) (object &optional (size '*))
  (and (simple-vector-p object) (or (eq size '*) (= size (array-total-size object))))) 


(defun (:property simple-vector type-optimizer) (expression &rest args)
  (if (null args)
    `(simple-vector-p ,(cadr expression))
    expression)) 


(defun (:property simple-vector type-expander) (&optional (size '*))
  `(simple-array t (,size))) 


(defun (:property global:string type-predicate) (object &optional (size '*))
  (and (stringp object) (or (eq size '*) (= size (array-total-size object))))) 



(defun (:property string type-predicate) (object &optional (size '*))
  (and (stringp object) (or (eq size '*) (= size (array-total-size object))))) 


(defun (:property global:string type-optimizer) (expression &rest args)
  (if (null args)
    `(stringp ,(cadr expression))
    expression)) 



(defun (:property string type-optimizer) (expression &rest args)
  (if (null args)
    `(stringp ,(cadr expression))
    expression)) 


(defun (:property global:string type-expander) (&optional (size '*))
  `(array string-char (,size))) 



(defun (:property string type-expander) (&optional (size '*))
  `(array string-char (,size))) 


(defun (:property simple-string type-predicate) (object &optional (size '*))
  (and (simple-string-p object) (or (eq size '*) (= size (array-total-size object))))) 


(defun (:property simple-string type-optimizer) (expression &rest args)
  (if (null args)
    `(simple-string-p ,(cadr expression))
    expression)) 


(defun (:property simple-string type-expander) (&optional (size '*))
  `(simple-array string-char (,size))) 


(defun (:property bit-vector type-predicate) (object &optional (size '*))
  (and (bit-vector-p object) (or (eq size '*) (= size (array-total-size object))))) 


(defun (:property bit-vector type-optimizer) (expression &rest args)
  (if (null args)
    `(bit-vector-p ,(cadr expression))
    expression)) 


(defun (:property bit-vector type-expander) (&optional (size '*))
  `(array bit (,size))) 


(defun (:property simple-bit-vector type-predicate) (object &optional (size '*))
  (and (simple-bit-vector-p object) (or (eq size '*) (= size (array-total-size object))))) 


(defun (:property simple-bit-vector type-optimizer) (expression &rest args)
  (if (null args)
    `(simple-bit-vector-p ,(cadr expression))
    expression)) 


(defun (:property simple-bit-vector type-expander) (&optional (size '*))
  `(simple-array bit (,size))) 


(defun (:property named-structure type-predicate) (object)
  (not (null (named-structure-p object)))) 


(defun (:property named-structure type-optimizer) (expression)
  `(not (null (named-structure-p ,(cadr expression))))) 


(defun (:property named-structure type-expander) ()
  'structure) 


(defun (:property structure type-predicate) (object)
  (not (null (named-structure-p object)))) 


(defun (:property structure type-optimizer) (expression)
  `(not (null (named-structure-p ,(cadr expression))))) 


;;AB 8/3/87.  Support type of FUNCTION (but not list (FUNCTION arg-types result-types)).  [SPR 5779]
(defun (:property function type-predicate) (object &rest type-specifier-body)
  (COND ((NOT type-specifier-body)
	 (FUNCTIONP object nil))
	(t
	 (ferror () "FUNCTION types are not meaningful for testing objects against."))))

;;AB 8/3/87.  Support type of FUNCTION (but not list (FUNCTION arg-types result-types)).  [SPR 5779]
(defun (:property function type-optimizer) (expression)
  (COND ((ATOM (SECOND (THIRD expression)))
	 `(FUNCTIONP ,(SECOND expression) nil))
	(t
	 (ferror () "FUNCTION types are not meaningful for testing objects against."))))

(defun (:property values type-predicate) (object &rest ignore)
  object
  (ferror () "VALUES types are not meaningful for testing objects against."))

;;01/20/88 CLM for PHD - added type-validator property so that VALUES not 
;;seen to be a valid type specifier in TYPE-SPECIFIER-P.
;;02/01/88 CLM - fixed for forms like (values integer integer)
(defun (:property values type-validator) (&rest ignore) nil) 


(defun (:property sequence type-predicate) (object)
  (or (null object) (consp object) (vectorp object))) 


(defun (:property sequence type-expander) ()
  '(or list vector)) 


(defun (:property nil type-predicate) (object)
  object
  ()) 


(defun (:property nil type-optimizer) (expression)
  `(progn
     ,(cadr expression)
     ())) 


(defun (:property t type-predicate) (object)
  object
  t) 


(defun (:property t type-optimizer) (expression)
  expression
  `(progn
     ,(cadr expression)
     t)) 


(defun (:property string-char type-predicate) (object)
  (and (characterp object) (string-char-p object)))

;;12/10/87 CLM for PHD - added the following type-optimizer and
;;REMOVED the type-expander for string-char and standard-char.
;;Also fixed defprop atom and defprop common to reflect these 
;;changes.
(defun (:property string-char type-optimizer) (expression)
  (let ((object (cadr expression)))
    (once-only (object) `(and (characterp ,object) (string-char-p  ,object))))) 

;;(defun (:property string-char type-expander) ()
;;  '(and character (satisfies string-char-p))) 


(defun (:property fat-char type-predicate) (object)
  (and (characterp object) (< object (lsh 1 16)))) 


(defun (:property standard-char type-predicate) (object)
  (and (characterp object) (standard-char-p object))) 


(defun (:property standard-char type-optimizer) (expression)
  (let ((object (cadr expression)))
    (once-only (object) `(and (characterp ,object) (standard-char-p ,object))))) 


;;(defun (:property standard-char type-expander) ()
;;  '(and character (satisfies string-char-p) (satisfies standard-char-p))) 

(defun (:property global:character type-predicate) (object)
  (characterp object)) 

(defun (:property global:character type-optimizer) (expression)
  `(characterp ,(cadr expression))) 

(defun (:property character type-predicate) (object)
  (characterp object)) 

(defun (:property character type-optimizer) (expression)
  `(characterp ,(cadr expression)))

;;  5/1/89 DNG - The next 4 added for ANSI Common Lisp.  These don't 
;;		completely match the specified functionality, but are close enough for now.
(deftype base-character () 'string-char)
(deftype extended-character () `(and character (not string-char)))
(deftype base-string () 'string)
(deftype simple-base-string () 'simple-string)

(defun (:property closure type-predicate) (object)
  (closurep object))

(defun (:property closure type-optimizer) (expression)
  `(closurep ,(second expression)))



;; Type-validator properties added 9/4/86 PDC

;;PAD 2/19/87 Added a second value for satisfies.
(defun (:property satisfies type-validator) (&optional (predicate nil predicate-provided-p))
  (values (and predicate-provided-p
	       (symbolp predicate)
	       (fboundp predicate))
	  (and predicate-provided-p
	       (symbolp predicate))))



(defun (:property not type-validator) (&optional (type nil type-provided-p))
  (and type-provided-p
       (type-specifier-p type)))

(defprop and combinator-type-validator  type-validator)
(defprop or combinator-type-validator  type-validator)

(defun combinator-type-validator (&rest args)
  (let ((result1 t)
	(result2 t))
    (dolist (arg args (values result1 result2))
      (multiple-value-call #'(lambda (val1 &optional (val2 t val2-p ))
			       (setf result1 (and result1 val1))
			       (setf result2 (and result2 (if val2-p val2 val1))))
			   (type-specifier-p arg)))))
			       
(defun (:property member type-validator) (&rest args)
  (and args t))

(defun array-validator (&rest args)
  (or (null args)
      (and (>= 2 (length args))
	   (let ((dims (second args)))
	     (dolist (i (if (listp dims) dims (cdr args)) t)
	       (unless (or (eq i '*)
			   (null i)
			   (and (fixnump i)
				(not (minusp i))))
		 (return nil))))
	   (or (eq (first args) '*)
	       (type-specifier-p (first args))))))

(defprop array array-validator type-validator)

(defprop simple-array array-validator type-validator)

(eval-when (compile)
(defmacro validate-range ( args predicate)
  `(or (null ,args)
      (and (<= (length ,args) 2)
	   (dolist (i ,args t)
	     (when (consp i) (setf i (first i)))
	     (unless (or (eq i '*)
		       (,predicate i))
	       (return nil))))))
);eval-when

;;  5/2/89 DNG - Fixed for SPR 8985.
(defun (:property complex type-validator) (&rest args)
  (or (null args)
      (and (< (length args) 2)
	   (type-specifier-p (first args))
	   (values (subtypep (first args) 'real)))))

(defun (:property integer type-validator) (&rest args)
  (validate-range args integerp))

(defun (:property float type-validator) (&rest args)
  (validate-range args floatp))  

(defun (:property double-float type-validator) (&rest args)
  (validate-range args double-floatp))

(defun (:property long-float type-validator) (&rest args)
  (validate-range args double-floatp))  ;;  long-floatp -- DRH

(defun (:property short-float type-validator) (&rest args)
  (validate-range args small-floatp))    ;;short-floatp  -- DRH

(defun (:property single-float type-validator) (&rest args)
  (validate-range args single-floatp))

(defun (:property rational type-validator) (&rest args)
  (validate-range args rationalp))


;;; Numeric types.


(defun (:property complex type-predicate) (object &optional (type '*))
  (and (complexp object) (or (eq type '*) (typep (complex-real-part object) type)))) 


(defun (:property complex type-optimizer) (expression &optional (type '*))
  (let ((object (cadr expression)))
    (if (eq type '*)
      `(complexp ,object)
      (once-only (object) `(and (complexp ,object) (typep (complex-real-part ,object) ',type)))))) 


(defprop real realp type-predicate) 


(defun (:property integer type-predicate) (object &optional (low '*) (high '*))
  (and (integerp object)
     (cond
       ((eq low '*) t)
       ((numberp low) (<= low object))
       ((consp low) (< (car low) object))
       (t (ferror () "Invalid lower limit in INTEGER type specifier.")))
     (cond
       ((eq high '*) t)
       ((numberp high) (>= high object))
       ((consp high) (> (car high) object))
       (t (ferror () "Invalid upper limit in INTEGER type specifier."))))) 


(defun (:property integer type-optimizer) (expression &optional (low '*) (high '*))
  (if (and (not (eq low '*)) (not (eq high '*))
      (< (- (if (consp high)
	      (1- (car high))
	      high)
	    (if (consp low)
	      (1+ (car low))
	      low)) 4))
    (let ((object (cadr expression)))
      `(member ,object
	     ',(loop for i from (if (consp low)
				  (1+ (car low))
				  low)
		  upto (if (consp high)
			 (1- (car high))
			 high)
		  collect i)
	     :test #'eq))
    (optimize-numeric-type-test 'integerp expression low high))) 


(defprop fix integerp type-predicate) 

(defun (:property fix type-expander) ()
  'integer) 


(defprop fixnum fixnump type-predicate) 

;;PAD 2/12/87 Read-time evaluation of constants to prevent consing.
(defun (:property fixnum type-expander) ()
  '(integer #.most-negative-fixnum #.most-positive-fixnum)) 


(defun (:property fixnum type-optimizer) (expression)
  `(fixnump ,(cadr expression))) 


(defun optimize-numeric-type-test (predicate expression &optional (low '*) (high '*))
  (let ((object (cadr expression)))
    (once-only (object)
       (if (and (eq low '*) (eq high '*))
	 `(,predicate ,object)
	 `(and (,predicate ,object)
	     ,(cond
		((eq low '*) t)
		((numberp low) `(>=  ,object ,low))
		((listp low) `(> ,object ,(car low))))
	     ,(cond
		((eq high '*) t)
		((numberp high) `(<= ,object ,high))
		((listp high) `(< ,object ,(car high))))))))) 
	     

(defun (:property mod type-predicate) (object &optional (limit '*))
  (and (integerp object) (not (minusp object))
     (cond
       ((eq limit '*) t)
       ((numberp limit) (> limit object))
       (t (ferror () "Invalid upper limit in MOD type specifier."))))) 


(defun (:property mod type-expander) (&optional (high '*))
  (if (eq high '*)
    '(integer 0)
    `(integer 0 ,(1- high)))) 


(defun (:property bit type-predicate) (object)
  (member object '(0 1) :test #'eq)) 


(defun (:property bit type-expander) ()
  '(integer 0 1)) 


(defun (:property unsigned-byte type-predicate) (object &optional (byte-size '*))
  (and (integerp object) (not (minusp object))
     (cond
       ((eq byte-size '*) t)
       ((numberp byte-size) (> (ash 1 byte-size) object))
       (t (ferror () "Invalid byte size in UNSIGNED-BYTE type specifier."))))) 


(defun (:property unsigned-byte type-expander) (&optional (byte-size '*))
  (if (eq byte-size '*)
    '(integer 0)
    `(integer 0 ,(1- (ash 1 byte-size))))) 


(defun (:property signed-byte type-predicate) (object &optional (byte-size '*))
  (and (integerp object)
     (cond
       ((eq byte-size '*) t)
       ((numberp byte-size)
	(and (< object (ash 1 (1- byte-size))) (>= object (- (ash 1 (1- byte-size))))))
       (t (ferror () "Invalid byte size in SIGNED-BYTE type specifier."))))) 


(defun (:property signed-byte type-expander) (&optional (byte-size '*))
  (if (eq byte-size '*)
    'integer
    `(integer ,(- (ash 1 (1- byte-size))) ,(1- (ash 1 (1- byte-size)))))) 


(defun (:property rational type-predicate) (object &optional (low '*) (high '*))
  (and (rationalp object)
     (cond
       ((eq low '*) t)
       ((numberp low) (<= low object))
       ((consp low) (< (car low) object))
       (t (ferror () "Invalid lower limit in RATIONAL type specifier.")))
     (cond
       ((eq high '*) t)
       ((numberp high) (>= high object))
       ((consp high) (> (car high) object))
       (t (ferror () "Invalid upper limit in RATIONAL type specifier."))))) 


(defun (:property rational type-optimizer) (expression &optional (low '*) (high '*))
  (optimize-numeric-type-test 'rationalp expression low high)) 


(defun (:property real type-predicate) (object &optional (low '*) (high '*))
  (and (realp object)
     (cond
       ((eq low '*) t)
       ((numberp low) (<= low object))
       ((consp low) (< (car low) object))
       (t (ferror () "Invalid lower limit in REAL type specifier.")))
     (cond
       ((eq high '*) t)
       ((numberp high) (>= high object))
       ((consp high) (> (car high) object))
       (t (ferror () "Invalid upper limit in REAL type specifier."))))) 


(defun (:property real type-optimizer) (expression &optional (low '*) (high '*))
  (optimize-numeric-type-test 'realp expression low high)) 


(defprop float float-type-predicate type-predicate) 

(defprop global:float float-type-predicate type-predicate) 

(defun float-type-predicate (object &optional (low '*) (high '*))
  (and (floatp object)
     (cond
       ((eq low '*) t)
       ((numberp low) (<= low object))
       ((consp low) (< (car low) object))
       (t (ferror () "Invalid lower limit in FLOAT type specifier.")))
     (cond
       ((eq high '*) t)
       ((numberp high) (>= high object))
       ((consp high) (> (car high) object))
       (t (ferror () "Invalid upper limit in FLOAT type specifier."))))) 


(defun (:property float type-optimizer) (expression &optional (low '*) (high '*))
  (optimize-numeric-type-test 'floatp expression low high)) 

(defun (:property global:float type-optimizer) (expression &optional (low '*) (high '*))
  (optimize-numeric-type-test 'floatp expression low high)) 


(defprop short-float small-float-predicate type-predicate) 

(defprop small-flonum small-float-predicate type-predicate) 

(defun small-float-predicate (object &optional (low '*) (high '*))
  (and (small-floatp object) (float-type-predicate object low high))) 


(defprop small-flonum canon-to-short-float type-expander) 

(defun canon-to-short-float (&rest params)
  (cons 'short-float params)) 


(defprop short-float small-float-type-optimizer type-optimizer) 

(defprop small-flonum small-float-type-optimizer type-optimizer) 

(defun small-float-type-optimizer (expression &optional (low '*) (high '*))
  (optimize-numeric-type-test 'small-floatp expression low high)) 


(defprop single-float single-float-predicate type-predicate)

(defprop double-float double-float-predicate type-predicate) 

(defprop long-float double-float-predicate type-predicate) 

(defprop flonum single-float-predicate type-predicate) 

(defun single-float-predicate (object &optional (low '*) (high '*))
  (and (single-floatp object) (float-type-predicate object low high)))

(defun double-float-predicate (object &optional (low '*) (high '*))
  (and (double-floatp object) (float-type-predicate object low high)))


(defun (:property long-float type-expander) (&rest params)
  (cons 'double-float params))

(defun (:property flonum type-expander) (&rest params)
  (cons 'single-float params))


(defprop single-float single-float-type-optimizer type-optimizer) 

(defprop double-float double-float-type-optimizer type-optimizer) 

(defprop long-float double-float-type-optimizer type-optimizer) 

(defprop flonum single-float-type-optimizer type-optimizer) 

(defun single-float-type-optimizer (expression &optional (low '*) (high '*))
  (optimize-numeric-type-test 'single-floatp expression low high))

(defun double-float-type-optimizer (expression &optional (low '*) (high '*))
  (optimize-numeric-type-test 'double-floatp expression low high))




;;; Data base for inclusion relation on basic types.

(defprop member global:member type-alias-for)

(defprop global:float float type-alias-for)

(defprop number (real rational integer bignum ratio complex float short-float single-float double-float) subtypes) 

(defprop real (rational integer ratio bignum float short-float single-float double-float) subtypes) 

(defprop rational (integer ratio bignum) subtypes) 

(defprop integer (bignum) subtypes) 

(defprop float (short-float single-float double-float) subtypes) 

(defprop sequence
   (list cons null vector bit-vector string simple-vector simple-bit-vector simple-string)
   subtypes) 

(defprop symbol (null keyword) subtypes) 

(defprop list (cons null) subtypes) 

(defprop character (standard-char string-char fat-char) subtypes) 

(defprop global:string string type-alias-for) 

(defprop global:character character type-alias-for) 

(defprop fat-char (string-char standard-char) subtypes) 

(defprop string-char (standard-char) subtypes) 

(defprop array
   (structure simple-array vector string bit-vector simple-vector simple-bit-vector
    simple-string)
   subtypes) 

(defprop simple-array (simple-vector simple-bit-vector simple-string) subtypes) 

(defprop vector (string bit-vector simple-vector simple-bit-vector simple-string) subtypes) 

(defprop string (simple-string) subtypes) 

(defprop bit-vector (simple-bit-vector) subtypes) 

(defprop atom
   (array simple-array vector string bit-vector simple-vector simple-bit-vector simple-string
      character symbol null number rational integer bignum ratio complex float short-float
      single-float double-float hash-table readtable LISP:package pathname stream random-state
      structure closure lexical-closure instance stack-group locative compiled-function
      microcode-function)
   subtypes)

(defprop common
   (array simple-array vector string bit-vector simple-vector simple-bit-vector simple-string
      standard-char list symbol cons null number rational integer bignum ratio complex float
      short-float single-float double-float hash-table readtable LISP:package pathname stream
      random-state structure)
   subtypes)

(defprop closure (lexical-closure) subtypes)




(defprop atom atom type-predicate) 

(defprop bignum bigp type-predicate) 

(defprop common commonp type-predicate) 

(defprop complex complexp type-predicate) 

(defprop cons consp type-predicate) 

(defprop list common-lisp-listp type-predicate) 

(defprop keyword keywordp type-predicate) 

(defprop null null type-predicate) 

(defprop number numberp type-predicate) 

(defprop ratio ratiop type-predicate) 

(defprop stream streamp type-predicate) 

(defprop symbol symbolp type-predicate) 

;;; Pretty names for types.  This is used by the CHECK-ARG-TYPE macro.

(defprop fix "an integer" type-name) 

(defprop float "a floating-point number" type-name) 

(defprop global:float "a floating-point number" type-name) 

(defprop real "a real number" type-name) 

(defprop null "NIL" type-name) 

(defprop complex "a complex number" type-name) 
;;PAD 3/11/87 Add type-alias-for property.
(defun fixup-type-properties ()
  (dolist (symbol
    '(array atom bignum bit bit-vector character closure common compiled-function complex
	cons double-float lexical-closure fat-char fix fixnum flonum float hash-table
	instance integer keyword list locative long-float microcode-function null
	named-structure number LISP:package pathname random-state ratio rational readtable real
	sequence short-float simple-array simple-bit-vector simple-string simple-vector
	single-float standard-char stream string string-char structure symbol vector))
    (setf (get (intern (string symbol) *keyword-package*) 'type-alias-for) symbol)
    (when (get symbol 'type-predicate)
      (setf (get (intern (string symbol) *keyword-package*) 'type-predicate) (get symbol 'type-predicate)))
    (when (get symbol 'type-optimizer)
      (setf (get (intern (string symbol) *keyword-package*) 'type-optimizer) (get symbol 'type-optimizer)))
    (when (get symbol 'subtypes)
      (let ((combined
	     (nconc
	      (mapcar #'(lambda (elt)
			  (intern (string elt) *keyword-package*))
		      (get symbol 'subtypes))
	      (get symbol 'subtypes))))
	(setf (get (intern (string symbol) *keyword-package*) 'subtypes) combined)
	(setf (get symbol 'subtypes) combined)))
    (when (get symbol 'type-expander)
      (setf (get (intern (string symbol) *keyword-package*) 'type-expander) (get symbol 'type-expander)))
    (when (get symbol 'type-name)
      (setf (get (intern (string symbol) *keyword-package*) 'type-name) (get symbol 'type-name))))) 



;;CLM for PHD 02/11/87 - fix bug report ????? [from Stephanie Keene] on subtypep.
;;Fix: last clause of (case...) changed from (apply tem (cdr typespec)) to 
;;(type-canonicalize (apply tem (cdr typespec))).
;;PHD 6/29/88 Added support for clos classes.
;;DNG 8/10/88 Use TYPEP-STRUCTURE-OR-FLAVOR instead of TYPEP for CLASS test to 
;;	avoid bootstrapping problems.
;;clm 3/16/89 - integrated CLOS changes into Kernel.
;;DNG 4/10/89 - Add optional environment argument.
;;DNG 4/25/89 - Accept a class object as a valid type specifier.
(defun type-canonicalize (typespec &optional (environment compiler:*local-environment*) &aux tem)
  "Returns a typespec equivalent in meaning to TYPESPEC, but possibly simpler."
  (cond
    ((null typespec) nil)
    ((eq typespec t) t)
    ((symbolp typespec)
     (cond
       ((setq tem (get typespec 'type-alias-for)) (type-canonicalize tem environment))
       ((setq tem (getdecl typespec 'type-expander nil environment))
	(type-canonicalize (funcall tem) environment))
       (t typespec)))
    ((classp typespec) typespec)
    ((and (consp typespec) (symbolp (car typespec)))
     (case (car typespec)
       (or
	(when (null (cdr typespec))
	  (type-canonicalize
	    (cerror t () 'wrong-type-argument "~*~S invalid typespec." 'typespec typespec)
	    environment))
	(let ((z
		(mapcan
		  #'(lambda (x)
		      (setq x (type-canonicalize x environment))
		      (if (and (consp x) (eq (car x) 'or))
			  (cdr x)
			  (list x)))
		  (cdr typespec))))
	  (if (cdr z)
	      (cons 'or z)
	      (car z))))
       (and
	(when (null (cdr typespec))
	  (type-canonicalize
	    (cerror t () 'wrong-type-argument "~*~S invalid typespec." 'typespec typespec)
	    environment))
	(let ((z
		(mapcan
		  #'(lambda (x)
		      (setq x (type-canonicalize x environment))
		      (if (and (consp x) (eq (car x) 'and))
			  (cdr x)
			  (list x)))
		  (cdr typespec))))
	  (if (cdr z)
	      (cons 'and z)
	      (car z))))
       (not
	(if (null (cdr typespec))
	    (type-canonicalize
	      (cerror t () 'wrong-type-argument "~*~S invalid typespec." 'typespec typespec)
	      environment)
	    (let ((z (type-canonicalize (cadr typespec) environment)))
	      (if (and (consp z) (eq (car z) 'not))
		  (cadr z)
		  (list 'not z)))))
       ((member global:member)
	`(member ,@(cdr typespec)))
       (t
	(if (dolist (elt (cdr typespec) t)
	      (unless (eq elt '*)
		(return ())))
	    (type-canonicalize (car typespec) environment)
	    (if (setq tem (getdecl (car typespec) 'type-expander nil environment))
		(type-canonicalize (apply tem (cdr typespec)) environment)
		typespec)))))
    ((classp typespec) typespec)
    (t
     (type-canonicalize
       (cerror t () 'wrong-type-argument "~*~S invalid typespec." 'typespec typespec)
       environment)))) 

;;;; subtypep

;;AB 8/3/87.  For PHD.  Fix type inferencing on DEFSTRUCT. [SPR 6025]
(defun subtypep-internal (x y &optional environment &aux t1 t2)
  ;;X and Y are known to be canonicalized.
  (cond
    ((or (null x) (eq y t) (equal x y)) (values t t))
    ((and (consp y) (member (car y) '(or and not) :test #'eq))
     (case (car y)
       (or
	(loop with knownp = t for y in (cdr y) do (multiple-value-setq (t1 t2)
						    (subtypep-internal x y environment))
	      when t1 return (values t t) do (setq knownp (and knownp t2)) finally
	      (return (values () knownp))))
       (and
	;;PHD 7/16/87 SPR 6025 Stop the loop at the first failure.
	(dolist (y (cdr y) (values t t))
	  (multiple-value-setq (t1 t2)
	    (subtypep-internal x y environment))
	  (unless (and t1 t2) (return (values nil t2)))))
       (t (multiple-value-setq (t1 t2)
	    (disjoint-typep x (cadr y) nil environment))
	  (values t1 (or t2 (subtypep-internal x (cadr y) environment)
			 (subtypep-internal (cadr y) x environment))))))
    ((and (consp x) (member (car x) '(and or not member) :test #'eq))
     (case (car x)
       (member (values (loop for z in (cdr x) always (typep z y)) t))
       (and
	(loop with known = t for z in (cdr x) do (multiple-value-setq (t1 t2)
						   (subtypep-internal z y environment))
	      when t1 return (values t t) do (setq known (and known t2)) finally
	      (return (values () known))))
       (or
	(loop with val = t for z in (cdr x) do (multiple-value-setq (t1 t2)
						 (subtypep-internal z y environment))
	      when (not t2) return (values () ()) unless t1 do (setq val ()) finally
	      (return (values val t))))
       (t (multiple-value-setq (t1 t2)
	    (disjoint-typep (cadr x) y nil environment))
	  (values () (or t2 (subtypep-internal (cadr x) y environment)
			 (subtypep-internal y (cadr x) environment))))))
    ((and (consp y) (eq (car y) 'member))
     ;; Not quite right, (subtypep  '(integer 0 1 ) (member 0 1 2 ) should return t)
     (values nil t))
    ((symbolp y) (values (atom-subtypep (if (atom x) x (car x))
					y environment)
			 t))
    ((eq (car y) 'satisfies) (values nil nil ))
    ((consp x)
     (cond
       ((eq (car x) 'satisfies) (values nil nil))
       ((and (atom-subtypep (car x) (car y) environment)
	     (setq t1 (get (car y) 'subtypep-predicate)))
	(funcall t1 x y))
       (t (values () t))))
    (t (values () ()))))

;;  4/10/89 DNG - Add optional environment argument.
;;  4/25/89 DNG - Support use of class objects as type specifiers.
(defun subtypep (x y &optional (environment compiler:*local-environment*))
  "T if any object of type X must be of type Y.
The second value is T if the first value is accurate:
if the second value is T and the first is NIL,
then there are objects of type X that are not of type Y.
If the second value is NIL, it is not known whether X is really a subtype of Y."
  (declare (values known-to-be-subtype known-whether-is-subtype))
  (cond ((equal x y) (values t t))
	((eq y 't) (values t t))
	((classp x)
	 (if (consp y)
	     (values nil nil)
	   (let ((class (ticlos:class-named y t environment)))
	     (values (and class (ticlos:subclassp x class) t)
		     t))))
	((classp y)
	 (if (consp x)
	     (values nil nil)
	   (let ((class (ticlos:class-named x t environment)))
	     (values (and class (ticlos:subclassp class y) t)
		     t))))
	(t (subtypep-internal (type-canonicalize x environment)
			      (type-canonicalize y environment)
			      environment))))

;T if atomic type X is a subtype of atomic type Y.
;It is never impossible to tell, so only one value is returned.

;;;PHD-PAD 3/12/87 Added getdecl for structures and flavors
;;08/4/88 clm - fixed problem reported in 8423; (subtypep 'list 'atom) was incorrectly
;; returning T.
;;10/26/88 DNG - Use COMPILER:*COMPILE-FILE-ENVIRONMENT*; don't compute C2 until needed.
;;03/16/89 clm - Integrated CLOS changes into Kernel. 
;; 4/10/89 DNG - Added environment argument.
;; 4/25/89 DNG - Fix so that (SUBTYPEP '<class-or-flavor-name> 'INSTANCE) => T.
;; 4/26/89 DNG - Use GET-FLAVOR instead of COMPILATION-FLAVOR.
(defun atom-subtypep (x y &optional environment &aux t1 t2
		      (f1 (get-flavor x environment))
		      (f2 (get-flavor y environment)))
  (cond
    ((eq x y) t)
    
    (f1
     (or (eq y 'atom)
	 (eq y 'instance)
	 (and f2 (member y (dont-optimize (flavor-depends-on-all f1)) :test #'eq) t)))
    (f2 nil)
    ((or (and (setq t1 (getdecl x 'defstruct-description nil environment))
	      (defstruct-description-named-p t1))
	 (getdecl x 'defstruct-named-p nil environment))
     (if (member y '(structure atom array common) :test #'eq)
       t
       (and
	(or (and (setq t2 (getdecl y 'defstruct-description nil environment))
		 (defstruct-description-named-p t2))
	    (get y 'defstruct-named-p))
	(do ((symbol x
	      (and (setq t1 (getdecl symbol 'defstruct-description nil environment))
		 (car (defstruct-description-include t1)))))
	    ((null symbol)
	     nil)
	  (and (eq y symbol) (return t))))))
    (t (OR (not (null (member x (get y 'subtypes) :test #'eq)))
	   (LET ((c1 (ticlos:class-named x t environment))
		 c2)
	     (AND c1
		  (not (typep-structure-or-flavor c1 'ticlos:built-in-class))
		  (or (eq y 'atom)
		      (and (eq y 'instance)
			   (typep-structure-or-flavor c1 'ticlos:standard-class))
		      (and (setq c2 (ticlos:class-named y t environment))
			   (ticlos:subclassp c1 c2) t))))))))

;; Compare canonicalized types 

(defprop array array-subtypep subtypep-predicate) 

(defprop simple-array array-subtypep subtypep-predicate) 

(defun array-subtypep (type1 type2)
  (values
   (and
    (or (null (cdr type2)) (eq (cadr type2) '*)
       (and (cdr type1) (neq (cadr type1) '*)
	  (equal (type-canonicalize (cadr type1)) (type-canonicalize (cadr type2)))))
    (or (null (cddr type2)) (eq (caddr type2) '*)
       (and (cddr type1) (neq (caddr type1) '*)
	  (= (if (numberp (caddr type1))
	       (caddr type1)
	       (length (caddr type1)))
	     (if (numberp (caddr type2))
	       (caddr type2)
	       (length (caddr type2))))
	  (do ((1tail
		(if (consp (caddr type1))
		  (caddr type1)
		  (make-list (caddr type1) :initial-value '*))
		(cdr 1tail))
	       (2tail
		(if (consp (caddr type2))
		  (caddr type2)
		  (make-list (caddr type2) :initial-value '*))
		(cdr 2tail)))
	      ((null 1tail)
	       t)
	    (unless (or (eq (car 2tail) '*) (eql (car 1tail) (car 2tail)))
	      (return ()))))))
   t)) 


(defun (:property complex subtypep-predicate) (type1 type2)
  (subtypep (cadr type1) (cadr type2))) 


(defun (:property integer subtypep-predicate) (type1 type2)
  (values
   (and
    (or (member (cadr type2) '(nil *) :test #'eq)
       (and (not (member (cadr type1) '(nil *) :test #'eq))
	  (>= (if (consp (cadr type1))
		(1+ (caadr type1))
		(cadr type1))
	      (if (consp (cadr type2))
		(1+ (caadr type2))
		(cadr type2)))))
    (or (member (caddr type2) '(nil *) :test #'eq)
       (and (not (member (caddr type1) '(nil *) :test #'eq))
	  (<= (if (consp (caddr type1))
		(1- (caaddr type1))
		(caddr type1))
	      (if (consp (caddr type2))
		(1- (caaddr type2))
		(caddr type2))))))
   t)) 


(defprop rational dense-arithmetic-subtypep subtypep-predicate) 

(defprop float dense-arithmetic-subtypep subtypep-predicate) 

(defprop global:float dense-arithmetic-subtypep subtypep-predicate) 

(defprop short-float dense-arithmetic-subtypep subtypep-predicate) 

(defprop single-float dense-arithmetic-subtypep subtypep-predicate)

(defprop double-float dense-arithmetic-subtypep subtypep-predicate)

(defun dense-arithmetic-subtypep (type1 type2)
  (values
   (and
    (or (member (cadr type2) '(nil *) :test #'eq)
       (and (not (member (cadr type1) '(nil *) :test #'eq))
	  (if (and (consp (cadr type2)) (not (consp (cadr type1))))
	    (> (cadr type1) (caadr type2))
	    (>= (if (consp (cadr type1))
		  (caadr type1)
		  (cadr type1))
		(if (consp (cadr type2))
		  (caadr type2)
		  (cadr type2))))))
    (or (member (caddr type2) '(nil *) :test #'eq)
       (and (not (member (caddr type1) '(nil *) :test #'eq))
	  (if (and (consp (caddr type2)) (not (consp (caddr type1))))
	    (< (caddr type1) (caaddr type2))
	    (<= (if (consp (caddr type1))
		  (caaddr type1)
		  (caddr type1))
		(if (consp (caddr type2))
		  (caaddr type2)
		  (caddr type2)))))))
   t)) 

;;; DISJOINT-TYPEP

(eval-when (compile)
  (defun canonicalize-tree (tree)
    (if (atom tree)
	(type-canonicalize tree)
	(cons (canonicalize-tree (car tree)) (canonicalize-tree (cdr tree))))))

;;AB 8/3/87.  For PHD.  Change order of this list to fix type disjointedness for random-states/hashtables.  [SPR 4962]
(defvar subtypep-pairwise-disjoint-sets
	'#.(canonicalize-tree
	     '((integer fixnum bignum)
	       (rational ratio integer)
	       (number rational float complex)
	       (number real complex)
	       (list cons null)
	       (t list number hash-table readtable LISP:package pathname stream random-state)
	       (t cons symbol array number character locative instance closure lexical-closure
		  stack-group compiled-function microcode-function)
	       (t list array)
	       )))


;;PAD 1/16/87 If x is a list but not beginning with (and, or, etc.) go to last three tests.
;;PHD-PAD 2/6/87 Fix infinite recursion by preventing more than one call with swapped arguments.
;;AB for PHD 8/3/87.  Fix type disjointedness for structures & flavors.  [SPR 4962]
;;PHD 10/21/87 Protected GETDECL against X and Y not being symbols.[SPR 6753]
;;DNG  4/25/89 Fix to not error when given class objects.
;;DNG  4/26/89 Use GET-FLAVOR instead of COMPILATION-FLAVOR.  Pass environment 
;;		to GETDECL.  Extend to give useful answer for class objects.
(defun disjoint-typep (x y &optional deja-vu (environment compiler:*local-environment*) &aux t1 t2)
  (when (equal x y) (return-from disjoint-typep  (values nil t)))
  (let ((x (type-canonicalize x environment))
	(y (type-canonicalize y environment)))
    (when (equal x y) (return-from disjoint-typep  (values nil t)))
    (cond
      ((and (not (atom x)) (member (car x) '(or and not member satisfies array simple-array)))
       (case (car x)
	 (or 
	  (loop with val = t for x in (cdr x) do
	     (multiple-value-setq (t1 t2)
	       (disjoint-typep x y nil environment))
	     when (not t2) return (values () ()) do (setq val (and val t1)) finally
	     (return (values val t))))
	 (and
	  (loop with val = t for x in (cdr x) do
	     (multiple-value-setq (t1 t2)
	       (disjoint-typep x y nil environment))
	     when t1 return (values t t) do (setq val (and val t2)) finally
	     (return (values () val))))
	 (not (subtypep-internal y (cadr x) environment))
	 (member
	  (dolist ( x (cdr x) (return (values t t)))
	    (when (typep x y)
	      (return (values () t)))))
	 (satisfies (values nil nil))
	 ((array simple-array)
	  (cond
	    ((disjoint-typep (car x) y nil environment) (values t t))
	    ((atom y) (values () t))
	    ((member (car y) '(array simple-array) :test #'eq) (disjoint-array-typep x y environment))
	    (t (values nil nil))))
	 (t (values () ()))))
      ((or (classp x) (classp y))
       (if (or (consp x) (consp y))
	   (values nil nil)
	 (let ((cx (ticlos:class-named x t environment))
	       (cy (ticlos:class-named y t environment)))
	   (cond ((or (null cx) (null cy))
		  (values nil nil))
		 ((or (ticlos:subclassp cx cy) (ticlos:subclassp cy cx))
		  (values nil t))
		 ((or (null (ticlos:class-direct-subclasses cx))
		      (null (ticlos:class-direct-subclasses cy))
		      (disjoint-typep (ticlos:class-of cx) (ticlos:class-of cy) nil environment))
		  (values t t))
		 (t (values nil nil))))))
      ((or (subtypep-internal x y environment) (subtypep-internal y x environment))
       (values () t))
      ((not (atom y))(if deja-vu (values nil nil)  (disjoint-typep y x t environment)))
      ;; New clause (8/3/87)
      ((or (and (symbolp x)
		(or (getdecl x 'defstruct-description nil environment)
		    (get-flavor x environment)))  ;Fix for structures and
                                               ;flavors.
	   (and (symbolp y)
		(or (getdecl y 'defstruct-description nil environment)
		    (get-flavor y environment))))

       (values (and (not (subtypep-internal x y environment))
		    (not (subtypep-internal y x environment))) t))
      (t
       (loop for (a . b) in subtypep-pairwise-disjoint-sets
	     when (and (subtypep-internal x a environment) (subtypep-internal y a environment))
	     do
	     (let ((p (loop for tt in b when (subtypep-internal x tt environment) return tt))
		   (q (loop for tt in b when (subtypep-internal y tt environment) return tt)))
	       (when (and p q)
		 (return (values (not (eq p q)) t))))
	     finally (return (values () ()))))))) 

(defun disjoint-array-typep (x y environment)
  (or
   (and (not (member (cadr x) '(nil *) :test #'eq)) (not (member (cadr y) '(nil *) :test #'eq))
      (not (equal (type-canonicalize (cadr x) environment)
		  (type-canonicalize (cadr y) environment))))
   (and (cddr x) (neq (caddr x) '*) (cddr y) (neq (caddr y) '*)
      (not
       (equal (if (numberp (caddr x))
		(make-list (caddr x) :initial-value '*)
		(caddr x))
	      (if (numberp (caddr y))
		(make-list (caddr y) :initial-value '*)
		(caddr y)))))))


(defun coerce (object result-type)
  "Coerce OBJECT to an object of type RESULT-TYPE.  Only certain coercions are allowed.
Any sequence can be coerced to any sequence type if the elements are legal.
Strings, symbols and integers can be coerced to type CHARACTER.
Any number can be coerced to type COMPLEX.
Any real number can be coerced to any floating point number type."
  (if (typep object result-type)
      object
      (prog ((canon (type-canonicalize result-type)))
	    (case (if (atom canon)
		      canon
		      (car canon))
		  (list (if (typep object 'vector)
			    (return (coerce-to-list object))))
		  (short-float (if (realp object)
				   (return (small-float object))))
		  (single-float (if (realp object)
				    (return (internal-float object))))
		  (double-float (if (realp object)
				    (return (double-float object))))
		  ((float GLOBAL:float)
		   (if (realp object)
		       (return (float object))))
		  ((t) (return object))
		  (complex (return (complex object)))
		  ((character global:character)
		   (cond
		     ((stringp object) (if (= (length object) 1)
					   (return (aref object 0))))
		     ((symbolp object)
		      (if (= (length (symbol-name object)) 1)
			  (return (aref (symbol-name object) 0))))
		     ((integerp object) (return (int-char object)))))
		  ((array simple-array)
		   (when (typep object 'sequence)
		     (return
		       (make-array (length object) :initial-contents object :element-type
				   (if (atom canon)
				       t
				       (cadr canon)))))))
	    ;; If it did not already RETURN, this coercion is not allowed.
	    (ferror () "~S cannot be coerced to a ~S." object result-type)))) 


(defun coerce-to-character (x)
  "Convert X to a character if possible."
  (cond
    ((characterp x) x)
    ((numberp x) (int-char x))
    ((and (stringp x) (= (length x) 1)) (int-char (aref x 0)))
    ((and (symbolp x) (= (length (symbol-name x)) 1)) (int-char (aref (symbol-name x) 0)))
    (t (ferror () "Cannot coerce ~S into a character" x)))) 


(defun coerce-to-array (object element-type)
  (make-array (length object) :element-type element-type :initial-contents object)) 


(defun coerce-to-array-optimized (object array-type)
  (make-array (length object) :type array-type :initial-contents object)) 

; (deff coerce-to-list 'listarray) turned out to be wrong in case of strings 

(defun coerce-to-list (vector)
  (let ((list (make-list (length vector))))
    (do ((i 0 (1+ i))
	 (list list (cdr list)))
	((null list)
	 nil)
      (setf (car list) (aref vector i)))
    list)) 

(defun coerce-to-small-float (object)
  "Convert object to a small float if possible."
  (cond
    ((realp object) (small-float object))
    (t (ferror () "Cannot coerce ~S into a short float" object)))) 


(defun coerce-to-single-float (object)
  "Convert object to a single float if possible."
  (cond
    ((realp object) (internal-float object))
    (t (ferror () "Cannot coerce ~S into a single float" object))))   


(defun coerce-to-double-float (object)
  "Convert object to a double float if possible."
  (cond
    ((realp object) (double-float object))
    (t (ferror () "Cannot coerce ~S into a double float" object))))


(defun coerce-to-float (object)
  "Convert object to a  float if possible."
  (cond
    ((realp object) (float object))
    (t (ferror () "Cannot coerce ~S into a  float" object)))) 


(defun coerce-optimizer (form)
  (if (not (COMPILER:quotep  (caddr form)))
    form
    (let ((canon (type-canonicalize (cadr (caddr form))))
	  (object (cadr form)))
      (case (if (atom canon)
	 canon
	 (car canon))
	(list (once-only (object) `(the list
					(if (consp ,object)
					    ,object
					    (coerce-to-list ,object)))))
	(short-float `(coerce-to-small-float ,object))
	(single-float `(coerce-to-single-float ,object))
	(double-float `(coerce-to-double-float ,object))
	((float global:float) `(coerce-to-float ,object))
	((t) object)
	((character global:character) `(coerce-to-character ,object))
	((array simple-array)
	 `(coerce-to-array-optimized ,object
				     ',(array-type-from-element-type
					(if (atom canon)
					  t
					  (cadr canon)))))
	(t form))))) 

;;; Open coding of TYPEP.

;In QCOPT:
;(add-optimizer typep typep-two-args typep-structure typep-flavor
;	        subinstance-of-class-symbol-p)


;;phd 1/15/85 Change the type-of-alist lookup to symbolic-type-of-alist lookup
;;to be able to do cross compilation when the datatypes have changed.
;;phd 11/22/85 fixed flavor and defstruct part
;;Fixed some optimizations problems:
;;This function does not recurse anymore and relies on the compiler's 
;;optimizer driver to call it repeatedly until no optimization is being done.
;;The type expansion is done here instead of calling type-canonicalize that
;;would recurse and prevent intermediate optimizations.
;;PHD-PAD 3/12/87 Added getdecl for flavors and structures.
;;08/04/88 clm - if the type will need to be known at load time, but the
;;               class is undefined at that time, send signal to CLASS-NAMED to create 
;;               the class on the fly to prevent unloadable xlds.  Changes also made to
;;               CLASS-NAMED to do the actual creation.
;;08/25/88 clm - for CLOS, only generate a TYPEP-STRUCTURE-OR-FLAVOR instruction
;;               if the class object is of type standard-class.
;;03/06/89 clm - don't try to handle type-predicates which are not symbols.  Genasys cannot handle
;;               the forms this would generate.
;;03/16/89 clm - Integrated CLOS changes into Kernel.
;; 5/01/89 DNG - Fix to not trap on a type which is not a symbol, class, or cons.
(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)) `(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)))


(defvar type-pretty-name-hash-table (make-hash-table :test 'equal :size 500))


(defun type-pretty-name (type)
  "Return a string containing a noun phrase describing objects of type TYPE."
  ;; Prevent lossage if TYPE was consed in a temporary area.
  (let ((default-cons-area background-cons-area))
    (or (gethash type type-pretty-name-hash-table)
	(progn
	  (setq type (copy-tree type))
	  (setf (gethash type type-pretty-name-hash-table)
		(cond
		  ((symbolp type)
		   (or (get type 'type-name)
		       (string-append-a-or-an
			 (string-subst-char #\Space #\- (string-downcase (format () "~a" type)) ()))))
		  ((and (consp type) (funcall (get (car type) 'type-name-function #'ignore) type)))
		  (t (string-append (format () "an object of type ~S" type ))))))))) 

 


;;; Is this still used anywhere ???? HS

(defun type-pretty-name-1 (type)
  (cond
    ((symbolp type)
     (if (or (get type 'type-name)
	 (string-append-a-or-an (string-subst-char #\Space #\- (string-downcase type) ())))
       (string-append "a " (string-downcase (format () "~a" type)))))
    ((member type '((integer 0) (float 0)) :test #'equal)
     (string-append "a positive " (string-downcase (symbol-name (car type)))))
    ((and (eq (car type) 'or)
	(dolist (elt (cdr type) t)
	  (unless (type-pretty-name-1 elt)
	    (return ()))))
     (format:output ()
	(do ((tail (cdr type) (cdr tail)))
	    ((null tail))
	  (when (and (not (cdr tail)) (cddr type))
	    (princ "or "))
	  (princ (type-pretty-name-1 (car tail)))
	  (when (cdr tail)
	    (if (cddr tail)
	      (princ ", ")
	      (write-char #\Space))))))
    ((eq (car type) 'member)
     (format:output ()
	(do ((tail (cdr type) (cdr tail)))
	    ((null tail))
	  (when (and (not (cdr tail)) (cddr type))
	    (princ "or "))
	  (prin1 (car tail))
	  (when (cdr tail)
	    (if (cddr tail)
	      (princ ", ")
	      (write-char #\Space)))))))) 


(defun (:property or type-name-function) (type)
  (when (dolist (elt (cdr type) t)
     (unless (type-pretty-name elt)
       (return ())))
    (string-append
     (format:output ()
	(do ((tail (cdr type) (cdr tail)))
	    ((null tail))
	  (when (and (not (cdr tail)) (cddr type))
	    (princ "or "))
	  (princ (type-pretty-name (car tail)))
	  (when (cdr tail)
	    (if (cddr tail)
	      (princ ", ")
	      (write-char #\Space)))))))) 


(defun (:property member type-name-function) (type)
  (string-append
   (format:output ()
      (do ((tail (cdr type) (cdr tail)))
	  ((null tail))
	(when (and (not (cdr tail)) (cddr type))
	  (princ "or "))
	(prin1 (car tail))
	(when (cdr tail)
	  (if (cddr tail)
	    (princ ", ")
	    (write-char #\Space))))))) 


(defun (:property integer type-name-function) (type)
  (let ((low
	 (cond
	   ((null (cdr type)) '*)
	   ((consp (cadr type)) (car (cadr type)))
	   ((integerp (cadr type)) (1- (cadr type)))
	   (t (cadr type))))
	(high
	 (cond
	   ((null (cddr type)) '*)
	   ((consp (caddr type)) (car (caddr type)))
	   ((integerp (caddr type)) (1+ (caddr type)))
	   (t (caddr type)))))
    (cond
      ((and (eq low '*) (eq high '*)) "an integer")
      ((and (eq low -1) (eq high '*)) "a positive integer")
      ((and (eq high 1) (eq low '*)) "a negative integer")
      ((eq high '*) (string-append (format () "an integer greater than ~D" low)))
      ((eq low '*) (string-append (format () "an integer less than ~D" high)))
      (t (string-append (format () "an integer between ~D and ~D (exclusive)" low high)))))) 


(defun (:property real type-name-function) (type)
  (float-type-name-function "real number" type)) 


(defun (:property float type-name-function) (type)
  (float-type-name-function "float" type)) 

(defun (:property global:float type-name-function) (type)
  (float-type-name-function "float" type)) 

(defun (:property short-float type-name-function) (type)
  (float-type-name-function "short float" type)) 

(defun (:property single-float type-name-function) (type)
  (float-type-name-function "single float" type))

(defun (:property double-float type-name-function) (type)
  (float-type-name-function "double float" type))


(defun float-type-name-function (string type)
  (let ((low (if (null (cdr type))
	       '*
	       (cadr type)))
	(high (if (null (cddr type))
		'*
		(caddr type)))
	lowex
	highex)
    (if (consp low)
      (setq low (car low)
	    lowex t))
    (if (consp high)
      (setq high (car high)
	    highex t))
    (cond
      ((and (eq low '*) (eq high '*)) (string-append "a " string))
      ((and (eq low 0) (eq high '*))
       (if lowex
	 (string-append "a positive " string)
	 (string-append "a non-negative " string)))
      ((and (eq high 0) (eq low '*))
       (if highex
	 (string-append "a negative " string)
	 (string-append "a non-positive " string)))
      ((eq high '*) (string-append (format () "a ~A ~:[~;>~] ~D" string lowex low)))
      ((eq low '*) (string-append (format () "a ~A ~:[~;<~] ~D" string highex high)))
      (t
       (string-append
	(format () "a ~A satisfying ~D ~:[~;<~] ~A ~:[~;<~] ~D" string low lowex string highex
		high)))))) 


(defun (:property complex type-name-function) (type)
  (case (cadr type)
    ((nil real) "a complex number")
    (rational "a rational complex number")
    (short-float "a complex number with short-float components")
    (single-float "a complex number with single-float components")
    (long-float "a complex number with long-float components")
    (double-float "a complex number with double-float components")
    ((float global:float) "a complex number with floating-point components")
    (t nil))) 


;;PHD 3/26/87 remove duplicate definition
;;;(defun (:property complex type-predicate) (object &optional type)
;;;  (and (complexp object)
;;;     (or (member type '(nil *) :test #'eq) (typep (complex-real-part object) type)))) 


(eval-when (load)
  (fixup-type-properties)
)