(in-package "SB!KERNEL")
-;;; The actual TYPEP engine. The compiler only generates calls to this
+;;; the actual TYPEP engine. The compiler only generates calls to this
;;; function when it can't figure out anything more intelligent to do.
(defun %typep (object specifier)
(%%typep object
(or (eq (car want) '*)
(= (car want) (car got))))
(return nil))))
+ (if (unknown-type-p (array-type-element-type type))
+ ;; better to fail this way than to get bogosities like
+ ;; (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T
+ (error "~@<unknown element type in array type: ~2I~_~S~:>"
+ (type-specifier type))
+ t)
(or (eq (array-type-element-type type) *wild-type*)
(values (type= (array-type-specialized-element-type type)
(specifier-type (array-element-type
#+sb-xc-host (ctypep object type)
#-sb-xc-host (class-typep (layout-of object) type object))
(union-type
- (dolist (type (union-type-types type))
- (when (%%typep object type)
- (return t))))
+ (some (lambda (union-type-type) (%%typep object union-type-type))
+ (union-type-types type)))
+ (intersection-type
+ (every (lambda (intersection-type-type)
+ (%%typep object intersection-type-type))
+ (intersection-type-types type)))
+ (cons-type
+ (and (consp object)
+ (%%typep (car object) (cons-type-car-type type))
+ (%%typep (cdr object) (cons-type-cdr-type type))))
(unknown-type
;; dunno how to do this ANSIly -- WHN 19990413
#+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host")
(hairy-type
;; Now the tricky stuff.
(let* ((hairy-spec (hairy-type-specifier type))
- (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
+ (symbol (car hairy-spec)))
(ecase symbol
(and
- (or (atom hairy-spec)
- (dolist (spec (cdr hairy-spec) t)
- (unless (%%typep object (specifier-type spec))
- (return nil)))))
+ (every (lambda (spec) (%%typep object (specifier-type spec)))
+ (rest hairy-spec)))
+ ;; Note: it should be safe to skip OR here, because union
+ ;; types can always be represented as UNION-TYPE in general
+ ;; or other CTYPEs in special cases; we never need to use
+ ;; HAIRY-TYPE for them.
(not
(unless (proper-list-of-length-p hairy-spec 2)
(error "invalid type specifier: ~S" hairy-spec))
(satisfies
(unless (proper-list-of-length-p hairy-spec 2)
(error "invalid type specifier: ~S" hairy-spec))
- (let ((fn (cadr hairy-spec)))
- (if (funcall (typecase fn
- (function fn)
- (symbol (symbol-function fn))
- (t
- (coerce fn 'function)))
- object)
- t
- nil))))))
+ (values (funcall (symbol-function (cadr hairy-spec)) object))))))
(alien-type-type
(sb!alien-internals:alien-typep object (alien-type-type-alien-type type)))
- (function-type
+ (fun-type
(error "Function types are not a legal argument to TYPEP:~% ~S"
(type-specifier type)))))
-;;; Do type test from a class cell, allowing forward reference and
+;;; Do a type test from a class cell, allowing forward reference and
;;; redefinition.
(defun class-cell-typep (obj-layout cell object)
(let ((class (class-cell-class cell)))
(error "The class ~S has not yet been defined." (class-cell-name cell)))
(class-typep obj-layout class object)))
-;;; Test whether Obj-Layout is from an instance of Class.
+;;; Test whether OBJ-LAYOUT is from an instance of CLASS.
(defun class-typep (obj-layout class object)
(declare (optimize speed))
(when (layout-invalid obj-layout)