X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpred.lisp;h=ada4bed3944be9a718a0851f98b8684c3d8ed098;hb=dc33d6a6b84f8338e603759cec8e25da29055d50;hp=79944d2c722114e18e5259c72713a64faee404b5;hpb=667ec9d494530079bef28e8589dd0d3274b935ec;p=sbcl.git diff --git a/src/code/pred.lisp b/src/code/pred.lisp index 79944d2..ada4bed 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -47,6 +47,8 @@ (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) @@ -63,6 +65,7 @@ ;; 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) @@ -77,8 +80,10 @@ (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) @@ -90,6 +95,7 @@ (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) @@ -104,7 +110,8 @@ #!+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)) ;;; Return the specifier for the type of object. This is not simply ;;; (TYPE-SPECIFIER (CTYPE-OF OBJECT)) because CTYPE-OF has different @@ -113,29 +120,37 @@ (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)))) - -;;; 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))))) ;;;; equality predicates @@ -145,6 +160,19 @@ "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 @@ -162,15 +190,7 @@ (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 @@ -214,7 +234,7 @@ (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)) @@ -250,7 +270,7 @@ (/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