X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Ftarget-type.lisp;h=20945cffa00ed29c1ce3bc22282b0e0d0244c1e5;hb=c8af15e61b030c8d4b0e950bc9b7618530044618;hp=b3415d24e4cbc1f55db04b8da159546e906c08b2;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index b3415d2..20945cf 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -19,23 +19,24 @@ ;;; 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." (%typep object type)) -;;; If Type is a type that we can do a compile-time test on, then return the -;;; whether the object is of that type as the first value and second value -;;; true. Otherwise return NIL, NIL. +;;; 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. +;;; +;;; 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. ;;; -;;; 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. +;;; 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 @@ -43,7 +44,8 @@ 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)) @@ -54,11 +56,29 @@ (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 @@ -85,29 +105,18 @@ (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))))))))) -;;; 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))) @@ -145,23 +154,24 @@ ;;;; 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)) @@ -200,6 +210,8 @@ :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))))