X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpred.lisp;h=7d006cce2b6bb789a15163a745b7092954b0218b;hb=3b6e07c0fcb050fa86c7c42db33f49107e3097e6;hp=dc780441f9b18f7011fd709235a470c6a8718bbe;hpb=0aecc2b20142e08068c3434273500131cb13fe2d;p=sbcl.git diff --git a/src/code/pred.lisp b/src/code/pred.lisp index dc78044..7d006cc 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -21,7 +21,40 @@ (defun vector-t-p (x) (or (simple-vector-p x) (and (complex-vector-p x) - (simple-vector-p (%array-data-vector x))))) + (do ((data (%array-data-vector x) (%array-data-vector data))) + ((not (array-header-p data)) (simple-vector-p data)))))) + +;;; 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. @@ -73,6 +106,8 @@ (def-type-predicate-wrapper integerp) (def-type-predicate-wrapper listp) (def-type-predicate-wrapper long-float-p) + #!+(and sb-thread sb-lutex) + (def-type-predicate-wrapper lutexp) (def-type-predicate-wrapper lra-p) (def-type-predicate-wrapper null) (def-type-predicate-wrapper numberp) @@ -93,8 +128,14 @@ (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) + #!+#.(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) @@ -160,6 +201,43 @@ "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL." (eq obj1 obj2)) +(declaim (inline %eql)) +(defun %eql (obj1 obj2) + #!+sb-doc + "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL." + (or (eq obj1 obj2) + (if (or (typep obj2 'fixnum) + (not (typep obj2 'number))) + nil + (macrolet ((foo (&rest stuff) + `(typecase obj2 + ,@(mapcar (lambda (foo) + (let ((type (car foo)) + (fn (cadr foo))) + `(,type + (and (typep obj1 ',type) + (,fn obj1 obj2))))) + stuff)))) + (foo + (single-float eql) + (double-float eql) + #!+long-float + (long-float eql) + (bignum + (lambda (x y) + (zerop (bignum-compare x y)))) + (ratio + (lambda (x y) + (and (eql (numerator x) (numerator y)) + (eql (denominator x) (denominator y))))) + (complex + (lambda (x y) + (and (eql (realpart x) (realpart y)) + (eql (imagpart x) (imagpart y)))))))))) + +(defun eql (x y) + (%eql x y)) + (defun bit-vector-= (x y) (declare (type bit-vector x y)) (if (and (simple-bit-vector-p x) @@ -175,23 +253,31 @@ (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." - (cond ((eql x y) t) - ((consp x) - (and (consp y) - (equal (car x) (car y)) - (equal (cdr x) (cdr y)))) - ((stringp x) - (and (stringp y) (string= x y))) - ((pathnamep x) - (and (pathnamep y) (pathname= x y))) - ((bit-vector-p x) - (and (bit-vector-p y) - (bit-vector-= x y))) - (t nil))) + "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) + ((consp x) + (and (consp y) + (equal-aux (car x) (car y)) + (equal-aux (cdr x) (cdr y)))) + ((stringp x) + (and (stringp y) (string= x y))) + ((pathnamep x) + (and (pathnamep y) (pathname= x y))) + ((bit-vector-p x) + (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))) ;;; EQUALP comparison of HASH-TABLE values (defun hash-table-equalp (x y)