X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpred.lisp;h=f2e2e6b91844ad68c0cfce547d7e9a4e4de1ca04;hb=0c08cc954cc0910079bdcf153cccf9a95ef11d67;hp=2830c518a48505cffcab42342f9f3a2e896c0087;hpb=a0238f83af553a3ff662824fc73aca3ba01112f6;p=sbcl.git diff --git a/src/code/pred.lisp b/src/code/pred.lisp index 2830c51..f2e2e6b 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) @@ -79,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) @@ -106,8 +115,6 @@ (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) @@ -115,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 @@ -176,7 +181,7 @@ (extended-char 'extended-char) ((member t) 'boolean) (keyword 'keyword) - ((or array complex) + ((or array complex #!+sb-simd-pack sb!kernel:simd-pack) (type-specifier (ctype-of object))) (t (let* ((classoid (layout-classoid (layout-of object))) @@ -241,16 +246,18 @@ (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