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 (file-comment
  13   "$Header$")
  14
  15 ;;; The actual TYPEP engine. The compiler only generates calls to this
  16 ;;; function when it can't figure out anything more intelligent to do.
  17 (defun %typep (object specifier)
  18   (%%typep object
  19            (if (ctype-p specifier)
  20                specifier
  21                (specifier-type specifier))))
  22 (defun %%typep (object type)
  23   (declare (type ctype type))
  24   (etypecase type
  25     (named-type
  26      (ecase (named-type-name type)
  27        ((* t) t)
  28        ((nil) nil)))
  29     (numeric-type
  30      (and (numberp object)
  31           (let ((num (if (complexp object) (realpart object) object)))
  32             (ecase (numeric-type-class type)
  33               (integer (integerp num))
  34               (rational (rationalp num))
  35               (float
  36                (ecase (numeric-type-format type)
  37                  (short-float (typep num 'short-float))
  38                  (single-float (typep num 'single-float))
  39                  (double-float (typep num 'double-float))
  40                  (long-float (typep num 'long-float))
  41                  ((nil) (floatp num))))
  42               ((nil) t)))
  43           #!-negative-zero-is-not-zero
  44           (flet ((bound-test (val)
  45                    (let ((low (numeric-type-low type))
  46                          (high (numeric-type-high type)))
  47                      (and (cond ((null low) t)
  48                                 ((listp low) (> val (car low)))
  49                                 (t (>= val low)))
  50                           (cond ((null high) t)
  51                                 ((listp high) (< val (car high)))
  52                                 (t (<= val high)))))))
  53             (ecase (numeric-type-complexp type)
  54               ((nil) t)
  55               (:complex
  56                (and (complexp object)
  57                     (bound-test (realpart object))
  58                     (bound-test (imagpart object))))
  59               (:real
  60                (and (not (complexp object))
  61                     (bound-test object)))))
  62           #!+negative-zero-is-not-zero
  63           (labels ((signed-> (x y)
  64                      (if (and (zerop x) (zerop y) (floatp x) (floatp y))
  65                          (> (float-sign x) (float-sign y))
  66                          (> x y)))
  67                    (signed->= (x y)
  68                      (if (and (zerop x) (zerop y) (floatp x) (floatp y))
  69                          (>= (float-sign x) (float-sign y))
  70                          (>= x y)))
  71                    (bound-test (val)
  72                      (let ((low (numeric-type-low type))
  73                            (high (numeric-type-high type)))
  74                        (and (cond ((null low) t)
  75                                   ((listp low)
  76                                    (signed-> val (car low)))
  77                                   (t
  78                                    (signed->= val low)))
  79                             (cond ((null high) t)
  80                                   ((listp high)
  81                                    (signed-> (car high) val))
  82                                   (t
  83                                    (signed->= high val)))))))
  84             (ecase (numeric-type-complexp type)
  85               ((nil) t)
  86               (:complex
  87                (and (complexp object)
  88                     (bound-test (realpart object))
  89                     (bound-test (imagpart object))))
  90               (:real
  91                (and (not (complexp object))
  92                     (bound-test object)))))))
  93     (array-type
  94      (and (arrayp object)
  95           (ecase (array-type-complexp type)
  96             ((t) (not (typep object 'simple-array)))
  97             ((nil) (typep object 'simple-array))
  98             ((:maybe) t))
  99           (or (eq (array-type-dimensions type) '*)
 100               (do ((want (array-type-dimensions type) (cdr want))
 101                    (got (array-dimensions object) (cdr got)))
 102                   ((and (null want) (null got)) t)
 103                 (unless (and want got
 104                              (or (eq (car want) '*)
 105                                  (= (car want) (car got))))
 106                   (return nil))))
 107           (or (eq (array-type-element-type type) *wild-type*)
 108               (values (type= (array-type-specialized-element-type type)
 109                              (specifier-type (array-element-type
 110                                               object)))))))
 111     (member-type
 112      (if (member object (member-type-members type)) t))
 113     (sb!xc:class
 114      #+sb-xc-host (ctypep object type)
 115      #-sb-xc-host (class-typep (layout-of object) type object))
 116     (union-type
 117      (dolist (type (union-type-types type))
 118        (when (%%typep object type)
 119          (return t))))
 120     (unknown-type
 121      ;; dunno how to do this ANSIly -- WHN 19990413
 122      #+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host")
 123      ;; Parse it again to make sure it's really undefined.
 124      (let ((reparse (specifier-type (unknown-type-specifier type))))
 125        (if (typep reparse 'unknown-type)
 126            (error "unknown type specifier: ~S"
 127                   (unknown-type-specifier reparse))
 128            (%%typep object reparse))))
 129     (hairy-type
 130      ;; Now the tricky stuff.
 131      (let* ((hairy-spec (hairy-type-specifier type))
 132             (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
 133        (ecase symbol
 134          (and
 135           (or (atom hairy-spec)
 136               (dolist (spec (cdr hairy-spec) t)
 137                 (unless (%%typep object (specifier-type spec))
 138                   (return nil)))))
 139          (not
 140           (unless (proper-list-of-length-p hairy-spec 2)
 141             (error "invalid type specifier: ~S" hairy-spec))
 142           (not (%%typep object (specifier-type (cadr hairy-spec)))))
 143          (satisfies
 144           (unless (proper-list-of-length-p hairy-spec 2)
 145             (error "invalid type specifier: ~S" hairy-spec))
 146           (let ((fn (cadr hairy-spec)))
 147             (if (funcall (typecase fn
 148                            (function fn)
 149                            (symbol (symbol-function fn))
 150                            (t
 151                             (coerce fn 'function)))
 152                          object)
 153                 t
 154                 nil))))))
 155     (alien-type-type
 156      (sb!alien-internals:alien-typep object (alien-type-type-alien-type type)))
 157     (function-type
 158      (error "Function types are not a legal argument to TYPEP:~%  ~S"
 159             (type-specifier type)))))
 160
 161 ;;; Do type test from a class cell, allowing forward reference and
 162 ;;; redefinition.
 163 (defun class-cell-typep (obj-layout cell object)
 164   (let ((class (class-cell-class cell)))
 165     (unless class
 166       (error "The class ~S has not yet been defined." (class-cell-name cell)))
 167     (class-typep obj-layout class object)))
 168
 169 ;;; Test whether Obj-Layout is from an instance of Class.
 170 (defun class-typep (obj-layout class object)
 171   (declare (optimize speed))
 172   (when (layout-invalid obj-layout)
 173     (if (and (typep (sb!xc:class-of object) 'sb!xc:standard-class) object)
 174         (setq obj-layout (pcl-check-wrapper-validity-hook object))
 175         (error "TYPEP was called on an obsolete object (was class ~S)."
 176                (class-proper-name (layout-class obj-layout)))))
 177   (let ((layout (class-layout class))
 178         (obj-inherits (layout-inherits obj-layout)))
 179     (when (layout-invalid layout)
 180       (error "The class ~S is currently invalid." class))
 181     (or (eq obj-layout layout)
 182         (dotimes (i (length obj-inherits) nil)
 183           (when (eq (svref obj-inherits i) layout)
 184             (return t))))))
 185
 186 ;;; to be redefined as PCL::CHECK-WRAPPER-VALIDITY when PCL is loaded
 187 ;;;
 188 ;;; FIXME: should probably be renamed SB!PCL:CHECK-WRAPPER-VALIDITY
 189 (defun pcl-check-wrapper-validity-hook (object)
 190   object)