src/code/typep.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (in-package "SB!KERNEL")
  11
  12 ;;; (Note that when cross-compiling, SB!XC:TYPEP is interpreted as a
  13 ;;; test that the host Lisp object OBJECT translates to a target SBCL
  14 ;;; type TYPE. This behavior is needed e.g. to test for the validity
  15 ;;; of numeric subtype bounds read when cross-compiling.)
  16 (defun typep (object type &optional environment)
  17   #!+sb-doc
  18   "Is OBJECT of type TYPE?"
  19   (declare (ignore environment))
  20   ;; Actually interpreting types at runtime is done by %TYPEP. The
  21   ;; cost of the extra function call here should be negligible
  22   ;; compared to the cost of interpreting types. (And the compiler
  23   ;; tries hard to optimize away the interpretation of types at
  24   ;; runtime, and when it succeeds, we never get here anyway.)
  25   (%typep object type))
  26
  27 ;;; the actual TYPEP engine. The compiler only generates calls to this
  28 ;;; function when it can't figure out anything more intelligent to do.
  29 (defun %typep (object specifier)
  30   (%%typep object
  31            (if (ctype-p specifier)
  32                specifier
  33                (specifier-type specifier))))
  34 (defun %%typep (object type &optional (strict t))
  35   (declare (type ctype type))
  36   (etypecase type
  37     (named-type
  38      (ecase (named-type-name type)
  39        ((* t) t)
  40        ((instance) (%instancep object))
  41        ((funcallable-instance) (funcallable-instance-p object))
  42        ((extended-sequence) (extended-sequence-p object))
  43        ((nil) nil)))
  44     (numeric-type
  45      (and (numberp object)
  46           (let (;; I think this works because of an invariant of the
  47                 ;; two components of a COMPLEX are always coerced to
  48                 ;; be the same, e.g. (COMPLEX 1.0 3/2) => #C(1.0 1.5).
  49                 ;; Dunno why that holds, though -- ANSI? Python
  50                 ;; tradition? marsh faerie spirits? -- WHN 2001-10-27
  51                 (num (if (complexp object)
  52                          (realpart object)
  53                          object)))
  54             (ecase (numeric-type-class type)
  55               (integer (integerp num))
  56               (rational (rationalp num))
  57               (float
  58                (ecase (numeric-type-format type)
  59                  (short-float (typep num 'short-float))
  60                  (single-float (typep num 'single-float))
  61                  (double-float (typep num 'double-float))
  62                  (long-float (typep num 'long-float))
  63                  ((nil) (floatp num))))
  64               ((nil) t)))
  65           (flet ((bound-test (val)
  66                    (let ((low (numeric-type-low type))
  67                          (high (numeric-type-high type)))
  68                      (and (cond ((null low) t)
  69                                 ((listp low) (> val (car low)))
  70                                 (t (>= val low)))
  71                           (cond ((null high) t)
  72                                 ((listp high) (< val (car high)))
  73                                 (t (<= val high)))))))
  74             (ecase (numeric-type-complexp type)
  75               ((nil) t)
  76               (:complex
  77                (and (complexp object)
  78                     (bound-test (realpart object))
  79                     (bound-test (imagpart object))))
  80               (:real
  81                (and (not (complexp object))
  82                     (bound-test object)))))))
  83     (array-type
  84      (and (arrayp object)
  85           (ecase (array-type-complexp type)
  86             ((t) (not (typep object 'simple-array)))
  87             ((nil) (typep object 'simple-array))
  88             ((:maybe) t))
  89           (or (eq (array-type-dimensions type) '*)
  90               (do ((want (array-type-dimensions type) (cdr want))
  91                    (got (array-dimensions object) (cdr got)))
  92                   ((and (null want) (null got)) t)
  93                 (unless (and want got
  94                              (or (eq (car want) '*)
  95                                  (= (car want) (car got))))
  96                   (return nil))))
  97           (if (unknown-type-p (array-type-element-type type))
  98               ;; better to fail this way than to get bogosities like
  99               ;;   (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T
 100               (error "~@<unknown element type in array type: ~2I~_~S~:>"
 101                      (type-specifier type))
 102               t)
 103           (or (eq (array-type-specialized-element-type type) *wild-type*)
 104               (values (type= (array-type-specialized-element-type type)
 105                              (specifier-type (array-element-type
 106                                               object)))))))
 107     (member-type
 108      (when (member-type-member-p object type)
 109        t))
 110     (classoid
 111      #+sb-xc-host (ctypep object type)
 112      ;; It might be more efficient to check that OBJECT is either INSTANCEP
 113      ;; or FUNCALLABLE-INSTANCE-P before making this call.
 114      ;; But doing that would change the behavior if %%TYPEP were ever called
 115      ;; with a built-in classoid whose members are not instances.
 116      ;; e.g. (%%typep (find-fdefn 'car) (specifier-type 'fdefn))
 117      ;; I'm not sure if that can happen.
 118      #-sb-xc-host (classoid-typep (layout-of object) type object))
 119     (union-type
 120      (some (lambda (union-type-type) (%%typep object union-type-type strict))
 121            (union-type-types type)))
 122     (intersection-type
 123      (every (lambda (intersection-type-type)
 124               (%%typep object intersection-type-type strict))
 125             (intersection-type-types type)))
 126     (cons-type
 127      (and (consp object)
 128           (%%typep (car object) (cons-type-car-type type) strict)
 129           (%%typep (cdr object) (cons-type-cdr-type type) strict)))
 130     #!+sb-simd-pack
 131     (simd-pack-type
 132      (and (simd-pack-p object)
 133           (let* ((tag (%simd-pack-tag object))
 134                  (name (nth tag *simd-pack-element-types*)))
 135             (not (not (member name (simd-pack-type-element-type type)))))))
 136     (character-set-type
 137      (and (characterp object)
 138          (let ((code (char-code object))
 139                (pairs (character-set-type-pairs type)))
 140            (dolist (pair pairs nil)
 141              (destructuring-bind (low . high) pair
 142                (when (<= low code high)
 143                  (return t)))))))
 144     (unknown-type
 145      ;; dunno how to do this ANSIly -- WHN 19990413
 146      #+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host")
 147      ;; Parse it again to make sure it's really undefined.
 148      (let ((reparse (specifier-type (unknown-type-specifier type))))
 149        (if (typep reparse 'unknown-type)
 150            (error "unknown type specifier: ~S"
 151                   (unknown-type-specifier reparse))
 152            (%%typep object reparse strict))))
 153     (negation-type
 154      (not (%%typep object (negation-type-type type) strict)))
 155     (hairy-type
 156      ;; Now the tricky stuff.
 157      (let* ((hairy-spec (hairy-type-specifier type))
 158             (symbol (car hairy-spec)))
 159        (ecase symbol
 160          (and
 161           (every (lambda (spec) (%%typep object (specifier-type spec) strict))
 162                  (rest hairy-spec)))
 163          ;; Note: it should be safe to skip OR here, because union
 164          ;; types can always be represented as UNION-TYPE in general
 165          ;; or other CTYPEs in special cases; we never need to use
 166          ;; HAIRY-TYPE for them.
 167          (not
 168           (unless (proper-list-of-length-p hairy-spec 2)
 169             (error "invalid type specifier: ~S" hairy-spec))
 170           (not (%%typep object (specifier-type (cadr hairy-spec)) strict)))
 171          (satisfies
 172           (unless (proper-list-of-length-p hairy-spec 2)
 173             (error "invalid type specifier: ~S" hairy-spec))
 174           (values (funcall (symbol-function (cadr hairy-spec)) object))))))
 175     (alien-type-type
 176      (sb!alien-internals:alien-typep object (alien-type-type-alien-type type)))
 177     (fun-type
 178      (if strict
 179          (error "Function types are not a legal argument to TYPEP:~%  ~S"
 180                 (type-specifier type))
 181          (and (functionp object)
 182               (csubtypep (specifier-type (sb!impl::%fun-type object)) type))))))
 183
 184 ;;; Do a type test from a class cell, allowing forward reference and
 185 ;;; redefinition.
 186 (defun classoid-cell-typep (obj-layout cell object)
 187   (let ((classoid (classoid-cell-classoid cell)))
 188     (unless classoid
 189       (error "The class ~S has not yet been defined."
 190              (classoid-cell-name cell)))
 191     (classoid-typep obj-layout classoid object)))
 192
 193 ;;; Test whether OBJ-LAYOUT is from an instance of CLASSOID.
 194 (defun classoid-typep (obj-layout classoid object)
 195   (declare (optimize speed))
 196   ;; FIXME & KLUDGE: We could like to grab the *WORLD-LOCK* here (to ensure that
 197   ;; class graph doesn't change while we're doing the typep test), but in
 198   ;; pratice that causes trouble -- deadlocking against the compiler
 199   ;; if compiler output (or macro, or compiler-macro expansion) causes
 200   ;; another thread to do stuff. Not locking is a shoddy bandaid as it is remains
 201   ;; easy to trigger the same problem using a different code path -- but in practice
 202   ;; locking here makes Slime unusable with :SPAWN in post *WORLD-LOCK* world. So...
 203   ;; -- NS 2008-12-16
 204   (multiple-value-bind (obj-layout layout)
 205       (do ((layout (classoid-layout classoid) (classoid-layout classoid))
 206            (i 0 (+ i 1))
 207            (obj-layout obj-layout))
 208           ((and (not (layout-invalid obj-layout))
 209                 (not (layout-invalid layout)))
 210            (values obj-layout layout))
 211         (aver (< i 2))
 212         (when (layout-invalid obj-layout)
 213           (setq obj-layout (update-object-layout-or-invalid object layout)))
 214         (%ensure-classoid-valid classoid layout "typep"))
 215     (let ((obj-inherits (layout-inherits obj-layout)))
 216       (or (eq obj-layout layout)
 217           (dotimes (i (length obj-inherits) nil)
 218             (when (eq (svref obj-inherits i) layout)
 219               (return t)))))))