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