X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpred.lisp;h=417b1c0a3d2ee77c761df57492df587311fc4fbe;hb=4084b6b95c1d5e0a45e073a9b875d8471efd8505;hp=7d006cce2b6bb789a15163a745b7092954b0218b;hpb=b2f0204834bd0c314d44942dd92475c15ffa8c89;p=sbcl.git diff --git a/src/code/pred.lisp b/src/code/pred.lisp index 7d006cc..417b1c0 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -17,12 +17,18 @@ (defun streamp (stream) (typep stream 'stream)) -;;; Is X a (VECTOR T)? -(defun vector-t-p (x) - (or (simple-vector-p x) - (and (complex-vector-p x) - (do ((data (%array-data-vector x) (%array-data-vector data))) - ((not (array-header-p data)) (simple-vector-p data)))))) +;;; various (VECTOR FOO) type predicates, not implemented as simple +;;; widetag tests +(macrolet + ((def () + `(progn + ,@(loop for (name spec) in *vector-without-complex-typecode-infos* + collect `(defun ,name (x) + (or (typep x '(simple-array ,spec (*))) + (and (complex-vector-p x) + (do ((data (%array-data-vector x) (%array-data-vector data))) + ((not (array-header-p data)) (typep data '(simple-array ,spec (*)))))))))))) + (def)) ;;; Is X an extended sequence? (defun extended-sequence-p (x) @@ -115,43 +121,33 @@ (def-type-predicate-wrapper ratiop) (def-type-predicate-wrapper realp) (def-type-predicate-wrapper short-float-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 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) - #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) - (def-type-predicate-wrapper unsigned-byte-32-p) #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) - (def-type-predicate-wrapper signed-byte-32-p) - #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) - (def-type-predicate-wrapper unsigned-byte-64-p) + (progn + (def-type-predicate-wrapper unsigned-byte-32-p) + (def-type-predicate-wrapper signed-byte-32-p)) #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) - (def-type-predicate-wrapper signed-byte-64-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) - (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) + (progn + (def-type-predicate-wrapper unsigned-byte-64-p) + (def-type-predicate-wrapper signed-byte-64-p)) + ;; Specialized array types + (macrolet ((saetp-defs () + `(progn + ,@(map 'list + (lambda (saetp) + `(def-type-predicate-wrapper + ,(symbolicate (sb!vm:saetp-primitive-type-name saetp) "-P"))) + sb!vm:*specialized-array-element-type-properties*)))) + (saetp-defs)) + ;; Other array types + (def-type-predicate-wrapper simple-array-p) + (def-type-predicate-wrapper simple-string-p) + (def-type-predicate-wrapper stringp) + (def-type-predicate-wrapper vectorp) (def-type-predicate-wrapper vector-nil-p)) ;;; Return the specifier for the type of object. This is not simply @@ -176,7 +172,8 @@ (extended-char 'extended-char) ((member t) 'boolean) (keyword 'keyword) - ((or array complex) (type-specifier (ctype-of object))) + ((or array complex) + (type-specifier (ctype-of object))) (t (let* ((classoid (layout-classoid (layout-of object))) (name (classoid-name classoid))) @@ -317,18 +314,21 @@ length and have identical components. Other arrays must be EQ to be EQUAL." (hash-table-equalp x y))) ((%instancep x) (let* ((layout-x (%instance-layout x)) - (len (layout-length layout-x))) + (raw-len (layout-n-untagged-slots layout-x)) + (total-len (layout-length layout-x)) + (normal-len (- total-len raw-len))) (and (%instancep y) (eq layout-x (%instance-layout y)) (structure-classoid-p (layout-classoid layout-x)) - (do ((i 1 (1+ i))) - ((= i len) t) - (declare (fixnum i)) + (dotimes (i normal-len t) (let ((x-el (%instance-ref x i)) (y-el (%instance-ref y i))) (unless (or (eq x-el y-el) (equalp x-el y-el)) - (return nil))))))) + (return nil)))) + (if (zerop raw-len) + t + (raw-instance-slots-equalp layout-x x y))))) ((vectorp x) (let ((length (length x))) (and (vectorp y) @@ -358,8 +358,9 @@ length and have identical components. Other arrays must be EQ to be EQUAL." #!+sb-test (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 + (#c(1 0) #c(1.0 0.0) t) + (#c(0 1) #c(0.0 1.0) t) + (#c(1.1 0.0) #c(11/10 0) nil) ; due to roundoff error ("Hello" "hello" t) ("Hello" #(#\h #\E #\l #\l #\o) t) ("Hello" "goodbye" nil))))