src/code/pred.lisp

   1 ;;;; predicate functions (EQUAL and friends, and type predicates)
   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!IMPL")
  13 \f
  14 ;;;; miscellaneous non-primitive predicates
  15
  16 #!-sb-fluid (declaim (inline streamp))
  17 (defun streamp (stream)
  18   (typep stream 'stream))
  19
  20 ;;; Is X a (VECTOR T)?
  21 (defun vector-t-p (x)
  22   (or (simple-vector-p x)
  23       (and (complex-vector-p x)
  24            (simple-vector-p (%array-data-vector x)))))
  25 \f
  26 ;;;; primitive predicates. These must be supported directly by the
  27 ;;;; compiler.
  28
  29 (defun not (object)
  30   #!+sb-doc
  31   "Return T if X is NIL, otherwise return NIL."
  32   (not object))
  33
  34 ;;; All the primitive type predicates share a parallel form..
  35 (macrolet
  36     ((frob ()
  37        `(progn
  38           ,@(mapcar (lambda (pred)
  39                       (let* ((name (symbol-name pred))
  40                              (stem (string-right-trim name "P-"))
  41                              (article (if (find (schar name 0) "AEIOU")
  42                                         "an"
  43                                         "a")))
  44                         `(defun ,pred (object)
  45                            ,(format nil
  46                                     "Return T if OBJECT is ~A ~A, ~
  47                                      and NIL otherwise."
  48                                     article
  49                                     stem)
  50                            (,pred object))))
  51                     '(array-header-p
  52                       arrayp
  53                       atom
  54                       base-char-p
  55                       bignump
  56                       bit-vector-p
  57                       characterp
  58                       code-component-p
  59                       consp
  60                       compiled-function-p
  61                       complexp
  62                       complex-double-float-p
  63                       complex-float-p
  64                       #!+long-float complex-long-float-p
  65                       complex-rational-p
  66                       complex-single-float-p
  67                       ;; (COMPLEX-VECTOR-P is not included here since
  68                       ;; it's awkward to express the type it tests for
  69                       ;; in the Common Lisp type system, and since
  70                       ;; it's only used in the implementation of a few
  71                       ;; specialized things.)
  72                       double-float-p
  73                       fdefn-p
  74                       fixnump
  75                       floatp
  76                       functionp
  77                       integerp
  78                       listp
  79                       long-float-p
  80                       lra-p
  81                       null
  82                       numberp
  83                       rationalp
  84                       ratiop
  85                       realp
  86                       short-float-p
  87                       sb!kernel:simple-array-p
  88                       simple-bit-vector-p
  89                       simple-string-p
  90                       simple-vector-p
  91                       single-float-p
  92                       stringp
  93                       %instancep
  94                       symbolp
  95                       system-area-pointer-p
  96                       weak-pointer-p
  97                       vectorp
  98                       unsigned-byte-32-p
  99                       signed-byte-32-p
 100                       simple-array-unsigned-byte-2-p
 101                       simple-array-unsigned-byte-4-p
 102                       simple-array-unsigned-byte-8-p
 103                       simple-array-unsigned-byte-16-p
 104                       simple-array-unsigned-byte-32-p
 105                       simple-array-signed-byte-8-p
 106                       simple-array-signed-byte-16-p
 107                       simple-array-signed-byte-30-p
 108                       simple-array-signed-byte-32-p
 109                       simple-array-single-float-p
 110                       simple-array-double-float-p
 111                       #!+long-float simple-array-long-float-p
 112                       simple-array-complex-single-float-p
 113                       simple-array-complex-double-float-p
 114                       #!+long-float simple-array-complex-long-float-p
 115                       )))))
 116   (frob))
 117 \f
 118 ;;; Return the specifier for the type of object. This is not simply
 119 ;;; (TYPE-SPECIFIER (CTYPE-OF OBJECT)) because CTYPE-OF has different
 120 ;;; goals than TYPE-OF. In particular, speed is more important than
 121 ;;; precision, and it is not permitted to return member types.
 122 (defun type-of (object)
 123   #!+sb-doc
 124   "Return the type of OBJECT."
 125   (if (typep object '(or function array complex))
 126     (type-specifier (ctype-of object))
 127     (let* ((class (layout-class (layout-of object)))
 128            (name (class-name class)))
 129       (if (typep object 'instance)
 130       (case name
 131         (sb!alien-internals:alien-value
 132          `(sb!alien:alien
 133            ,(sb!alien-internals:unparse-alien-type
 134              (sb!alien-internals:alien-value-type object))))
 135         (t
 136          (class-proper-name class)))
 137       name))))
 138 \f
 139 ;;; FIXME: This belongs somewhere else, perhaps in code/array.lisp.
 140 (defun upgraded-array-element-type (spec)
 141   #!+sb-doc
 142   "Return the element type that will actually be used to implement an array
 143    with the specifier :ELEMENT-TYPE Spec."
 144   (if (unknown-type-p (specifier-type spec))
 145       (error "undefined type: ~S" spec)
 146       (type-specifier (array-type-specialized-element-type
 147                        (specifier-type `(array ,spec))))))
 148 \f
 149 ;;;; equality predicates
 150
 151 ;;; This is real simple, 'cause the compiler takes care of it.
 152 (defun eq (obj1 obj2)
 153   #!+sb-doc
 154   "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
 155   (eq obj1 obj2))
 156
 157 (defun equal (x y)
 158   #!+sb-doc
 159   "Returns T if X and Y are EQL or if they are structured components
 160   whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
 161   are the same length and have identical components. Other arrays must be
 162   EQ to be EQUAL."
 163   (cond ((eql x y) t)
 164         ((consp x)
 165          (and (consp y)
 166               (equal (car x) (car y))
 167               (equal (cdr x) (cdr y))))
 168         ((stringp x)
 169          (and (stringp y) (string= x y)))
 170         ((pathnamep x)
 171          (and (pathnamep y) (pathname= x y)))
 172         ((bit-vector-p x)
 173          (and (bit-vector-p y)
 174               (= (the fixnum (length x))
 175                  (the fixnum (length y)))
 176               (do ((i 0 (1+ i))
 177                    (length (length x)))
 178                   ((= i length) t)
 179                 (declare (fixnum i))
 180                 (or (= (the fixnum (bit x i))
 181                        (the fixnum (bit y i)))
 182                     (return nil)))))
 183         (t nil)))
 184
 185 ;;; EQUALP comparison of HASH-TABLE values
 186 (defun hash-table-equalp (x y)
 187   (declare (type hash-table x y))
 188   (or (eq x y)
 189       (and (hash-table-p y)
 190            (eql (hash-table-count x) (hash-table-count y))
 191            (eql (hash-table-test x) (hash-table-test y))
 192            (block comparison-of-entries
 193              (maphash (lambda (key x-value)
 194                         (multiple-value-bind (y-value y-value-p)
 195                             (gethash key y)
 196                           (unless (and y-value-p (equalp x-value y-value))
 197                             (return-from comparison-of-entries nil))))
 198                       x)
 199              t))))
 200
 201 (defun equalp (x y)
 202   #+nil ; KLUDGE: If doc string, should be accurate: Talk about structures
 203   ; and HASH-TABLEs.
 204   "Just like EQUAL, but more liberal in several respects.
 205   Numbers may be of different types, as long as the values are identical
 206   after coercion. Characters may differ in alphabetic case. Vectors and
 207   arrays must have identical dimensions and EQUALP elements, but may differ
 208   in their type restriction."
 209   (cond ((eq x y) t)
 210         ((characterp x) (and (characterp y) (char-equal x y)))
 211         ((numberp x) (and (numberp y) (= x y)))
 212         ((consp x)
 213          (and (consp y)
 214               (equalp (car x) (car y))
 215               (equalp (cdr x) (cdr y))))
 216         ((pathnamep x)
 217          (and (pathnamep y) (pathname= x y)))
 218         ((hash-table-p x)
 219          (and (hash-table-p y)
 220               (hash-table-equalp x y)))
 221         ((typep x 'instance)
 222          (let* ((layout-x (%instance-layout x))
 223                 (len (layout-length layout-x)))
 224            (and (typep y 'instance)
 225                 (eq layout-x (%instance-layout y))
 226                 (structure-class-p (layout-class layout-x))
 227                 (do ((i 1 (1+ i)))
 228                     ((= i len) t)
 229                   (declare (fixnum i))
 230                   (let ((x-el (%instance-ref x i))
 231                         (y-el (%instance-ref y i)))
 232                     (unless (or (eq x-el y-el)
 233                                 (equalp x-el y-el))
 234                       (return nil)))))))
 235         ((vectorp x)
 236          (let ((length (length x)))
 237            (and (vectorp y)
 238                 (= length (length y))
 239                 (dotimes (i length t)
 240                   (let ((x-el (aref x i))
 241                         (y-el (aref y i)))
 242                     (unless (or (eq x-el y-el)
 243                                 (equalp x-el y-el))
 244                       (return nil)))))))
 245         ((arrayp x)
 246          (and (arrayp y)
 247               (= (array-rank x) (array-rank y))
 248               (dotimes (axis (array-rank x) t)
 249                 (unless (= (array-dimension x axis)
 250                            (array-dimension y axis))
 251                   (return nil)))
 252               (dotimes (index (array-total-size x) t)
 253                 (let ((x-el (row-major-aref x index))
 254                       (y-el (row-major-aref y index)))
 255                   (unless (or (eq x-el y-el)
 256                               (equalp x-el y-el))
 257                     (return nil))))))
 258         (t nil)))
 259
 260 (/show0 "about to do test cases in pred.lisp")
 261 #!+sb-test
 262 (let ((test-cases '((0.0 -0.0 t)
 263                     (0.0 1.0 nil)
 264                     (#c(1 0) #c(1.0 0) t)
 265                     (#c(1.1 0) #c(11/10 0) nil) ; due to roundoff error
 266                     ("Hello" "hello" t)
 267                     ("Hello" #(#\h #\E #\l #\l #\o) t)
 268                     ("Hello" "goodbye" nil))))
 269   (/show0 "TEST-CASES bound in pred.lisp")
 270   (dolist (test-case test-cases)
 271     (/show0 "about to do a TEST-CASE in pred.lisp")
 272     (destructuring-bind (x y expected-result) test-case
 273       (let* ((result (equalp x y))
 274              (bresult (if result 1 0))
 275              (expected-bresult (if expected-result 1 0)))
 276         (unless (= bresult expected-bresult)
 277           (/show0 "failing test in pred.lisp")
 278           (error "failed test (EQUALP ~S ~S)" x y))))))
 279 (/show0 "done with test cases in pred.lisp")