;;;; files for more information.
(in-package "SB!IMPL")
-
-(file-comment
- "$Header$")
\f
;;;; miscellaneous non-primitive predicates
"Return T if X is NIL, otherwise return NIL."
(not object))
-;;; All the primitive type predicates share a parallel form..
-(macrolet
- ((frob ()
- `(progn
- ,@(mapcar (lambda (pred)
- (let* ((name (symbol-name pred))
- (stem (string-right-trim name "P-"))
- (article (if (find (schar name 0) "AEIOU")
- "an"
- "a")))
- `(defun ,pred (object)
- ,(format nil
- "Return T if OBJECT is ~A ~A, ~
- and NIL otherwise."
- article
- stem)
- (,pred object))))
- '(array-header-p
- arrayp
- atom
- base-char-p
- bignump
- bit-vector-p
- characterp
- code-component-p
- consp
- compiled-function-p
- complexp
- complex-double-float-p
- complex-float-p
- #!+long-float complex-long-float-p
- complex-rational-p
- complex-single-float-p
- ;; (COMPLEX-VECTOR-P is not included here since
- ;; it's awkward to express the type it tests for
- ;; in the Common Lisp type system, and since
- ;; it's only used in the implementation of a few
- ;; specialized things.)
- double-float-p
- fdefn-p
- fixnump
- floatp
- functionp
- integerp
- listp
- long-float-p
- lra-p
- null
- numberp
- rationalp
- ratiop
- realp
- short-float-p
- sb!kernel:simple-array-p
- simple-bit-vector-p
- simple-string-p
- simple-vector-p
- single-float-p
- stringp
- %instancep
- symbolp
- system-area-pointer-p
- weak-pointer-p
- vectorp
- unsigned-byte-32-p
- signed-byte-32-p
- simple-array-unsigned-byte-2-p
- simple-array-unsigned-byte-4-p
- simple-array-unsigned-byte-8-p
- simple-array-unsigned-byte-16-p
- simple-array-unsigned-byte-32-p
- simple-array-signed-byte-8-p
- simple-array-signed-byte-16-p
- simple-array-signed-byte-30-p
- simple-array-signed-byte-32-p
- simple-array-single-float-p
- simple-array-double-float-p
- #!+long-float simple-array-long-float-p
- simple-array-complex-single-float-p
- simple-array-complex-double-float-p
- #!+long-float simple-array-complex-long-float-p
- )))))
- (frob))
+;;; All the primitive type predicate wrappers share a parallel form..
+(macrolet ((def-type-predicate-wrapper (pred)
+ (let* ((name (symbol-name pred))
+ (stem (string-left-trim "%" (string-right-trim "P-" name)))
+ (article (if (position (schar name 0) "AEIOU") "an" "a")))
+ `(defun ,pred (object)
+ ,(format nil
+ "Return true if OBJECT is ~A ~A, and NIL otherwise."
+ article
+ stem)
+ ;; (falling through to low-level implementation)
+ (,pred object)))))
+ (def-type-predicate-wrapper array-header-p)
+ (def-type-predicate-wrapper arrayp)
+ (def-type-predicate-wrapper atom)
+ (def-type-predicate-wrapper base-char-p)
+ (def-type-predicate-wrapper bignump)
+ (def-type-predicate-wrapper bit-vector-p)
+ (def-type-predicate-wrapper characterp)
+ (def-type-predicate-wrapper code-component-p)
+ (def-type-predicate-wrapper consp)
+ (def-type-predicate-wrapper compiled-function-p)
+ (def-type-predicate-wrapper complexp)
+ (def-type-predicate-wrapper complex-double-float-p)
+ (def-type-predicate-wrapper complex-float-p)
+ #!+long-float (def-type-predicate-wrapper complex-long-float-p)
+ (def-type-predicate-wrapper complex-rational-p)
+ (def-type-predicate-wrapper complex-single-float-p)
+ ;; (COMPLEX-VECTOR-P is not included here since it's awkward to express
+ ;; the type it tests for in the Common Lisp type system, and since it's
+ ;; only used in the implementation of a few specialized things.)
+ (def-type-predicate-wrapper double-float-p)
+ (def-type-predicate-wrapper fdefn-p)
+ (def-type-predicate-wrapper fixnump)
+ (def-type-predicate-wrapper floatp)
+ (def-type-predicate-wrapper functionp)
+ (def-type-predicate-wrapper integerp)
+ (def-type-predicate-wrapper listp)
+ (def-type-predicate-wrapper long-float-p)
+ (def-type-predicate-wrapper lra-p)
+ (def-type-predicate-wrapper null)
+ (def-type-predicate-wrapper numberp)
+ (def-type-predicate-wrapper rationalp)
+ (def-type-predicate-wrapper ratiop)
+ (def-type-predicate-wrapper realp)
+ (def-type-predicate-wrapper short-float-p)
+ (def-type-predicate-wrapper sb!kernel:simple-array-p)
+ (def-type-predicate-wrapper simple-bit-vector-p)
+ (def-type-predicate-wrapper simple-string-p)
+ (def-type-predicate-wrapper simple-vector-p)
+ (def-type-predicate-wrapper single-float-p)
+ (def-type-predicate-wrapper stringp)
+ (def-type-predicate-wrapper %instancep)
+ (def-type-predicate-wrapper symbolp)
+ (def-type-predicate-wrapper system-area-pointer-p)
+ (def-type-predicate-wrapper weak-pointer-p)
+ (def-type-predicate-wrapper vectorp)
+ (def-type-predicate-wrapper unsigned-byte-32-p)
+ (def-type-predicate-wrapper signed-byte-32-p)
+ (def-type-predicate-wrapper simple-array-unsigned-byte-2-p)
+ (def-type-predicate-wrapper simple-array-unsigned-byte-4-p)
+ (def-type-predicate-wrapper simple-array-unsigned-byte-8-p)
+ (def-type-predicate-wrapper simple-array-unsigned-byte-16-p)
+ (def-type-predicate-wrapper simple-array-unsigned-byte-32-p)
+ (def-type-predicate-wrapper simple-array-signed-byte-8-p)
+ (def-type-predicate-wrapper simple-array-signed-byte-16-p)
+ (def-type-predicate-wrapper simple-array-signed-byte-30-p)
+ (def-type-predicate-wrapper simple-array-signed-byte-32-p)
+ (def-type-predicate-wrapper simple-array-single-float-p)
+ (def-type-predicate-wrapper simple-array-double-float-p)
+ #!+long-float (def-type-predicate-wrapper simple-array-long-float-p)
+ (def-type-predicate-wrapper simple-array-complex-single-float-p)
+ (def-type-predicate-wrapper simple-array-complex-double-float-p)
+ #!+long-float (def-type-predicate-wrapper simple-array-complex-long-float-p))
\f
;;; Return the specifier for the type of object. This is not simply
;;; (TYPE-SPECIFIER (CTYPE-OF OBJECT)) because CTYPE-OF has different
(defun type-of (object)
#!+sb-doc
"Return the type of OBJECT."
- (if (typep object '(or function array complex))
- (type-specifier (ctype-of object))
- (let* ((class (layout-class (layout-of object)))
- (name (class-name class)))
- (if (typep object 'instance)
- (case name
- (sb!alien-internals:alien-value
- `(sb!alien:alien
- ,(sb!alien-internals:unparse-alien-type
- (sb!alien-internals:alien-value-type object))))
- (t
- (class-proper-name class)))
- name))))
-\f
-;;; FIXME: This belongs somewhere else, perhaps in code/array.lisp.
-(defun upgraded-array-element-type (spec)
- #!+sb-doc
- "Return the element type that will actually be used to implement an array
- with the specifier :ELEMENT-TYPE Spec."
- (type-specifier
- (array-type-specialized-element-type
- (specifier-type `(array ,spec)))))
+ (typecase object
+ (fixnum
+ (cond
+ ((<= 0 object 1) 'bit)
+ ((< object 0) 'fixnum)
+ (t '(integer 0 #.sb!xc:most-positive-fixnum))))
+ (integer
+ (if (>= object 0)
+ '(integer #.(1+ sb!xc:most-positive-fixnum))
+ 'bignum))
+ (standard-char 'standard-char)
+ ((member t) 'boolean)
+ (keyword 'keyword)
+ ((or array complex) (type-specifier (ctype-of object)))
+ (t
+ (let* ((classoid (layout-classoid (layout-of object)))
+ (name (classoid-name classoid)))
+ (if (typep object 'instance)
+ (case name
+ (sb!alien-internals:alien-value
+ `(sb!alien:alien
+ ,(sb!alien-internals:unparse-alien-type
+ (sb!alien-internals:alien-value-type object))))
+ (t
+ (let ((pname (classoid-proper-name classoid)))
+ (if (classoid-p pname)
+ (classoid-pcl-class pname)
+ pname))))
+ name)))))
\f
;;;; equality predicates
"Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
(eq obj1 obj2))
+(defun bit-vector-= (x y)
+ (declare (type bit-vector x y))
+ (if (and (simple-bit-vector-p x)
+ (simple-bit-vector-p y))
+ (bit-vector-= x y) ; DEFTRANSFORM
+ (and (= (length x) (length y))
+ (do ((i 0 (1+ i))
+ (length (length x)))
+ ((= i length) t)
+ (declare (fixnum i))
+ (unless (= (bit x i) (bit y i))
+ (return nil))))))
+
(defun equal (x y)
#!+sb-doc
- "Returns T if X and Y are EQL or if they are structured components
+ "Return T if X and Y are EQL or if they are structured components
whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
are the same length and have identical components. Other arrays must be
EQ to be EQUAL."
(and (pathnamep y) (pathname= x y)))
((bit-vector-p x)
(and (bit-vector-p y)
- (= (the fixnum (length x))
- (the fixnum (length y)))
- (do ((i 0 (1+ i))
- (length (length x)))
- ((= i length) t)
- (declare (fixnum i))
- (or (= (the fixnum (bit x i))
- (the fixnum (bit y i)))
- (return nil)))))
+ (bit-vector-= x y)))
(t nil)))
;;; EQUALP comparison of HASH-TABLE values
(defun equalp (x y)
#+nil ; KLUDGE: If doc string, should be accurate: Talk about structures
; and HASH-TABLEs.
- "Just like EQUAL, but more liberal in several respects.
+ "This is like EQUAL, except more liberal in several respects.
Numbers may be of different types, as long as the values are identical
after coercion. Characters may differ in alphabetic case. Vectors and
arrays must have identical dimensions and EQUALP elements, but may differ
(len (layout-length layout-x)))
(and (typep y 'instance)
(eq layout-x (%instance-layout y))
- (structure-class-p (layout-class layout-x))
+ (structure-classoid-p (layout-classoid layout-x))
(do ((i 1 (1+ i)))
((= i len) t)
(declare (fixnum i))
(equalp x-el y-el))
(return nil))))))
(t nil)))
+
+(/show0 "about to do test cases in pred.lisp")
#!+sb-test
-(let ((test-cases '((0.0 -0.0 t)
+(let ((test-cases `((0.0 ,(load-time-value (make-unportable-float :single-float-negative-zero)) t)
(0.0 1.0 nil)
(#c(1 0) #c(1.0 0) t)
(#c(1.1 0) #c(11/10 0) nil) ; due to roundoff error
("Hello" "hello" t)
("Hello" #(#\h #\E #\l #\l #\o) t)
("Hello" "goodbye" nil))))
+ (/show0 "TEST-CASES bound in pred.lisp")
(dolist (test-case test-cases)
+ (/show0 "about to do a TEST-CASE in pred.lisp")
(destructuring-bind (x y expected-result) test-case
(let* ((result (equalp x y))
(bresult (if result 1 0))
(expected-bresult (if expected-result 1 0)))
(unless (= bresult expected-bresult)
+ (/show0 "failing test in pred.lisp")
(error "failed test (EQUALP ~S ~S)" x y))))))
+(/show0 "done with test cases in pred.lisp")
projects / sbcl.git / blobdiff