X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-type.lisp;h=f8dccd315ed0a03a90ea63a29d53d486bfb4d5d6;hb=2034cb134af58c5998f4e305673af6e2c75bc179;hp=de27d70e8db66ecfa8031f4e2d192c396ac021a8;hpb=f0670f28705c01e79fb23cb2a582074d3e51ec98;p=sbcl.git diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index de27d70..f8dccd3 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -13,17 +13,6 @@ (!begin-collecting-cold-init-forms) -;;; 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. @@ -44,47 +33,38 @@ named-type member-type array-type - sb!xc:built-in-class + character-set-type + built-in-classoid cons-type) (values (%typep obj type) t)) - (sb!xc:class + (classoid (if (if (csubtypep type (specifier-type 'funcallable-instance)) (funcallable-instance-p obj) (typep obj 'instance)) - (if (eq (class-layout type) - (info :type :compiler-layout (sb!xc:class-name type))) + (if (eq (classoid-layout type) + (info :type :compiler-layout (classoid-name type))) (values (sb!xc:typep obj type) t) (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)) (alien-type-type (values (alien-typep obj (alien-type-type-alien-type type)) t)) + (negation-type + (multiple-value-bind (res win) + (ctypep obj (negation-type-type type)) + (if win + (values (not res) t) + (values nil nil)))) (hairy-type ;; Now the tricky stuff. (let* ((hairy-spec (hairy-type-specifier type)) @@ -105,29 +85,37 @@ (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) + (let* (;; "Is OBJ of the SATISFIES type?" represented + ;; as a generalized boolean. + ;; + ;; (Why IGNORE-ERRORS? This code is used to try to + ;; check type relationships at compile time. + ;; Passing only-slightly-twisted types like + ;; (AND INTEGER (SATISFIES ODDP)) into the + ;; rather-significantly-twisted type dispatch + ;; system can easily give rise to oddities like + ;; calling predicates like ODDP on values they + ;; don't like. (E.g. on OBJ=#\NEWLINE when the + ;; above type is tested for TYPE= against + ;; STANDARD-CHAR, represented as a + ;; MEMBER-TYPE.) In such cases, NIL seems to be + ;; an appropriate answer to "is OBJ of the + ;; SATISFIES type?") + (gbool (ignore-errors (funcall predicate-name obj))) + ;; RAW coerced to a pure BOOLEAN value + (bool (not (not gbool)))) + (values bool 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))) @@ -139,50 +127,48 @@ ;; 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 - (declare (notinline sb!xc:find-class)) - (class-layout (sb!xc:find-class 'null)))) - (t (svref *built-in-class-codes* (get-type x))))) + ;; 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 find-classoid)) + (classoid-layout (find-classoid 'null)))) + (t (svref *built-in-class-codes* (widetag-of x))))) -#!-sb-fluid (declaim (inline sb!xc:class-of)) -(defun sb!xc:class-of (object) +#!-sb-fluid (declaim (inline classoid-of)) +(defun classoid-of (object) #!+sb-doc "Return the class of the supplied object, which may be any Lisp object, not just a CLOS STANDARD-OBJECT." - (layout-class (layout-of object))) + (layout-classoid (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)))) ;;;; miscellaneous interfaces ;;; Clear memoization of all type system operations that can be ;;; altered by type definition/redefinition. +;;; +;;; FIXME: This should be autogenerated. (defun clear-type-caches () + (declare (special *type-system-initialized*)) (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-intersection2-cache-clear - values-type-intersection-cache-clear)) - (funcall (symbol-function sym)))) + values-type-intersection-cache-clear + type=-cache-clear)) + (funcall (the function (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)) @@ -192,29 +178,12 @@ (typecase x (function (if (funcallable-instance-p x) - (sb!xc:class-of x) - (extract-function-type x))) + (classoid-of 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) @@ -223,8 +192,10 @@ :specialized-element-type etype))) (cons (make-cons-type *universal-type* *universal-type*)) + (character + (specifier-type 'character)) (t - (sb!xc:class-of x)))) + (classoid-of x)))) ;;; Clear this cache on GC so that we don't hold onto too much garbage. (pushnew 'ctype-of-cache-clear *before-gc-hooks*)