X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-type.lisp;h=871cb84eb07de09894f52a11beb47e40af40a6a7;hb=959057baab99d4328fc386aee3fcc812f5fcb3ed;hp=7ebfccf60fdd2f34a0efab47e6f467167b9dac90;hpb=ce02ab2ecd9c6ae2e570abd8c93ebf3be55bbdad;p=sbcl.git diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index 7ebfccf..871cb84 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -32,6 +32,11 @@ ;;; 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 @@ -52,29 +57,12 @@ (values nil nil)) (values nil t))) (compound-type - (let ((certain? t)) - (etypecase type - ;; FIXME: The cases here are very similar to #'EVERY/TYPE and - ;; #'ANY/TYPE. It would be good to fix them so that they - ;; share the same code. (That will require making sure that - ;; the two-value return convention for CTYPEP really is - ;; exactly compatible with the two-value convention the - ;; quantifier/TYPE functions operate on, and probably also - ;; making sure that things are inlined and defined early - ;; enough that consing can be avoided.) - (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)))))))) + (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 @@ -101,29 +89,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))) @@ -135,9 +112,9 @@ ;; 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))))) @@ -151,13 +128,11 @@ ;;; 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))))))) + (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)))))) ;;;; miscellaneous interfaces @@ -167,7 +142,7 @@ (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 @@ -193,24 +168,7 @@ (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)