(!begin-collecting-cold-init-forms)
\f
-;;; Just call %TYPEP.
-;;;
-;;; Note that when cross-compiling, SB!XC:TYPEP is interpreted as
-;;; a 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)
- #!+sb-doc
- "Return T iff OBJECT is of type TYPE."
- (%typep object type))
-
;;; If TYPE is a type that we can do a compile-time test on, then
;;; return whether the object is of that type as the first value and
;;; second value true. Otherwise return NIL, NIL.
(values nil nil))
(values nil 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
+ (funcall (etypecase type
+ (intersection-type #'every/type)
+ (union-type #'any/type))
+ #'ctypep
+ obj
+ (compound-type-types type)))
+ (fun-type
(values (functionp obj) t))
(unknown-type
(values nil nil))
;; run time in order to make it easier to build the cross-compiler.
;; If it doesn't work, something else will be needed..
(locally
- ;; KLUDGE: In order to really make it run at run time (instead of
- ;; doing some weird broken thing at cold load time),
- ;; we need to suppress a DEFTRANSFORM.. -- WHN 19991004
+ ;; KLUDGE: In order to really make this run at run time
+ ;; (instead of doing some weird broken thing at cold load
+ ;; time), we need to suppress a DEFTRANSFORM.. -- WHN 19991004
(declare (notinline sb!xc:find-class))
(class-layout (sb!xc:find-class 'null))))
- (t (svref *built-in-class-codes* (get-type x)))))
+ (t (svref *built-in-class-codes* (widetag-of x)))))
#!-sb-fluid (declaim (inline sb!xc:class-of))
(defun sb!xc:class-of (object)
(layout-class (layout-of object)))
;;; Pull the type specifier out of a function object.
-(defun extract-function-type (fun)
- (if (sb!eval:interpreted-function-p fun)
- (sb!eval:interpreted-function-type fun)
- (typecase fun
- (byte-function (byte-function-type fun))
- (byte-closure (byte-function-type (byte-closure-function fun)))
- (t
- (specifier-type (%function-type (%closure-function fun)))))))
+(defun extract-fun-type (fun)
+ (specifier-type (%simple-fun-type (%closure-fun fun))))
\f
;;;; miscellaneous interfaces
(funcall (symbol-function sym))))
(values))
-;;; Like TYPE-OF, only we return a CTYPE structure instead of a type
-;;; specifier, and we try to return the type most useful for type
-;;; checking, rather than trying to come up with the one that the user
-;;; might find most informative.
+;;; This is like TYPE-OF, only we return a CTYPE structure instead of
+;;; a type specifier, and we try to return the type most useful for
+;;; type checking, rather than trying to come up with the one that the
+;;; user might find most informative.
(declaim (ftype (function (t) ctype) ctype-of))
(defun-cached (ctype-of
:hash-function (lambda (x) (logand (sxhash x) #x1FF))
(function
(if (funcallable-instance-p x)
(sb!xc:class-of x)
- (extract-function-type x)))
+ (extract-fun-type x)))
(symbol
(make-member-type :members (list x)))
(number
- (let* ((num (if (complexp x) (realpart x) x))
- (res (make-numeric-type
- :class (etypecase num
- (integer 'integer)
- (rational 'rational)
- (float 'float))
- :format (if (floatp num)
- (float-format-name num)
- nil))))
- (cond ((complexp x)
- (setf (numeric-type-complexp res) :complex)
- (let ((imag (imagpart x)))
- (setf (numeric-type-low res) (min num imag))
- (setf (numeric-type-high res) (max num imag))))
- (t
- (setf (numeric-type-low res) num)
- (setf (numeric-type-high res) num)))
- res))
+ (ctype-of-number x))
(array
(let ((etype (specifier-type (array-element-type x))))
(make-array-type :dimensions (array-dimensions x)