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   (type-specifier
 145    (array-type-specialized-element-type
 146     (specifier-type `(array ,spec)))))
 147 \f
 148 ;;;; equality predicates
 149
 150 ;;; This is real simple, 'cause the compiler takes care of it.
 151 (defun eq (obj1 obj2)
 152   #!+sb-doc
 153   "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
 154   (eq obj1 obj2))
 155
 156 (defun equal (x y)
 157   #!+sb-doc
 158   "Returns T if X and Y are EQL or if they are structured components
 159   whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
 160   are the same length and have identical components. Other arrays must be
 161   EQ to be EQUAL."
 162   (cond ((eql x y) t)
 163         ((consp x)
 164          (and (consp y)
 165               (equal (car x) (car y))
 166               (equal (cdr x) (cdr y))))
 167         ((stringp x)
 168          (and (stringp y) (string= x y)))
 169         ((pathnamep x)
 170          (and (pathnamep y) (pathname= x y)))
 171         ((bit-vector-p x)
 172          (and (bit-vector-p y)
 173               (= (the fixnum (length x))
 174                  (the fixnum (length y)))
 175               (do ((i 0 (1+ i))
 176                    (length (length x)))
 177                   ((= i length) t)
 178                 (declare (fixnum i))
 179                 (or (= (the fixnum (bit x i))
 180                        (the fixnum (bit y i)))
 181                     (return nil)))))
 182         (t nil)))
 183
 184 ;;; EQUALP comparison of HASH-TABLE values
 185 (defun hash-table-equalp (x y)
 186   (declare (type hash-table x y))
 187   (or (eq x y)
 188       (and (hash-table-p y)
 189            (eql (hash-table-count x) (hash-table-count y))
 190            (eql (hash-table-test x) (hash-table-test y))
 191            (block comparison-of-entries
 192              (maphash (lambda (key x-value)
 193                         (multiple-value-bind (y-value y-value-p)
 194                             (gethash key y)
 195                           (unless (and y-value-p (equalp x-value y-value))
 196                             (return-from comparison-of-entries nil))))
 197                       x)
 198              t))))
 199
 200 (defun equalp (x y)
 201   #+nil ; KLUDGE: If doc string, should be accurate: Talk about structures
 202   ; and HASH-TABLEs.
 203   "Just like EQUAL, but more liberal in several respects.
 204   Numbers may be of different types, as long as the values are identical
 205   after coercion. Characters may differ in alphabetic case. Vectors and
 206   arrays must have identical dimensions and EQUALP elements, but may differ
 207   in their type restriction."
 208   (cond ((eq x y) t)
 209         ((characterp x) (and (characterp y) (char-equal x y)))
 210         ((numberp x) (and (numberp y) (= x y)))
 211         ((consp x)
 212          (and (consp y)
 213               (equalp (car x) (car y))
 214               (equalp (cdr x) (cdr y))))
 215         ((pathnamep x)
 216          (and (pathnamep y) (pathname= x y)))
 217         ((hash-table-p x)
 218          (and (hash-table-p y)
 219               (hash-table-equalp x y)))
 220         ((typep x 'instance)
 221          (let* ((layout-x (%instance-layout x))
 222                 (len (layout-length layout-x)))
 223            (and (typep y 'instance)
 224                 (eq layout-x (%instance-layout y))
 225                 (structure-class-p (layout-class layout-x))
 226                 (do ((i 1 (1+ i)))
 227                     ((= i len) t)
 228                   (declare (fixnum i))
 229                   (let ((x-el (%instance-ref x i))
 230                         (y-el (%instance-ref y i)))
 231                     (unless (or (eq x-el y-el)
 232                                 (equalp x-el y-el))
 233                       (return nil)))))))
 234         ((vectorp x)
 235          (let ((length (length x)))
 236            (and (vectorp y)
 237                 (= length (length y))
 238                 (dotimes (i length t)
 239                   (let ((x-el (aref x i))
 240                         (y-el (aref y i)))
 241                     (unless (or (eq x-el y-el)
 242                                 (equalp x-el y-el))
 243                       (return nil)))))))
 244         ((arrayp x)
 245          (and (arrayp y)
 246               (= (array-rank x) (array-rank y))
 247               (dotimes (axis (array-rank x) t)
 248                 (unless (= (array-dimension x axis)
 249                            (array-dimension y axis))
 250                   (return nil)))
 251               (dotimes (index (array-total-size x) t)
 252                 (let ((x-el (row-major-aref x index))
 253                       (y-el (row-major-aref y index)))
 254                   (unless (or (eq x-el y-el)
 255                               (equalp x-el y-el))
 256                     (return nil))))))
 257         (t nil)))
 258
 259 (/show0 "about to do test cases in pred.lisp")
 260 #!+sb-test
 261 (let ((test-cases '((0.0 -0.0 t)
 262                     (0.0 1.0 nil)
 263                     (#c(1 0) #c(1.0 0) t)
 264                     (#c(1.1 0) #c(11/10 0) nil) ; due to roundoff error
 265                     ("Hello" "hello" t)
 266                     ("Hello" #(#\h #\E #\l #\l #\o) t)
 267                     ("Hello" "goodbye" nil))))
 268   (/show0 "TEST-CASES bound in pred.lisp")
 269   (dolist (test-case test-cases)
 270     (/show0 "about to do a TEST-CASE in pred.lisp")
 271     (destructuring-bind (x y expected-result) test-case
 272       (let* ((result (equalp x y))
 273              (bresult (if result 1 0))
 274              (expected-bresult (if expected-result 1 0)))
 275         (unless (= bresult expected-bresult)
 276           (/show0 "failing test in pred.lisp")
 277           (error "failed test (EQUALP ~S ~S)" x y))))))
 278 (/show0 "done with test cases in pred.lisp")