X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpred.lisp;h=44e6f19ada564a6652913275a273f3871ed51204;hb=d720bc359f03734ccb9baf66cb45dc01d623f369;hp=a3d18bd692c7a0052f0f6e97d0cb9e684e513f3e;hpb=3ceaa081c90a970f6779e02bed659835a202772c;p=sbcl.git diff --git a/src/code/pred.lisp b/src/code/pred.lisp index a3d18bd..44e6f19 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -17,11 +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) - (simple-vector-p (%array-data-vector x))))) +;;; 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. @@ -80,37 +119,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) + #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) + (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)) + (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 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) - (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) (def-type-predicate-wrapper vector-nil-p)) ;;; Return the specifier for the type of object. This is not simply @@ -135,7 +170,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))) @@ -212,10 +248,12 @@ (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 (labels ((equal-aux (x y) (cond ((%eql x y) t) @@ -231,6 +269,8 @@ (and (bit-vector-p y) (bit-vector-= x y))) (t nil)))) + ;; Use MAYBE-INLINE to get the inline expansion only once (instead + ;; of 200 times with INLINE). -- JES, 2005-12-30 (declare (maybe-inline equal-aux)) (equal-aux x y))) @@ -272,18 +312,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) @@ -313,8 +356,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))))