;;; 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.)
-;;;
-;;; KLUDGE: In classic CMU CL this was wrapped in a (DECLAIM (START-BLOCK
-;;; TYPEP %TYPEP CLASS-CELL-TYPEP)) to make calls efficient. Once I straighten
-;;; out bootstrapping and cross-compiling issues it'd likely be a good idea to
-;;; do this again. -- WHN 19990413
(defun typep (object type)
#!+sb-doc
"Return T iff OBJECT is of type TYPE."
;;; 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
named-type
member-type
array-type
- sb!xc:built-in-class)
+ sb!xc:built-in-class
+ cons-type)
(values (%typep obj type) t))
(sb!xc:class
(if (if (csubtypep type (specifier-type 'funcallable-instance))
(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
+ (funcall (etypecase type
+ (intersection-type #'every/type)
+ (union-type #'any/type))
+ #'ctypep
+ obj
+ (compound-type-types type)))
(function-type
(values (functionp obj) t))
(unknown-type
(values (not res) t)
(values nil nil))))
(satisfies
- ;; KLUDGE: This stuff might well blow up if we tried to execute it
- ;; when cross-compiling. But since for the foreseeable future the
- ;; only code we'll try to cross-compile is SBCL itself, and SBCL is
- ;; built without using SATISFIES types, it's arguably not important
- ;; to worry about this. -- WHN 19990210.
- (let ((fun (second hairy-spec)))
- (cond ((and (consp fun)
- (eq (car fun) 'lambda))
- (values (not (null (funcall (coerce fun 'function) obj)))
- t))
- ((and (symbolp fun) (fboundp fun))
- (values (not (null (funcall fun obj))) t))
- (t
- (values nil nil))))))))))
+ (let ((predicate-name (second hairy-spec)))
+ (declare (type symbol predicate-name)) ; by ANSI spec of SATISFIES
+ (if (fboundp predicate-name)
+ (values (not (null (funcall predicate-name obj))) t)
+ (values nil nil)))))))))
\f
-;;; LAYOUT-OF -- Exported
-;;;
-;;; Return the layout for an object. This is the basic operation for
-;;; finding out the "type" of an object, and is used for generic function
-;;; dispatch. The standard doesn't seem to say as much as it should about what
-;;; this returns for built-in objects. For example, it seems that we must
-;;; return NULL rather than LIST when X is NIL so that GF's can specialize on
-;;; NULL.
+;;; Return the layout for an object. This is the basic operation for
+;;; finding out the "type" of an object, and is used for generic
+;;; function dispatch. The standard doesn't seem to say as much as it
+;;; should about what this returns for built-in objects. For example,
+;;; it seems that we must return NULL rather than LIST when X is NIL
+;;; so that GF's can specialize on NULL.
#!-sb-fluid (declaim (inline layout-of))
(defun layout-of (x)
(declare (optimize (speed 3) (safety 0)))
;; 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)))))
;;; 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)))
+ (cond #!+sb-interpreter
+ ((sb!eval:interpreted-function-p fun)
+ (sb!eval:interpreted-function-type fun))
(t
- (specifier-type (%function-type (%closure-function 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))))))))
\f
;;;; miscellaneous interfaces
-;;; Clear memoization of all type system operations that can be altered by
-;;; type definition/redefinition.
+;;; Clear memoization of all type system operations that can be
+;;; altered by type definition/redefinition.
(defun clear-type-caches ()
(when *type-system-initialized*
(dolist (sym '(values-specifier-type-cache-clear
values-type-union-cache-clear
- type-union-cache-clear
+ type-union2-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))
-;;; 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.
+;;; 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))
(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)
:complexp (not (typep x 'simple-array))
:element-type etype
:specialized-element-type etype)))
+ (cons
+ (make-cons-type *universal-type* *universal-type*))
(t
(sb!xc:class-of x))))
projects / sbcl.git / blobdiff