1 ;;;; predicate functions (EQUAL and friends, and type predicates)
3 ;;;; This software is part of the SBCL system. See the README file for
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.
12 (in-package "SB!IMPL")
14 ;;;; miscellaneous non-primitive predicates
16 #!-sb-fluid
(declaim (inline streamp
))
17 (defun streamp (stream)
18 (typep stream
'stream
))
20 ;;; various (VECTOR FOO) type predicates, not implemented as simple
25 ,@(loop for
(name spec
) in
*vector-without-complex-typecode-infos
*
26 collect
`(defun ,name
(x)
27 (or (typep x
'(simple-array ,spec
(*)))
28 (and (complex-vector-p x
)
29 (do ((data (%array-data-vector x
) (%array-data-vector data
)))
30 ((not (array-header-p data
)) (typep data
'(simple-array ,spec
(*))))))))))))
33 ;;; Is X an extended sequence?
34 ;; This is like the "hierarchical layout depths for other things"
35 ;; case of the TYPEP transform (cf 'typetran'). Ideally it would
36 ;; be preferable to share TYPEP's code rather than repeat it here.
37 (declaim (maybe-inline extended-sequence-p
))
38 (defun extended-sequence-p (x)
39 (let* ((slayout #.
(info :type
:compiler-layout
'sequence
))
40 (depthoid #.
(layout-depthoid (info :type
:compiler-layout
'sequence
)))
42 ;; It is not an error to define a class that is both SEQUENCE and
43 ;; FUNCALLABLE-INSTANCE with metaclass FUNCALLABLE-STANDARD-CLASS
44 (cond ((%instancep x
) (%instance-layout x
))
45 ((funcallable-instance-p x
) (%funcallable-instance-layout x
))
46 (t (return-from extended-sequence-p nil
)))))
47 (when (layout-invalid layout
)
48 (setq layout
(update-object-layout-or-invalid x slayout
)))
49 ;; It's _nearly_ impossible to create an instance which is exactly
50 ;; of type SEQUENCE. To wit: (make-instance 'sequence) =>
51 ;; "Cannot allocate an instance of #<BUILT-IN-CLASS SEQUENCE>."
52 ;; We should not need to check for that, just the 'inherits' vector.
53 ;; However, bootstrap code does a sleazy thing, making an instance of
54 ;; the abstract base type which is impossible for user code to do.
55 ;; Preferably the prototype instance for SEQUENCE would be one that could
56 ;; exist, so it would be a STANDARD-OBJECT and SEQUENCE. But it's not.
57 ;; Hence we have to check for a layout that no code using the documented
58 ;; sequence API would ever see, just to get the boundary case right.
60 ;; - Some builtins use a prototype object that is strictly deeper than
61 ;; layout of the named class because it is indeed the case that no
62 ;; object's layout can ever be EQ to that of the ancestor.
63 ;; e.g. a fixnum as representative of class REAL
64 ;; - Some builtins actually fail (TYPEP (CLASS-PROTOTYPE X) X)
65 ;; but that's not an excuse for getting SEQUENCE wrong:
66 ;; (CLASS-PROTOTYPE (FIND-CLASS 'FLOAT)) => 42
67 ;; (CLASS-PROTOTYPE (FIND-CLASS 'VECTOR)) => 42
68 ;; (CLASS-PROTOTYPE (FIND-CLASS 'LIST)) => 42
69 ;; (CLASS-PROTOTYPE (FIND-CLASS 'STRING)) => 42
70 (let ((inherits (layout-inherits (truly-the layout layout
))))
71 (declare (optimize (safety 0)))
72 (eq (if (> (length inherits
) depthoid
) (svref inherits depthoid
) layout
)
75 ;;; Is X a SEQUENCE? Harder than just (OR VECTOR LIST)
77 (declare (inline extended-sequence-p
))
78 (or (listp x
) (vectorp x
) (extended-sequence-p x
)))
80 ;;;; primitive predicates. These must be supported directly by the
85 "Return T if X is NIL, otherwise return NIL."
88 ;;; All the primitive type predicate wrappers share a parallel form..
89 (macrolet ((def-type-predicate-wrapper (pred)
90 (let* ((name (symbol-name pred
))
91 (stem (string-left-trim "%" (string-right-trim "P-" name
)))
92 (article (if (position (schar name
0) "AEIOU") "an" "a")))
93 `(defun ,pred
(object)
96 "Return true if OBJECT is ~A ~A, and NIL otherwise."
99 ;; (falling through to low-level implementation)
101 (def-type-predicate-wrapper array-header-p
)
102 (def-type-predicate-wrapper arrayp
)
103 (def-type-predicate-wrapper atom
)
104 ;; Testing for BASE-CHAR-P is usually redundant on #-sb-unicode,
105 ;; remove it there completely so that #-sb-unicode build will
106 ;; break when it's used.
107 #!+sb-unicode
(def-type-predicate-wrapper base-char-p
)
108 (def-type-predicate-wrapper base-string-p
)
109 #!+sb-unicode
(def-type-predicate-wrapper character-string-p
)
110 (def-type-predicate-wrapper bignump
)
111 (def-type-predicate-wrapper bit-vector-p
)
112 (def-type-predicate-wrapper characterp
)
113 (def-type-predicate-wrapper code-component-p
)
114 (def-type-predicate-wrapper consp
)
115 (def-type-predicate-wrapper compiled-function-p
)
116 (def-type-predicate-wrapper complexp
)
117 (def-type-predicate-wrapper complex-double-float-p
)
118 (def-type-predicate-wrapper complex-float-p
)
119 #!+long-float
(def-type-predicate-wrapper complex-long-float-p
)
120 (def-type-predicate-wrapper complex-rational-p
)
121 (def-type-predicate-wrapper complex-single-float-p
)
122 ;; (COMPLEX-VECTOR-P is not included here since it's awkward to express
123 ;; the type it tests for in the Common Lisp type system, and since it's
124 ;; only used in the implementation of a few specialized things.)
125 (def-type-predicate-wrapper double-float-p
)
126 (def-type-predicate-wrapper extended-char-p
)
127 (def-type-predicate-wrapper fdefn-p
)
128 (def-type-predicate-wrapper fixnump
)
129 (def-type-predicate-wrapper floatp
)
130 (def-type-predicate-wrapper functionp
)
131 (def-type-predicate-wrapper integerp
)
132 (def-type-predicate-wrapper listp
)
133 (def-type-predicate-wrapper long-float-p
)
134 (def-type-predicate-wrapper lra-p
)
135 (def-type-predicate-wrapper null
)
136 (def-type-predicate-wrapper numberp
)
137 (def-type-predicate-wrapper rationalp
)
138 (def-type-predicate-wrapper ratiop
)
139 (def-type-predicate-wrapper realp
)
140 (def-type-predicate-wrapper short-float-p
)
141 (def-type-predicate-wrapper single-float-p
)
142 #!+sb-simd-pack
(def-type-predicate-wrapper simd-pack-p
)
143 (def-type-predicate-wrapper %instancep
)
144 (def-type-predicate-wrapper symbolp
)
145 (def-type-predicate-wrapper %other-pointer-p
)
146 (def-type-predicate-wrapper system-area-pointer-p
)
147 (def-type-predicate-wrapper weak-pointer-p
)
150 (def-type-predicate-wrapper unsigned-byte-32-p
)
151 (def-type-predicate-wrapper signed-byte-32-p
))
154 (def-type-predicate-wrapper unsigned-byte-64-p
)
155 (def-type-predicate-wrapper signed-byte-64-p
))
156 ;; Specialized array types
157 (macrolet ((saetp-defs ()
161 `(def-type-predicate-wrapper
162 ,(symbolicate (sb!vm
:saetp-primitive-type-name saetp
) "-P")))
163 sb
!vm
:*specialized-array-element-type-properties
*))))
166 (def-type-predicate-wrapper simple-array-p
)
167 (def-type-predicate-wrapper simple-rank-1-array-
*-p
)
168 (def-type-predicate-wrapper simple-string-p
)
169 (def-type-predicate-wrapper stringp
)
170 (def-type-predicate-wrapper vectorp
)
171 (def-type-predicate-wrapper vector-nil-p
))
173 #!+(or x86 x86-64 arm arm64
)
174 (defun fixnum-mod-p (x limit
)
178 #!+(or x86 x86-64 ppc
)
179 (defun %other-pointer-subtype-p
(x choices
)
180 (and (%other-pointer-p x
)
181 (member (%other-pointer-widetag x
) choices
)
184 ;;; Return the layout for an object. This is the basic operation for
185 ;;; finding out the "type" of an object, and is used for generic
186 ;;; function dispatch. The standard doesn't seem to say as much as it
187 ;;; should about what this returns for built-in objects. For example,
188 ;;; it seems that we must return NULL rather than LIST when X is NIL
189 ;;; so that GF's can specialize on NULL.
190 (declaim (inline layout-of
))
193 (declare (optimize (speed 3) (safety 0)))
194 (cond ((%instancep x
) (%instance-layout x
))
195 ((funcallable-instance-p x
) (%funcallable-instance-layout x
))
196 ;; Compiler can dump literal layouts, which handily sidesteps
197 ;; the question of when cold-init runs L-T-V forms.
198 ((null x
) #.
(find-layout 'null
))
200 ;; Note that WIDETAG-OF is slightly suboptimal here and could be
201 ;; improved - we've already ruled out some of the lowtags.
202 (svref (load-time-value sb
!kernel
::**built-in-class-codes
** t
)
205 (declaim (inline classoid-of
))
207 (defun classoid-of (object)
209 "Return the class of the supplied object, which may be any Lisp object, not
210 just a CLOS STANDARD-OBJECT."
211 (layout-classoid (layout-of object
)))
213 ;;; Return the specifier for the type of object. This is not simply
214 ;;; (TYPE-SPECIFIER (CTYPE-OF OBJECT)) because CTYPE-OF has different
215 ;;; goals than TYPE-OF. In particular, speed is more important than
216 ;;; precision here, and it is not permitted to return member types,
217 ;;; negation, union, or intersection types.
218 (defun type-of (object)
220 "Return the type of OBJECT."
221 (declare (explicit-check))
222 ;; We have special logic for everything except arrays.
223 ;; Arrays use CTYPE-OF and then convert the answer to a specifier.
227 ((<= 0 object
1) 'bit
)
228 ((< object
0) 'fixnum
)
229 (t '(integer 0 #.sb
!xc
:most-positive-fixnum
))))
232 '(integer #.
(1+ sb
!xc
:most-positive-fixnum
))
236 (standard-char 'standard-char
)
237 (base-char 'base-char
)
238 (extended-char 'extended-char
)))
239 ;; We "have to" (or have chosen to) pick off KEYWORD and BOOLEAN,
240 ;; so we may as well have a branch that returns early for any SYMBOL
241 ;; rather than falling into the CLASSOID-based test. But then since we
242 ;; do that, we also have to pick off NIL so that it doesn't say SYMBOL.
244 (cond ((eq object t
) 'boolean
)
245 ((eq object nil
) 'null
)
246 ((eq (symbol-package object
) *keyword-package
*) 'keyword
)
248 ((or array complex
#!+sb-simd-pack simd-pack
)
249 (let ((sb!kernel
::*unparse-allow-negation
* nil
))
250 (declare (special sb
!kernel
::*unparse-allow-negation
*)) ; forward ref
251 (type-specifier (ctype-of object
))))
253 (let* ((classoid (classoid-of object
))
254 (name (classoid-name classoid
)))
255 (if (%instancep object
)
257 (sb!alien-internals
:alien-value
259 ,(sb!alien-internals
:unparse-alien-type
260 (sb!alien-internals
:alien-value-type object
))))
262 (let ((pname (classoid-proper-name classoid
)))
263 (if (classoid-p pname
)
264 (classoid-pcl-class pname
)
268 ;;;; equality predicates
270 ;;; This is real simple, 'cause the compiler takes care of it.
271 (defun eq (obj1 obj2
)
273 "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
275 ;;; and this too, but it's only needed for backends on which
276 ;;; IR1 might potentially transform EQL into %EQL/INTEGER.
278 (defun %eql
/integer
(obj1 obj2
)
279 ;; This is just for constand folding, no need to transform into the %EQL/INTEGER VOP
282 (declaim (inline %eql
))
283 (defun %eql
(obj1 obj2
)
285 "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL."
287 (if (or (typep obj2
'fixnum
)
288 (not (typep obj2
'number
)))
290 ;; I would think that we could do slightly better here by testing that
291 ;; both objs are OTHER-POINTER-P with equal %OTHER-POINTER-WIDETAGs.
292 ;; Then dispatch on obj2 and elide the TYPEP on obj1 using TRULY-THE.
293 ;; Also would need to deal with immediate single-float for 64-bit.
294 (macrolet ((foo (&rest stuff
)
296 ,@(mapcar (lambda (foo)
297 (let ((type (car foo
))
300 (and (typep obj1
',type
)
309 #!-integer-eql-vop
(lambda (x y
) (zerop (bignum-compare x y
)))
310 #!+integer-eql-vop eql
) ; will become %eql/integer
313 (and (eql (numerator x
) (numerator y
))
314 (eql (denominator x
) (denominator y
)))))
317 (and (eql (realpart x
) (realpart y
))
318 (eql (imagpart x
) (imagpart y
))))))))))
323 (defun bit-vector-= (x y
)
324 (declare (type bit-vector x y
))
326 ((and (simple-bit-vector-p x
)
327 (simple-bit-vector-p y
))
328 (bit-vector-= x y
)) ; DEFTRANSFORM
330 (and (= (length x
) (length y
))
331 (with-array-data ((x x
) (start-x) (end-x) :force-inline t
332 :check-fill-pointer t
)
333 (with-array-data ((y y
) (start-y) (end-y) :force-inline t
334 :check-fill-pointer t
)
335 (declare (ignore end-y
))
336 (loop for x-i fixnum from start-x below end-x
337 for y-i fixnum from start-y
338 always
(or (= (sbit x x-i
)
339 (sbit y y-i
))))))))))
343 "Return T if X and Y are EQL or if they are structured components whose
344 elements are EQUAL. Strings and bit-vectors are EQUAL if they are the same
345 length and have identical components. Other arrays must be EQ to be EQUAL."
346 ;; Non-tail self-recursion implemented with a local auxiliary function
347 ;; is a lot faster than doing it the straightforward way (at least
348 ;; on x86oids) due to calling convention differences. -- JES, 2005-12-30
349 (labels ((equal-aux (x y
)
354 (equal-aux (car x
) (car y
))
355 (equal-aux (cdr x
) (cdr y
))))
357 (and (stringp y
) (string= x y
)))
359 (and (pathnamep y
) (pathname= x y
)))
361 (and (bit-vector-p y
)
364 ;; Use MAYBE-INLINE to get the inline expansion only once (instead
365 ;; of 200 times with INLINE). -- JES, 2005-12-30
366 (declare (maybe-inline equal-aux
))
369 ;;; EQUALP comparison of HASH-TABLE values
370 (defun hash-table-equalp (x y
)
371 (declare (type hash-table x y
))
373 (and (hash-table-p y
)
374 (eql (hash-table-count x
) (hash-table-count y
))
375 (eql (hash-table-test x
) (hash-table-test y
))
376 (block comparison-of-entries
377 (maphash (lambda (key x-value
)
378 (multiple-value-bind (y-value y-value-p
)
380 (unless (and y-value-p
(equalp x-value y-value
))
381 (return-from comparison-of-entries nil
))))
385 (defun instance-equalp (x y
)
386 (let ((layout-x (%instance-layout x
)))
388 (eq layout-x
(%instance-layout y
))
389 ;; TODO: store one bit in the layout indicating whether EQUALP
390 ;; should scan slots. (basically a STRUCTURE-CLASSOID-P bit)
391 (structure-classoid-p (layout-classoid layout-x
))
392 (macrolet ((slot-ref-equalp ()
393 `(let ((x-el (%instance-ref x i
))
394 (y-el (%instance-ref y i
)))
395 (or (eq x-el y-el
) (equalp x-el y-el
)))))
396 (let ((metadata (layout-untagged-bitmap layout-x
)))
398 (loop for i of-type index from sb
!vm
:instance-data-start
399 below
(layout-length layout-x
)
400 always
(slot-ref-equalp))
401 (let ((comparators (layout-equalp-tests layout-x
)))
402 (unless (= (length comparators
)
403 (- (layout-length layout-x
) sb
!vm
:instance-data-start
))
404 (bug "EQUALP got incomplete instance layout"))
405 ;; See remark at the source code for %TARGET-DEFSTRUCT
406 ;; explaining how to use the vector of comparators.
407 (loop for i of-type index from sb
!vm
:instance-data-start
408 below
(layout-length layout-x
)
409 for test
= (data-vector-ref
410 comparators
(- i sb
!vm
:instance-data-start
))
411 always
(cond ((eql test
0) (slot-ref-equalp))
413 (funcall test i x y
))
416 ;;; Doesn't work on simple vectors
417 (defun array-equal-p (x y
)
418 (declare (array x y
))
419 (let ((rank (array-rank x
)))
420 (= rank
(array-rank y
))
421 (dotimes (axis rank t
)
422 (unless (= (%array-dimension x axis
)
423 (%array-dimension y axis
))
425 (with-array-data ((x x
) (start-x) (end-x) :force-inline t
427 (with-array-data ((y y
) (start-y) (end-y) :force-inline t
429 (declare (ignore end-y
))
430 (let* ((reffers %%data-vector-reffers%%
)
431 (getter-x (truly-the function
(svref reffers
(%other-pointer-widetag x
))))
432 (getter-y (truly-the function
(svref reffers
(%other-pointer-widetag y
)))))
433 (loop for x-i fixnum from start-x below end-x
434 for y-i fixnum from start-y
435 for x-el
= (funcall getter-x x x-i
)
436 for y-el
= (funcall getter-y y y-i
)
437 always
(or (eq x-el y-el
)
438 (equalp x-el y-el
))))))))
440 (defun vector-equalp (x y
)
441 (declare (vector x y
))
442 (let ((length (length x
)))
444 (= length
(length y
))
445 (with-array-data ((x x
) (start-x) (end-x) :force-inline t
446 :check-fill-pointer t
)
447 (with-array-data ((y y
) (start-y) (end-y) :force-inline t
448 :check-fill-pointer t
)
449 (declare (ignore end-y
))
450 (let* ((reffers %%data-vector-reffers%%
)
451 (getter-x (truly-the function
(svref reffers
(%other-pointer-widetag x
))))
452 (getter-y (truly-the function
(svref reffers
(%other-pointer-widetag y
)))))
453 (loop for x-i fixnum from start-x below end-x
454 for y-i fixnum from start-y
455 for x-el
= (funcall getter-x x x-i
)
456 for y-el
= (funcall getter-y y y-i
)
457 always
(or (eq x-el y-el
)
458 (equalp x-el y-el
)))))))))
461 #+nil
; KLUDGE: If doc string, should be accurate: Talk about structures
463 "This is like EQUAL, except more liberal in several respects.
464 Numbers may be of different types, as long as the values are identical
465 after coercion. Characters may differ in alphabetic case. Vectors and
466 arrays must have identical dimensions and EQUALP elements, but may differ
467 in their type restriction."
469 ((characterp x
) (and (characterp y
) (char-equal x y
)))
470 ((numberp x
) (and (numberp y
) (= x y
)))
473 (equalp (car x
) (car y
))
474 (equalp (cdr x
) (cdr y
))))
476 (and (pathnamep y
) (pathname= x y
)))
478 (and (hash-table-p y
)
479 (hash-table-equalp x y
)))
482 (instance-equalp x y
)))
483 ((and (bit-vector-p x
)
488 (vector-equalp x y
)))
491 (array-equal-p x y
)))
494 (/show0
"about to do test cases in pred.lisp")
496 (let ((test-cases `((0.0
,(load-time-value (make-unportable-float :single-float-negative-zero
)) t
)
498 (#c
(1 0) #c
(1.0
0.0) t
)
499 (#c
(0 1) #c
(0.0
1.0) t
)
500 (#c
(1.1
0.0) #c
(11/10 0) nil
) ; due to roundoff error
502 ("Hello" #(#\h
#\E
#\l
#\l
#\o
) t
)
503 ("Hello" "goodbye" nil
))))
504 (/show0
"TEST-CASES bound in pred.lisp")
505 (dolist (test-case test-cases
)
506 (/show0
"about to do a TEST-CASE in pred.lisp")
507 (destructuring-bind (x y expected-result
) test-case
508 (let* ((result (equalp x y
))
509 (bresult (if result
1 0))
510 (expected-bresult (if expected-result
1 0)))
511 (unless (= bresult expected-bresult
)
512 (/show0
"failing test in pred.lisp")
513 (error "failed test (EQUALP ~S ~S)" x y
))))))
514 (/show0
"done with test cases in pred.lisp")