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)
  17   #!+sb-doc
  18   "Is OBJECT of type TYPE?"
  19   ;; Actually interpreting types at runtime is done by %TYPEP. The
  20   ;; cost of the extra function call here should be negligible
  21   ;; compared to the cost of interpreting types. (And the compiler
  22   ;; tries hard to optimize away the interpretation of types at
  23   ;; runtime, and when it succeeds, we never get here anyway.)
  24   (%typep object type))
  25
  26 ;;; the actual TYPEP engine. The compiler only generates calls to this
  27 ;;; function when it can't figure out anything more intelligent to do.
  28 (defun %typep (object specifier)
  29   (%%typep object
  30            (if (ctype-p specifier)
  31                specifier
  32                (specifier-type specifier))))
  33 (defun %%typep (object type)
  34   (declare (type ctype type))
  35   (etypecase type
  36     (named-type
  37      (ecase (named-type-name type)
  38        ((* t) t)
  39        ((nil) nil)))
  40     (numeric-type
  41      (and (numberp object)
  42           (let (;; I think this works because of an invariant of the
  43                 ;; two components of a COMPLEX are always coerced to
  44                 ;; be the same, e.g. (COMPLEX 1.0 3/2) => #C(1.0 1.5).
  45                 ;; Dunno why that holds, though -- ANSI? Python
  46                 ;; tradition? marsh faerie spirits? -- WHN 2001-10-27
  47                 (num (if (complexp object)
  48                          (realpart object)
  49                          object)))
  50             (ecase (numeric-type-class type)
  51               (integer (integerp num))
  52               (rational (rationalp num))
  53               (float
  54                (ecase (numeric-type-format type)
  55                  (short-float (typep num 'short-float))
  56                  (single-float (typep num 'single-float))
  57                  (double-float (typep num 'double-float))
  58                  (long-float (typep num 'long-float))
  59                  ((nil) (floatp num))))
  60               ((nil) t)))
  61           #!-negative-zero-is-not-zero
  62           (flet ((bound-test (val)
  63                    (let ((low (numeric-type-low type))
  64                          (high (numeric-type-high type)))
  65                      (and (cond ((null low) t)
  66                                 ((listp low) (> val (car low)))
  67                                 (t (>= val low)))
  68                           (cond ((null high) t)
  69                                 ((listp high) (< val (car high)))
  70                                 (t (<= val high)))))))
  71             (ecase (numeric-type-complexp type)
  72               ((nil) t)
  73               (:complex
  74                (and (complexp object)
  75                     (bound-test (realpart object))
  76                     (bound-test (imagpart object))))
  77               (:real
  78                (and (not (complexp object))
  79                     (bound-test object)))))
  80           #!+negative-zero-is-not-zero
  81           (labels ((signed-> (x y)
  82                      (if (and (zerop x) (zerop y) (floatp x) (floatp y))
  83                          (> (float-sign x) (float-sign y))
  84                          (> x y)))
  85                    (signed->= (x y)
  86                      (if (and (zerop x) (zerop y) (floatp x) (floatp y))
  87                          (>= (float-sign x) (float-sign y))
  88                          (>= x y)))
  89                    (bound-test (val)
  90                      (let ((low (numeric-type-low type))
  91                            (high (numeric-type-high type)))
  92                        (and (cond ((null low) t)
  93                                   ((listp low)
  94                                    (signed-> val (car low)))
  95                                   (t
  96                                    (signed->= val low)))
  97                             (cond ((null high) t)
  98                                   ((listp high)
  99                                    (signed-> (car high) val))
 100                                   (t
 101                                    (signed->= high val)))))))
 102             (ecase (numeric-type-complexp type)
 103               ((nil) t)
 104               (:complex
 105                (and (complexp object)
 106                     (bound-test (realpart object))
 107                     (bound-test (imagpart object))))
 108               (:real
 109                (and (not (complexp object))
 110                     (bound-test object)))))))
 111     (array-type
 112      (and (arrayp object)
 113           (ecase (array-type-complexp type)
 114             ((t) (not (typep object 'simple-array)))
 115             ((nil) (typep object 'simple-array))
 116             ((:maybe) t))
 117           (or (eq (array-type-dimensions type) '*)
 118               (do ((want (array-type-dimensions type) (cdr want))
 119                    (got (array-dimensions object) (cdr got)))
 120                   ((and (null want) (null got)) t)
 121                 (unless (and want got
 122                              (or (eq (car want) '*)
 123                                  (= (car want) (car got))))
 124                   (return nil))))
 125           (if (unknown-type-p (array-type-element-type type))
 126               ;; better to fail this way than to get bogosities like
 127               ;;   (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T
 128               (error "~@<unknown element type in array type: ~2I~_~S~:>"
 129                      (type-specifier type))
 130               t)
 131           (or (eq (array-type-element-type type) *wild-type*)
 132               (values (type= (array-type-specialized-element-type type)
 133                              (specifier-type (array-element-type
 134                                               object)))))))
 135     (member-type
 136      (if (member object (member-type-members type)) t))
 137     (sb!xc:class
 138      #+sb-xc-host (ctypep object type)
 139      #-sb-xc-host (class-typep (layout-of object) type object))
 140     (union-type
 141      (some (lambda (union-type-type) (%%typep object union-type-type))
 142            (union-type-types type)))
 143     (intersection-type
 144      (every (lambda (intersection-type-type)
 145               (%%typep object intersection-type-type))
 146             (intersection-type-types type)))
 147     (cons-type
 148      (and (consp object)
 149           (%%typep (car object) (cons-type-car-type type))
 150           (%%typep (cdr object) (cons-type-cdr-type type))))
 151     (unknown-type
 152      ;; dunno how to do this ANSIly -- WHN 19990413
 153      #+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host")
 154      ;; Parse it again to make sure it's really undefined.
 155      (let ((reparse (specifier-type (unknown-type-specifier type))))
 156        (if (typep reparse 'unknown-type)
 157            (error "unknown type specifier: ~S"
 158                   (unknown-type-specifier reparse))
 159            (%%typep object reparse))))
 160     (hairy-type
 161      ;; Now the tricky stuff.
 162      (let* ((hairy-spec (hairy-type-specifier type))
 163             (symbol (car hairy-spec)))
 164        (ecase symbol
 165          (and
 166           (every (lambda (spec) (%%typep object (specifier-type spec)))
 167                  (rest hairy-spec)))
 168          ;; Note: it should be safe to skip OR here, because union
 169          ;; types can always be represented as UNION-TYPE in general
 170          ;; or other CTYPEs in special cases; we never need to use
 171          ;; HAIRY-TYPE for them.
 172          (not
 173           (unless (proper-list-of-length-p hairy-spec 2)
 174             (error "invalid type specifier: ~S" hairy-spec))
 175           (not (%%typep object (specifier-type (cadr hairy-spec)))))
 176          (satisfies
 177           (unless (proper-list-of-length-p hairy-spec 2)
 178             (error "invalid type specifier: ~S" hairy-spec))
 179           (values (funcall (symbol-function (cadr hairy-spec)) object))))))
 180     (alien-type-type
 181      (sb!alien-internals:alien-typep object (alien-type-type-alien-type type)))
 182     (fun-type
 183      (error "Function types are not a legal argument to TYPEP:~%  ~S"
 184             (type-specifier type)))))
 185
 186 ;;; Do a type test from a class cell, allowing forward reference and
 187 ;;; redefinition.
 188 (defun class-cell-typep (obj-layout cell object)
 189   (let ((class (class-cell-class cell)))
 190     (unless class
 191       (error "The class ~S has not yet been defined." (class-cell-name cell)))
 192     (class-typep obj-layout class object)))
 193
 194 ;;; Test whether OBJ-LAYOUT is from an instance of CLASS.
 195 (defun class-typep (obj-layout class object)
 196   (declare (optimize speed))
 197   (when (layout-invalid obj-layout)
 198     (if (and (typep (sb!xc:class-of object) 'sb!xc:standard-class) object)
 199         (setq obj-layout (pcl-check-wrapper-validity-hook object))
 200         (error "TYPEP was called on an obsolete object (was class ~S)."
 201                (class-proper-name (layout-class obj-layout)))))
 202   (let ((layout (class-layout class))
 203         (obj-inherits (layout-inherits obj-layout)))
 204     (when (layout-invalid layout)
 205       (error "The class ~S is currently invalid." class))
 206     (or (eq obj-layout layout)
 207         (dotimes (i (length obj-inherits) nil)
 208           (when (eq (svref obj-inherits i) layout)
 209             (return t))))))
 210
 211 ;;; to be redefined as PCL::CHECK-WRAPPER-VALIDITY when PCL is loaded
 212 ;;;
 213 ;;; FIXME: should probably be renamed SB!PCL:CHECK-WRAPPER-VALIDITY
 214 (defun pcl-check-wrapper-validity-hook (object)
 215   object)