;;; return whether the object is of that type as the first value and
;;; second value true. Otherwise return NIL, NIL.
;;;
-;;; We give up on unknown types and pick off FUNCTION and UNION types.
-;;; For structure types, we require that the type be defined in both
-;;; the current and compiler environments, and that the INCLUDES be
-;;; the same.
+;;; We give up on unknown types and pick off FUNCTION- and COMPOUND-
+;;; types. For STRUCTURE- types, we require that the type be defined
+;;; in both the current and compiler environments, and that the
+;;; INCLUDES be the same.
+;;;
+;;; KLUDGE: This should probably be a type method instead of a big
+;;; ETYPECASE. But then the type method system should probably be CLOS
+;;; too, and until that happens wedging more stuff into it might be
+;;; messy. So I've left it a big ETYPECASE. -- 2001-03-16
(defun ctypep (obj type)
(declare (type ctype type))
(etypecase type
(values (sb!xc:typep obj type) t)
(values nil nil))
(values nil t)))
- (union-type
- (dolist (mem (union-type-types type) (values nil t))
- (multiple-value-bind (val win) (ctypep obj mem)
- (unless win (return (values nil nil)))
- (when val (return (values t t))))))
+ (compound-type
+ ;; REMOVEME: old version
+ #|
+ (let ((certain? t))
+ (etypecase type
+ (union-type
+ (dolist (mem (union-type-types type) (values nil certain?))
+ (multiple-value-bind (val win) (ctypep obj mem)
+ (if win
+ (when val (return (values t t)))
+ (setf certain? nil)))))
+ (intersection-type
+ (dolist (mem (intersection-type-types type)
+ (if certain? (values t t) (values nil nil)))
+ (multiple-value-bind (val win) (ctypep obj mem)
+ (if win
+ (unless val (return (values nil t)))
+ (setf certain? nil)))))))
+ |#
+ (let ((types (compound-type-types type)))
+ (etypecase type
+ (intersection-type (every/type #'ctypep obj types))
+ (union-type (any/type #'ctypep obj types)))))
(function-type
(values (functionp obj) t))
(unknown-type
type-union-cache-clear
values-subtypep-cache-clear
csubtypep-cache-clear
- type-intersection-cache-clear
+ type-intersection2-cache-clear
values-type-intersection-cache-clear))
(funcall (symbol-function sym))))
(values))