src/code/target-type.lisp

   1 ;;;; type-related stuff which exists only in the target SBCL runtime
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!KERNEL")
  13
  14 (!begin-collecting-cold-init-forms)
  15 \f
  16 ;;; Just call %TYPEP.
  17 ;;;
  18 ;;; Note that when cross-compiling, SB!XC:TYPEP is interpreted as
  19 ;;; a test that the host Lisp object OBJECT translates to a target SBCL
  20 ;;; type TYPE. (This behavior is needed e.g. to test for the validity of
  21 ;;; numeric subtype bounds read when cross-compiling.)
  22 (defun typep (object type)
  23   #!+sb-doc
  24   "Return T iff OBJECT is of type TYPE."
  25   (%typep object type))
  26
  27 ;;; If TYPE is a type that we can do a compile-time test on, then
  28 ;;; return whether the object is of that type as the first value and
  29 ;;; second value true. Otherwise return NIL, NIL.
  30 ;;;
  31 ;;; We give up on unknown types and pick off FUNCTION- and COMPOUND-
  32 ;;; types. For STRUCTURE- types, we require that the type be defined
  33 ;;; in both the current and compiler environments, and that the
  34 ;;; INCLUDES be the same.
  35 ;;;
  36 ;;; KLUDGE: This should probably be a type method instead of a big
  37 ;;; ETYPECASE. But then the type method system should probably be CLOS
  38 ;;; too, and until that happens wedging more stuff into it might be
  39 ;;; messy. So I've left it a big ETYPECASE. -- 2001-03-16
  40 (defun ctypep (obj type)
  41   (declare (type ctype type))
  42   (etypecase type
  43     ((or numeric-type
  44          named-type
  45          member-type
  46          array-type
  47          sb!xc:built-in-class
  48          cons-type)
  49      (values (%typep obj type) t))
  50     (sb!xc:class
  51      (if (if (csubtypep type (specifier-type 'funcallable-instance))
  52              (funcallable-instance-p obj)
  53              (typep obj 'instance))
  54          (if (eq (class-layout type)
  55                  (info :type :compiler-layout (sb!xc:class-name type)))
  56              (values (sb!xc:typep obj type) t)
  57              (values nil nil))
  58          (values nil t)))
  59     (compound-type
  60      ;; REMOVEME: old version
  61      #|
  62      (let ((certain? t))
  63        (etypecase type
  64          (union-type
  65           (dolist (mem (union-type-types type) (values nil certain?))
  66             (multiple-value-bind (val win) (ctypep obj mem)
  67               (if win
  68                   (when val (return (values t t)))
  69                   (setf certain? nil)))))
  70          (intersection-type
  71           (dolist (mem (intersection-type-types type)
  72                        (if certain? (values t t) (values nil nil)))
  73             (multiple-value-bind (val win) (ctypep obj mem)
  74               (if win
  75                   (unless val (return (values nil t)))
  76                   (setf certain? nil)))))))
  77      |#
  78      (let ((types (compound-type-types type)))
  79        (etypecase type
  80          (intersection-type (every/type #'ctypep obj types))
  81          (union-type        (any/type   #'ctypep obj types)))))
  82     (function-type
  83      (values (functionp obj) t))
  84     (unknown-type
  85      (values nil nil))
  86     (alien-type-type
  87      (values (alien-typep obj (alien-type-type-alien-type type)) t))
  88     (hairy-type
  89      ;; Now the tricky stuff.
  90      (let* ((hairy-spec (hairy-type-specifier type))
  91             (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
  92        (ecase symbol
  93          (and
  94           (if (atom hairy-spec)
  95               (values t t)
  96               (dolist (spec (cdr hairy-spec) (values t t))
  97                 (multiple-value-bind (res win)
  98                     (ctypep obj (specifier-type spec))
  99                   (unless win (return (values nil nil)))
 100                   (unless res (return (values nil t)))))))
 101          (not
 102           (multiple-value-bind (res win)
 103               (ctypep obj (specifier-type (cadr hairy-spec)))
 104             (if win
 105                 (values (not res) t)
 106                 (values nil nil))))
 107          (satisfies
 108           ;; KLUDGE: This stuff might well blow up if we tried to execute it
 109           ;; when cross-compiling. But since for the foreseeable future the
 110           ;; only code we'll try to cross-compile is SBCL itself, and SBCL is
 111           ;; built without using SATISFIES types, it's arguably not important
 112           ;; to worry about this. -- WHN 19990210.
 113           (let ((fun (second hairy-spec)))
 114             (cond ((and (consp fun)
 115                         (eq (car fun) 'lambda))
 116                    (values (not (null (funcall (coerce fun 'function) obj)))
 117                            t))
 118                   ((and (symbolp fun) (fboundp fun))
 119                    (values (not (null (funcall fun obj))) t))
 120                   (t
 121                    (values nil nil))))))))))
 122 \f
 123 ;;; LAYOUT-OF  --  Exported
 124 ;;;
 125 ;;;    Return the layout for an object. This is the basic operation for
 126 ;;; finding out the "type" of an object, and is used for generic function
 127 ;;; dispatch. The standard doesn't seem to say as much as it should about what
 128 ;;; this returns for built-in objects. For example, it seems that we must
 129 ;;; return NULL rather than LIST when X is NIL so that GF's can specialize on
 130 ;;; NULL.
 131 #!-sb-fluid (declaim (inline layout-of))
 132 (defun layout-of (x)
 133   (declare (optimize (speed 3) (safety 0)))
 134   (cond ((typep x 'instance) (%instance-layout x))
 135         ((funcallable-instance-p x) (%funcallable-instance-layout x))
 136         ((null x)
 137          ;; Note: was #.((CLASS-LAYOUT (SB!XC:FIND-CLASS 'NULL))).
 138          ;; I (WHN 19990209) replaced this with an expression evaluated at
 139          ;; run time in order to make it easier to build the cross-compiler.
 140          ;; If it doesn't work, something else will be needed..
 141          (locally
 142            ;; KLUDGE: In order to really make it run at run time (instead of
 143            ;; doing some weird broken thing at cold load time),
 144            ;; we need to suppress a DEFTRANSFORM.. -- WHN 19991004
 145            (declare (notinline sb!xc:find-class))
 146            (class-layout (sb!xc:find-class 'null))))
 147         (t (svref *built-in-class-codes* (get-type x)))))
 148
 149 #!-sb-fluid (declaim (inline sb!xc:class-of))
 150 (defun sb!xc:class-of (object)
 151   #!+sb-doc
 152   "Return the class of the supplied object, which may be any Lisp object, not
 153    just a CLOS STANDARD-OBJECT."
 154   (layout-class (layout-of object)))
 155
 156 ;;; Pull the type specifier out of a function object.
 157 (defun extract-function-type (fun)
 158   (if (sb!eval:interpreted-function-p fun)
 159       (sb!eval:interpreted-function-type fun)
 160       (typecase fun
 161         (byte-function (byte-function-type fun))
 162         (byte-closure (byte-function-type (byte-closure-function fun)))
 163         (t
 164          (specifier-type (%function-type (%closure-function fun)))))))
 165 \f
 166 ;;;; miscellaneous interfaces
 167
 168 ;;; Clear memoization of all type system operations that can be
 169 ;;; altered by type definition/redefinition.
 170 (defun clear-type-caches ()
 171   (when *type-system-initialized*
 172     (dolist (sym '(values-specifier-type-cache-clear
 173                    values-type-union-cache-clear
 174                    type-union-cache-clear
 175                    values-subtypep-cache-clear
 176                    csubtypep-cache-clear
 177                    type-intersection2-cache-clear
 178                    values-type-intersection-cache-clear))
 179       (funcall (symbol-function sym))))
 180   (values))
 181
 182 ;;; Like TYPE-OF, only we return a CTYPE structure instead of a type
 183 ;;; specifier, and we try to return the type most useful for type
 184 ;;; checking, rather than trying to come up with the one that the user
 185 ;;; might find most informative.
 186 (declaim (ftype (function (t) ctype) ctype-of))
 187 (defun-cached (ctype-of
 188                :hash-function (lambda (x) (logand (sxhash x) #x1FF))
 189                :hash-bits 9
 190                :init-wrapper !cold-init-forms)
 191               ((x eq))
 192   (typecase x
 193     (function
 194      (if (funcallable-instance-p x)
 195          (sb!xc:class-of x)
 196          (extract-function-type x)))
 197     (symbol
 198      (make-member-type :members (list x)))
 199     (number
 200      (let* ((num (if (complexp x) (realpart x) x))
 201             (res (make-numeric-type
 202                   :class (etypecase num
 203                            (integer 'integer)
 204                            (rational 'rational)
 205                            (float 'float))
 206                   :format (if (floatp num)
 207                               (float-format-name num)
 208                               nil))))
 209        (cond ((complexp x)
 210               (setf (numeric-type-complexp res) :complex)
 211               (let ((imag (imagpart x)))
 212                 (setf (numeric-type-low res) (min num imag))
 213                 (setf (numeric-type-high res) (max num imag))))
 214              (t
 215               (setf (numeric-type-low res) num)
 216               (setf (numeric-type-high res) num)))
 217        res))
 218     (array
 219      (let ((etype (specifier-type (array-element-type x))))
 220        (make-array-type :dimensions (array-dimensions x)
 221                         :complexp (not (typep x 'simple-array))
 222                         :element-type etype
 223                         :specialized-element-type etype)))
 224     (cons
 225      (make-cons-type *universal-type* *universal-type*))
 226     (t
 227      (sb!xc:class-of x))))
 228
 229 ;;; Clear this cache on GC so that we don't hold onto too much garbage.
 230 (pushnew 'ctype-of-cache-clear *before-gc-hooks*)
 231 \f
 232 (!defun-from-collected-cold-init-forms !target-type-cold-init)