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 14;;;; miscellaneous non-primitive predicates 15 16#!-sb-fluid (declaim (inline streamp)) 17(defun streamp (stream) 18 (typep stream 'stream)) 19 20;;; various (VECTOR FOO) type predicates, not implemented as simple 21;;; widetag tests 22(macrolet 23 ((def () 24 `(progn 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 (*)))))))))))) 31 (def)) 32 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))) 41 (layout 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. 59 ;; Note also: 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) 73 slayout)))) 74 75;;; Is X a SEQUENCE? Harder than just (OR VECTOR LIST) 76(defun sequencep (x) 77 (declare (inline extended-sequence-p)) 78 (or (listp x) (vectorp x) (extended-sequence-p x))) 79 80;;;; primitive predicates. These must be supported directly by the 81;;;; compiler. 82 83(defun not (object) 84 #!+sb-doc 85 "Return T if X is NIL, otherwise return NIL." 86 (not object)) 87 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) 94 #!+sb-doc 95 ,(format nil 96 "Return true if OBJECT is ~A ~A, and NIL otherwise." 97 article 98 stem) 99 ;; (falling through to low-level implementation) 100 (,pred object))))) 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) 148 #!-64-bit 149 (progn 150 (def-type-predicate-wrapper unsigned-byte-32-p) 151 (def-type-predicate-wrapper signed-byte-32-p)) 152 #!+64-bit 153 (progn 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 () 158 `(progn 159 ,@(map 'list 160 (lambda (saetp) 161 `(def-type-predicate-wrapper 162 ,(symbolicate (sb!vm:saetp-primitive-type-name saetp) "-P"))) 163 sb!vm:*specialized-array-element-type-properties*)))) 164 (saetp-defs)) 165 ;; Other array types 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)) 172 173#!+(or x86 x86-64 arm arm64) 174(defun fixnum-mod-p (x limit) 175 (and (fixnump x) 176 (<= 0 x limit))) 177 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) 182 t)) 183 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)) 191#-sb-xc-host 192(defun layout-of (x) 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)) 199 (t 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) 203 (widetag-of x))))) 204 205(declaim (inline classoid-of)) 206#-sb-xc-host 207(defun classoid-of (object) 208 #!+sb-doc 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))) 212 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) 219 #!+sb-doc 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. 224 (typecase object 225 (fixnum 226 (cond 227 ((<= 0 object 1) 'bit) 228 ((< object 0) 'fixnum) 229 (t '(integer 0 #.sb!xc:most-positive-fixnum)))) 230 (integer 231 (if (>= object 0) 232 '(integer #.(1+ sb!xc:most-positive-fixnum)) 233 'bignum)) 234 (character 235 (typecase object 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. 243 (symbol 244 (cond ((eq object t) 'boolean) 245 ((eq object nil) 'null) 246 ((eq (symbol-package object) *keyword-package*) 'keyword) 247 (t 'symbol))) 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)))) 252 (t 253 (let* ((classoid (classoid-of object)) 254 (name (classoid-name classoid))) 255 (if (%instancep object) 256 (case name 257 (sb!alien-internals:alien-value 258 `(alien 259 ,(sb!alien-internals:unparse-alien-type 260 (sb!alien-internals:alien-value-type object)))) 261 (t 262 (let ((pname (classoid-proper-name classoid))) 263 (if (classoid-p pname) 264 (classoid-pcl-class pname) 265 pname)))) 266 name))))) 267 268;;;; equality predicates 269 270;;; This is real simple, 'cause the compiler takes care of it. 271(defun eq (obj1 obj2) 272 #!+sb-doc 273 "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL." 274 (eq obj1 obj2)) 275;;; and this too, but it's only needed for backends on which 276;;; IR1 might potentially transform EQL into %EQL/INTEGER. 277#!+integer-eql-vop 278(defun %eql/integer (obj1 obj2) 279 ;; This is just for constant folding, no need to transform into the %EQL/INTEGER VOP 280 (eql obj1 obj2)) 281 282(declaim (inline %eql)) 283(defun %eql (obj1 obj2) 284 #!+sb-doc 285 "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL." 286 (or (eq obj1 obj2) 287 (if (or (typep obj2 'fixnum) 288 (not (typep obj2 'number))) 289 nil 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) 295 `(typecase obj2 296 ,@(mapcar (lambda (foo) 297 (let ((type (car foo)) 298 (fn (cadr foo))) 299 `(,type 300 (and (typep obj1 ',type) 301 (,fn obj1 obj2))))) 302 stuff)))) 303 (foo 304 (single-float eql) 305 (double-float eql) 306 #!+long-float 307 (long-float eql) 308 (bignum 309 #!-integer-eql-vop (lambda (x y) (zerop (bignum-compare x y))) 310 #!+integer-eql-vop eql) ; will become %eql/integer 311 (ratio 312 (lambda (x y) 313 (and (eql (numerator x) (numerator y)) 314 (eql (denominator x) (denominator y))))) 315 ((complex single-float) 316 (lambda (x y) 317 (and (eql (realpart x) (realpart y)) 318 (eql (imagpart x) (imagpart y))))) 319 ((complex double-float) 320 (lambda (x y) 321 (and (eql (realpart x) (realpart y)) 322 (eql (imagpart x) (imagpart y))))) 323 ((complex rational) 324 (lambda (x y) 325 (and (eql (realpart x) (realpart y)) 326 (eql (imagpart x) (imagpart y)))))))))) 327 328(defun eql (x y) 329 (%eql x y)) 330 331(defun bit-vector-= (x y) 332 (declare (type bit-vector x y)) 333 (cond ((eq x y)) 334 ((and (simple-bit-vector-p x) 335 (simple-bit-vector-p y)) 336 (bit-vector-= x y)) ; DEFTRANSFORM 337 (t 338 (and (= (length x) (length y)) 339 (with-array-data ((x x) (start-x) (end-x) :force-inline t 340 :check-fill-pointer t) 341 (with-array-data ((y y) (start-y) (end-y) :force-inline t 342 :check-fill-pointer t) 343 (declare (ignore end-y)) 344 (loop for x-i fixnum from start-x below end-x 345 for y-i fixnum from start-y 346 always (or (= (sbit x x-i) 347 (sbit y y-i)))))))))) 348 349(defun equal (x y) 350 #!+sb-doc 351 "Return T if X and Y are EQL or if they are structured components whose 352elements are EQUAL. Strings and bit-vectors are EQUAL if they are the same 353length and have identical components. Other arrays must be EQ to be EQUAL." 354 ;; Non-tail self-recursion implemented with a local auxiliary function 355 ;; is a lot faster than doing it the straightforward way (at least 356 ;; on x86oids) due to calling convention differences. -- JES, 2005-12-30 357 (labels ((equal-aux (x y) 358 (cond ((%eql x y) 359 t) 360 ((consp x) 361 (and (consp y) 362 (equal-aux (car x) (car y)) 363 (equal-aux (cdr x) (cdr y)))) 364 ((stringp x) 365 (and (stringp y) (string= x y))) 366 ((pathnamep x) 367 (and (pathnamep y) (pathname= x y))) 368 ((bit-vector-p x) 369 (and (bit-vector-p y) 370 (bit-vector-= x y))) 371 (t nil)))) 372 ;; Use MAYBE-INLINE to get the inline expansion only once (instead 373 ;; of 200 times with INLINE). -- JES, 2005-12-30 374 (declare (maybe-inline equal-aux)) 375 (equal-aux x y))) 376 377;;; EQUALP comparison of HASH-TABLE values 378(defun hash-table-equalp (x y) 379 (declare (type hash-table x y)) 380 (or (eq x y) 381 (and (hash-table-p y) 382 (eql (hash-table-count x) (hash-table-count y)) 383 (eql (hash-table-test x) (hash-table-test y)) 384 (block comparison-of-entries 385 (maphash (lambda (key x-value) 386 (multiple-value-bind (y-value y-value-p) 387 (gethash key y) 388 (unless (and y-value-p (equalp x-value y-value)) 389 (return-from comparison-of-entries nil)))) 390 x) 391 t)))) 392 393(defun instance-equalp (x y) 394 (let ((layout-x (%instance-layout x))) 395 (and 396 (eq layout-x (%instance-layout y)) 397 ;; TODO: store one bit in the layout indicating whether EQUALP 398 ;; should scan slots. (basically a STRUCTURE-CLASSOID-P bit) 399 (structure-classoid-p (layout-classoid layout-x)) 400 (macrolet ((slot-ref-equalp () 401 `(let ((x-el (%instance-ref x i)) 402 (y-el (%instance-ref y i))) 403 (or (eq x-el y-el) (equalp x-el y-el))))) 404 (if (eql (layout-bitmap layout-x) sb!kernel::+layout-all-tagged+) 405 (loop for i of-type index from sb!vm:instance-data-start 406 below (layout-length layout-x) 407 always (slot-ref-equalp)) 408 (let ((comparators (layout-equalp-tests layout-x))) 409 (unless (= (length comparators) 410 (- (layout-length layout-x) sb!vm:instance-data-start)) 411 (bug "EQUALP got incomplete instance layout")) 412 ;; See remark at the source code for %TARGET-DEFSTRUCT 413 ;; explaining how to use the vector of comparators. 414 (loop for i of-type index from sb!vm:instance-data-start 415 below (layout-length layout-x) 416 for test = (data-vector-ref 417 comparators (- i sb!vm:instance-data-start)) 418 always (cond ((eql test 0) (slot-ref-equalp)) 419 ((functionp test) 420 (funcall test i x y)) 421 (t))))))))) 422 423;;; Doesn't work on simple vectors 424(defun array-equal-p (x y) 425 (declare (array x y)) 426 (let ((rank (array-rank x))) 427 (and 428 (= rank (array-rank y)) 429 (dotimes (axis rank t) 430 (unless (= (%array-dimension x axis) 431 (%array-dimension y axis)) 432 (return nil))) 433 (with-array-data ((x x) (start-x) (end-x) :force-inline t 434 :array-header-p t) 435 (with-array-data ((y y) (start-y) (end-y) :force-inline t 436 :array-header-p t) 437 (declare (ignore end-y)) 438 (let* ((reffers %%data-vector-reffers%%) 439 (getter-x (truly-the function (svref reffers (%other-pointer-widetag x)))) 440 (getter-y (truly-the function (svref reffers (%other-pointer-widetag y))))) 441 (loop for x-i fixnum from start-x below end-x 442 for y-i fixnum from start-y 443 for x-el = (funcall getter-x x x-i) 444 for y-el = (funcall getter-y y y-i) 445 always (or (eq x-el y-el) 446 (equalp x-el y-el))))))))) 447 448(defun vector-equalp (x y) 449 (declare (vector x y)) 450 (let ((length (length x))) 451 (and (= length (length y)) 452 (with-array-data ((x x) (start-x) (end-x) :force-inline t 453 :check-fill-pointer t) 454 (with-array-data ((y y) (start-y) (end-y) :force-inline t 455 :check-fill-pointer t) 456 (declare (ignore end-y)) 457 (let* ((reffers %%data-vector-reffers%%) 458 (getter-x (truly-the function (svref reffers (%other-pointer-widetag x)))) 459 (getter-y (truly-the function (svref reffers (%other-pointer-widetag y))))) 460 (loop for x-i fixnum from start-x below end-x 461 for y-i fixnum from start-y 462 for x-el = (funcall getter-x x x-i) 463 for y-el = (funcall getter-y y y-i) 464 always (or (eq x-el y-el) 465 (equalp x-el y-el))))))))) 466 467(defun equalp (x y) 468 #+nil ; KLUDGE: If doc string, should be accurate: Talk about structures 469 ; and HASH-TABLEs. 470 "This is like EQUAL, except more liberal in several respects. 471 Numbers may be of different types, as long as the values are identical 472 after coercion. Characters may differ in alphabetic case. Vectors and 473 arrays must have identical dimensions and EQUALP elements, but may differ 474 in their type restriction." 475 (cond ((eq x y) t) 476 ((characterp x) (and (characterp y) (char-equal x y))) 477 ((numberp x) (and (numberp y) (= x y))) 478 ((consp x) 479 (and (consp y) 480 (equalp (car x) (car y)) 481 (equalp (cdr x) (cdr y)))) 482 ((pathnamep x) 483 (and (pathnamep y) (pathname= x y))) 484 ((hash-table-p x) 485 (and (hash-table-p y) 486 (hash-table-equalp x y))) 487 ((%instancep x) 488 (and (%instancep y) 489 (instance-equalp x y))) 490 ((and (bit-vector-p x) 491 (bit-vector-p y)) 492 (bit-vector-= x y)) 493 ((vectorp x) 494 (and (vectorp y) 495 (vector-equalp x y))) 496 ((arrayp x) 497 (and (arrayp y) 498 (array-equal-p x y))) 499 (t nil))) 500 501(/show0 "about to do test cases in pred.lisp") 502#!+sb-test 503(let ((test-cases `((0.0 ,(load-time-value (make-unportable-float :single-float-negative-zero)) t) 504 (0.0 1.0 nil) 505 (#c(1 0) #c(1.0 0.0) t) 506 (#c(0 1) #c(0.0 1.0) t) 507 (#c(1.1 0.0) #c(11/10 0) nil) ; due to roundoff error 508 ("Hello" "hello" t) 509 ("Hello" #(#\h #\E #\l #\l #\o) t) 510 ("Hello" "goodbye" nil)))) 511 (/show0 "TEST-CASES bound in pred.lisp") 512 (dolist (test-case test-cases) 513 (/show0 "about to do a TEST-CASE in pred.lisp") 514 (destructuring-bind (x y expected-result) test-case 515 (let* ((result (equalp x y)) 516 (bresult (if result 1 0)) 517 (expected-bresult (if expected-result 1 0))) 518 (unless (= bresult expected-bresult) 519 (/show0 "failing test in pred.lisp") 520 (error "failed test (EQUALP ~S ~S)" x y)))))) 521(/show0 "done with test cases in pred.lisp") 522