X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpred.lisp;h=f2e2e6b91844ad68c0cfce547d7e9a4e4de1ca04;hb=18dc0069cd514c976042766ab9a785c970fe1603;hp=0d34b488681dac92245721ea3f0d399c8bd8d5ab;hpb=568daf6b160280428701670b921f419aabd9eba0;p=sbcl.git diff --git a/src/code/pred.lisp b/src/code/pred.lisp index 0d34b48..f2e2e6b 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -17,12 +17,50 @@ (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) + (and (not (listp x)) + (not (vectorp x)) + (let* ((slayout #.(info :type :compiler-layout 'sequence)) + (depthoid #.(layout-depthoid (info :type :compiler-layout 'sequence))) + (layout (layout-of x))) + (when (layout-invalid layout) + (setq layout (update-object-layout-or-invalid x slayout))) + (if (eq layout slayout) + t + (let ((inherits (layout-inherits layout))) + (declare (optimize (safety 0))) + (and (> (length inherits) depthoid) + (eq (svref inherits depthoid) slayout))))))) + +;;; Is X a SEQUENCE? Harder than just (OR VECTOR LIST) +(defun sequencep (x) + (or (listp x) + (vectorp x) + (let* ((slayout #.(info :type :compiler-layout 'sequence)) + (depthoid #.(layout-depthoid (info :type :compiler-layout 'sequence))) + (layout (layout-of x))) + (when (layout-invalid layout) + (setq layout (update-object-layout-or-invalid x slayout))) + (if (eq layout slayout) + t + (let ((inherits (layout-inherits layout))) + (declare (optimize (safety 0))) + (and (> (length inherits) depthoid) + (eq (svref inherits depthoid) slayout))))))) ;;;; primitive predicates. These must be supported directly by the ;;;; compiler. @@ -47,7 +85,10 @@ (def-type-predicate-wrapper array-header-p) (def-type-predicate-wrapper arrayp) (def-type-predicate-wrapper atom) - (def-type-predicate-wrapper base-char-p) + ;; Testing for BASE-CHAR-P is usually redundant on #-sb-unicode, + ;; remove it there completely so that #-sb-unicode build will + ;; break when it's used. + #!+sb-unicode (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) @@ -81,44 +122,42 @@ (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) + #!+sb-simd-pack (def-type-predicate-wrapper simd-pack-p) (def-type-predicate-wrapper %instancep) (def-type-predicate-wrapper symbolp) + (def-type-predicate-wrapper %other-pointer-p) (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)) + +#!+(or x86 x86-64) +(defun fixnum-mod-p (x limit) + (and (fixnump x) + (<= 0 x limit))) + ;;; Return the specifier for the type of object. This is not simply ;;; (TYPE-SPECIFIER (CTYPE-OF OBJECT)) because CTYPE-OF has different @@ -142,7 +181,8 @@ (extended-char 'extended-char) ((member t) 'boolean) (keyword 'keyword) - ((or array complex) (type-specifier (ctype-of object))) + ((or array complex #!+sb-simd-pack sb!kernel:simd-pack) + (type-specifier (ctype-of object))) (t (let* ((classoid (layout-classoid (layout-of object))) (name (classoid-name classoid))) @@ -206,23 +246,24 @@ (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)))))) + (cond ((eq x y)) + ((and (simple-bit-vector-p x) + (simple-bit-vector-p y)) + (bit-vector-= x y)) ; DEFTRANSFORM + (t + (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 - 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." + "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." ;; Non-tail self-recursion implemented with a local auxiliary function ;; is a lot faster than doing it the straightforward way (at least ;; on x86oids) due to calling convention differences. -- JES, 2005-12-30 @@ -284,18 +325,21 @@ (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) @@ -325,8 +369,9 @@ #!+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))))