X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-type.lisp;h=ddf35edcfbb567b723ca0965af6a2114f97061e7;hb=01044af1b8d69fc3899dc0417064c1512223223d;hp=a3ec9c689eb1ac4fd3b44e35fed23ca935ced429;hpb=416152f084604094445a758ff399871132dff2bd;p=sbcl.git diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index a3ec9c6..ddf35ed 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,15 +33,15 @@ named-type member-type array-type - sb!xc:built-in-class + 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))) @@ -63,12 +52,18 @@ #'ctypep obj (compound-type-types type))) - (function-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)) @@ -92,7 +87,26 @@ (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) + (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))))))))) ;;; Return the layout for an object. This is the basic operation for @@ -115,33 +129,29 @@ ;; 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))))) + (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) - (typecase fun - ;; FIXME: byte compiler to be deleted completely - #| - (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 @@ -149,14 +159,15 @@ 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)) @@ -166,8 +177,8 @@ (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 @@ -181,7 +192,7 @@ (cons (make-cons-type *universal-type* *universal-type*)) (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*)