(def-type-predicate-wrapper arrayp)
(def-type-predicate-wrapper atom)
(def-type-predicate-wrapper base-char-p)
+ (def-type-predicate-wrapper base-string-p)
+ #!+sb-unicode (def-type-predicate-wrapper character-string-p)
(def-type-predicate-wrapper bignump)
(def-type-predicate-wrapper bit-vector-p)
(def-type-predicate-wrapper characterp)
;; 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 extended-char-p)
(def-type-predicate-wrapper fdefn-p)
(def-type-predicate-wrapper fixnump)
(def-type-predicate-wrapper floatp)
(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-array-p)
(def-type-predicate-wrapper simple-bit-vector-p)
+ (def-type-predicate-wrapper simple-base-string-p)
+ #!+sb-unicode (def-type-predicate-wrapper simple-character-string-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 vectorp)
(def-type-predicate-wrapper unsigned-byte-32-p)
(def-type-predicate-wrapper signed-byte-32-p)
+ (def-type-predicate-wrapper simple-array-nil-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)
#!+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))
+ #!+long-float (def-type-predicate-wrapper simple-array-complex-long-float-p)
+ (def-type-predicate-wrapper vector-nil-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."
- (if (unknown-type-p (specifier-type spec))
- (error "undefined type: ~S" 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)
+ (base-char 'base-char)
+ (extended-char 'extended-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
"Return T if X and Y are EQL or if they are structured components
(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
(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))
(/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
projects / sbcl.git / blobdiff