;;; test that the host Lisp object OBJECT translates to a target SBCL
;;; type TYPE. This behavior is needed e.g. to test for the validity
;;; of numeric subtype bounds read when cross-compiling.)
-(defun typep (object type)
+(defun typep (object type &optional environment)
#!+sb-doc
"Is OBJECT of type TYPE?"
+ (declare (ignore environment))
;; Actually interpreting types at runtime is done by %TYPEP. The
;; cost of the extra function call here should be negligible
;; compared to the cost of interpreting types. (And the compiler
(long-float (typep num 'long-float))
((nil) (floatp num))))
((nil) t)))
- #!-negative-zero-is-not-zero
(flet ((bound-test (val)
(let ((low (numeric-type-low type))
(high (numeric-type-high type)))
(bound-test (imagpart object))))
(:real
(and (not (complexp object))
- (bound-test object)))))
- #!+negative-zero-is-not-zero
- (labels ((signed-> (x y)
- (if (and (zerop x) (zerop y) (floatp x) (floatp y))
- (> (float-sign x) (float-sign y))
- (> x y)))
- (signed->= (x y)
- (if (and (zerop x) (zerop y) (floatp x) (floatp y))
- (>= (float-sign x) (float-sign y))
- (>= x y)))
- (bound-test (val)
- (let ((low (numeric-type-low type))
- (high (numeric-type-high type)))
- (and (cond ((null low) t)
- ((listp low)
- (signed-> val (car low)))
- (t
- (signed->= val low)))
- (cond ((null high) t)
- ((listp high)
- (signed-> (car high) val))
- (t
- (signed->= high val)))))))
- (ecase (numeric-type-complexp type)
- ((nil) t)
- (:complex
- (and (complexp object)
- (bound-test (realpart object))
- (bound-test (imagpart object))))
- (:real
- (and (not (complexp object))
(bound-test object)))))))
(array-type
(and (arrayp object)
object)))))))
(member-type
(if (member object (member-type-members type)) t))
- (sb!xc:class
+ (classoid
#+sb-xc-host (ctypep object type)
- #-sb-xc-host (class-typep (layout-of object) type object))
+ #-sb-xc-host (classoid-typep (layout-of object) type object))
(union-type
(some (lambda (union-type-type) (%%typep object union-type-type))
(union-type-types type)))
(and (consp object)
(%%typep (car object) (cons-type-car-type type))
(%%typep (cdr object) (cons-type-cdr-type type))))
+ (character-set-type
+ (and (characterp object)
+ (let ((code (char-code object))
+ (pairs (character-set-type-pairs type)))
+ (dolist (pair pairs nil)
+ (destructuring-bind (low . high) pair
+ (when (<= low code high)
+ (return t)))))))
(unknown-type
;; dunno how to do this ANSIly -- WHN 19990413
#+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host")
(error "unknown type specifier: ~S"
(unknown-type-specifier reparse))
(%%typep object reparse))))
+ (negation-type
+ (not (%%typep object (negation-type-type type))))
(hairy-type
;; Now the tricky stuff.
(let* ((hairy-spec (hairy-type-specifier type))
;;; 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)))
- (unless class
- (error "The class ~S has not yet been defined." (class-cell-name cell)))
- (class-typep obj-layout class object)))
+(defun classoid-cell-typep (obj-layout cell object)
+ (let ((classoid (classoid-cell-classoid cell)))
+ (unless classoid
+ (error "The class ~S has not yet been defined."
+ (classoid-cell-name cell)))
+ (classoid-typep obj-layout classoid object)))
-;;; Test whether OBJ-LAYOUT is from an instance of CLASS.
-(defun class-typep (obj-layout class object)
+;;; Test whether OBJ-LAYOUT is from an instance of CLASSOID.
+(defun classoid-typep (obj-layout classoid object)
(declare (optimize speed))
(when (layout-invalid obj-layout)
- (if (and (typep (sb!xc:class-of object) 'sb!xc:standard-class) object)
- (setq obj-layout (pcl-check-wrapper-validity-hook object))
+ (if (and (typep (classoid-of object) 'standard-classoid) object)
+ (setq obj-layout (sb!pcl::check-wrapper-validity object))
(error "TYPEP was called on an obsolete object (was class ~S)."
- (class-proper-name (layout-class obj-layout)))))
- (let ((layout (class-layout class))
+ (classoid-proper-name (layout-classoid obj-layout)))))
+ (let ((layout (classoid-layout classoid))
(obj-inherits (layout-inherits obj-layout)))
(when (layout-invalid layout)
- (error "The class ~S is currently invalid." class))
+ (error "The class ~S is currently invalid." classoid))
(or (eq obj-layout layout)
(dotimes (i (length obj-inherits) nil)
(when (eq (svref obj-inherits i) layout)
(return t))))))
-;;; to be redefined as PCL::CHECK-WRAPPER-VALIDITY when PCL is loaded
-;;;
-;;; FIXME: should probably be renamed SB!PCL:CHECK-WRAPPER-VALIDITY
-(defun pcl-check-wrapper-validity-hook (object)
+;;; This implementation is a placeholder to use until PCL is set up,
+;;; at which time it will be overwritten by a real implementation.
+(defun sb!pcl::check-wrapper-validity (object)
object)
projects / sbcl.git / blobdiff