0.6.10.21:
[sbcl.git] / 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")