X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fseq.impure.lisp;h=ffb1ec7d1b5b1830044f401c403f830ef22d6979;hb=83659744f9caa97aa83eb562d872b1c0127403c0;hp=52b8b1321a81562f172b171067fe633a14d6543c;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp index 52b8b13..ffb1ec7 100644 --- a/tests/seq.impure.lisp +++ b/tests/seq.impure.lisp @@ -13,10 +13,11 @@ ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. +(load "test-util.lisp") (load "assertoid.lisp") (defpackage :seq-test - (:use :cl :assertoid)) + (:use :cl :assertoid :test-util)) (in-package :seq-test) @@ -162,7 +163,23 @@ (eql 3 (position-if #'plusp seq :from-end t :key '1- :start 2)) (null (position-if #'plusp seq :from-end t :key '1- :start 2 :end 2)) (null (find-if-not #'plusp seq)) - (eql 0 (position-if-not #'evenp seq)))) + (eql 0 (position-if-not #'evenp seq)) + (eql 0 (search #(1) seq)) + (eql 1 (search #(4 5) seq :key 'oddp)) + (eql 1 (search #(-2) seq :test (lambda (a b) (= (- a) b)))) + (eql 4 (search #(1) seq :start2 1)) + (null (search #(3) seq :start2 3)) + (eql 2 (search #(3) seq :start2 2)) + (eql 0 (search #(1 2) seq)) + (null (search #(2 1 3) seq)) + (eql 0 (search #(0 1 2 4) seq :start1 1 :end1 3)) + (eql 3 (search #(0 2 1 4) seq :start1 1 :end1 3)) + (eql 4 (search #(1) seq :from-end t)) + (eql 0 (search #(1 2) seq :from-end t)) + (null (search #(1 2) seq :from-end t :start2 1)) + (eql 0 (search #(0 1 2 4) seq :from-end t :start1 1 :end1 3)) + (eql 3 (search #(0 2 1 4) seq :from-end t :start1 1 :end1 3)) + (null (search #(2 1 3) seq :from-end t)))) (for-every-seq "string test" '((null (find 0 seq)) (null (find #\D seq :key #'char-upcase)) @@ -242,13 +259,15 @@ (coerce #(0 0 0 1 1 1) `(,@type-stub 6)))) (assert-type-error (concatenate `(,@type-stub 5) #(0 0 0) #*111)) ;; MERGE - (assert (= (length (merge `(,@type-stub) #(0 1 0) #*111 #'>)) 6)) - (assert (equalp (merge `(,@type-stub) #(0 1 0) #*111 #'>) - (coerce #(1 1 1 0 1 0) `(,@type-stub)))) - (assert (= (length (merge `(,@type-stub 6) #(0 1 0) #*111 #'>)) 6)) - (assert (equalp (merge `(,@type-stub 6) #(0 1 0) #*111 #'>) - (coerce #(1 1 1 0 1 0) `(,@type-stub 6)))) - (assert-type-error (merge `(,@type-stub 4) #(0 1 0) #*111 #'>)) + (macrolet ((test (type) + `(merge ,type (copy-seq #(0 1 0)) (copy-seq #*111) #'>))) + (assert (= (length (test `(,@type-stub))) 6)) + (assert (equalp (test `(,@type-stub)) + (coerce #(1 1 1 0 1 0) `(,@type-stub)))) + (assert (= (length (test `(,@type-stub 6))) 6)) + (assert (equalp (test `(,@type-stub 6)) + (coerce #(1 1 1 0 1 0) `(,@type-stub 6)))) + (assert-type-error (test `(,@type-stub 4)))) ;; MAP (assert (= (length (map `(,@type-stub) #'logxor #(0 0 1 1) '(0 1 0 1))) 4)) (assert (equalp (map `(,@type-stub) #'logxor #(0 0 1 1) '(0 1 0 1)) @@ -274,7 +293,7 @@ (assert (equalp #(11 13) (map '(simple-array fixnum (*)) #'+ '(1 2 3) '(10 11)))) (assert-type-error (coerce '(1 2 3) 'simple-array)) - (assert-type-error (merge 'simple-array '(1 3) '(2 4) '<)) + (assert-type-error (merge 'simple-array (list 1 3) (list 2 4) '<)) (assert (equalp #(3 2 1) (coerce '(3 2 1) '(vector fixnum)))) (assert-type-error (map 'array #'identity '(1 2 3))) (assert-type-error (map '(array fixnum) #'identity '(1 2 3))) @@ -287,9 +306,9 @@ ;;; As pointed out by Raymond Toy on #lisp IRC, MERGE had some issues ;;; with user-defined types until sbcl-0.7.8.11 (deftype list-typeoid () 'list) -(assert (equal '(1 2 3 4) (merge 'list-typeoid '(1 3) '(2 4) '<))) +(assert (equal '(1 2 3 4) (merge 'list-typeoid (list 1 3) (list 2 4) '<))) ;;; and also with types that weren't precicely LIST -(assert (equal '(1 2 3 4) (merge 'cons '(1 3) '(2 4) '<))) +(assert (equal '(1 2 3 4) (merge 'cons (list 1 3) (list 2 4) '<))) ;;; but wait, there's more! The NULL and CONS types also have implicit ;;; length requirements: @@ -322,12 +341,14 @@ (assert (= (length (coerce #(1) '(cons t null))) 1)) (assert-type-error (coerce #() 'nil)) ;; MERGE - (assert-type-error (merge 'null '(1 3) '(2 4) '<)) + (assert-type-error (merge 'null (list 1 3) (list 2 4) '<)) (assert-type-error (merge 'cons () () '<)) (assert (null (merge 'null () () '<))) - (assert (= (length (merge 'cons '(1 3) '(2 4) '<)) 4)) + (assert (= (length (merge 'cons (list 1 3) (list 2 4) '<)) 4)) (assert (= (length (merge '(cons t (cons t (cons t (cons t null)))) - '(1 3) '(2 4) '<)) 4)) + (list 1 3) (list 2 4) + '<)) + 4)) (assert-type-error (merge 'nil () () '<)) ;; CONCATENATE (assert-type-error (concatenate 'null '(1) "2")) @@ -357,15 +378,18 @@ (svref x 0)) (assert (raises-error? (svrefalike #*0) type-error)) -;;; checks for uniform bounding index handling under SAFETY 3 code. +;;; checks for uniform bounding index handling. +;;; +;;; This used to be SAFETY 3 only, but bypassing these checks with +;;; above-zero speed when SPEED > SAFETY is not The SBCL Way. ;;; ;;; KLUDGE: not all in one big form because that causes SBCL to spend ;;; an absolute age trying to compile it. (defmacro sequence-bounding-indices-test (&body body) `(progn - (locally + (locally ;; See Issues 332 [and 333(!)] in the CLHS - (declare (optimize (safety 3))) + (declare (optimize (speed 3) (safety 1))) (let ((string (make-array 10 :fill-pointer 5 :initial-element #\a @@ -381,7 +405,7 @@ ,@(cdr body)))) (locally ;; See Issues 332 [and 333(!)] in the CLHS - (declare (optimize (safety 3))) + (declare (optimize (speed 3) (safety 1))) (let ((string (make-array 10 :fill-pointer 5 :initial-element #\a @@ -511,7 +535,9 @@ (sequence-bounding-indices-test (format t "~&/Function PARSE-NAMESTRING") (setf (fill-pointer string) 10) - (setf (subseq string 0 10) "/dev/ /tmp") + (setf (subseq string 0 10) + #-win32 "/dev/ /tmp" + #+win32 "C:/ NUL") (setf (fill-pointer string) 5) (assert (truename (parse-namestring string nil *default-pathname-defaults* :start 0 :end 5))) @@ -932,7 +958,8 @@ standard bashed) ;; fill vectors ;; a) the standard slow way - (fill standard c :start offset :end (+ offset n)) + (locally (declare (notinline fill)) + (fill standard c :start offset :end (+ offset n))) ;; b) the blazingly fast way (let ((value (loop for i from 0 by bitsize until (= i sb-vm:n-word-bits) @@ -986,14 +1013,109 @@ bashed-dst) (return-from test-copy-bashing nil)))))))) +;; Too slow for the interpreter +#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) (loop for i = 1 then (* i 2) do - ;; the bare '32' here is fairly arbitrary; '8' provides a good - ;; range of lengths over which to fill and copy, which should tease - ;; out most errors in the code (if any exist). (It also makes this - ;; part of the test suite finish reasonably quickly.) - (assert (test-fill-bashing i 32 8)) - (assert (test-copy-bashing i 32 8)) + ;; the bare '13' here is fairly arbitrary, except that it's been + ;; reduced from '32', which made the tests take aeons; '8' provides + ;; a good range of lengths over which to fill and copy, which + ;; should tease out most errors in the code (if any exist). (It + ;; also makes this part of the test suite finish reasonably + ;; quickly.) + (assert (time (test-fill-bashing i 13 8))) + (assert (time (test-copy-bashing i 13 8))) until (= i sb-vm:n-word-bits)) + +(defun test-inlined-bashing (bitsize) + ;; We have to compile things separately for each bitsize so the + ;; compiler will work out the array type and trigger the REPLACE + ;; transform. + (let ((lambda-form + `(lambda () + (let* ((n-elements-per-word ,(truncate sb-vm:n-word-bits bitsize)) + (size (* 3 n-elements-per-word)) + (standard-dst (make-array size :element-type '(unsigned-byte ,bitsize))) + (bashed-dst (make-array size :element-type '(unsigned-byte ,bitsize))) + (source (make-array size :element-type '(unsigned-byte ,bitsize)))) + (declare (type (simple-array (unsigned-byte ,bitsize) (*)) + source standard-dst bashed-dst)) + (do ((i 0 (1+ i)) + (offset n-elements-per-word (1+ offset))) + ((>= offset (* 2 n-elements-per-word)) t) + (dolist (c (fill-bytes-for-testing ,bitsize)) + (fill-with-known-value (mod (lognot c) (ash 1 ,bitsize)) size + source standard-dst bashed-dst) + ;; fill with test-data + (fill source c :start offset :end (+ offset n-elements-per-word)) + ;; copy filled data to test vectors + ;; + ;; a) the slow way (which is actually fast, since this + ;; should be transformed into UB*-BASH-COPY) + (replace standard-dst source + :start1 (- offset n-elements-per-word i) + :start2 (- offset n-elements-per-word i) + :end1 offset :end2 offset) + ;; b) the fast way--we fold the + ;; :START{1,2} arguments above ourselves + ;; to trigger the REPLACE transform + (replace bashed-dst source + :start1 0 :start2 0 :end1 offset :end2 offset) + ;; check for errors + (when (or (mismatch standard-dst bashed-dst) + ;; trigger COPY-SEQ transform + (mismatch (copy-seq standard-dst) bashed-dst) + ;; trigger SUBSEQ transform + (mismatch (subseq standard-dst (- offset n-elements-per-word i)) + bashed-dst)) + (format t "Test with target-offset ~A, source-offset ~A, fill ~A, and length ~A failed.~%" + 0 0 c offset) + (format t "Mismatch:~% correct ~A~% actual ~A~%" + standard-dst + bashed-dst) + (return-from nil nil)))))))) + (funcall (compile nil lambda-form)))) + +#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) +(loop for i = 1 then (* i 2) do + (assert (test-inlined-bashing i)) + until (= i sb-vm:n-word-bits)) + +;;; tests from the Sacla test suite via Eric Marsden, 2007-05-07 +(remove-duplicates (vector 1 2 2 1) :test-not (lambda (a b) (not (= a b)))) + +(delete-duplicates (vector #\a #\b #\c #\a) + :test-not (lambda (a b) (not (char-equal a b)))) + +;;; FILL on lists +(let ((l (list 1 2 3))) + (assert (eq l (fill l 0 :start 1 :end 2))) + (assert (equal l '(1 0 3))) + (assert (eq l (fill l 'x :start 2 :end 3))) + (assert (equal l '(1 0 x))) + (assert (eq l (fill l 'y :start 1))) + (assert (equal l '(1 y y))) + (assert (eq l (fill l 'z :end 2))) + (assert (equal l '(z z y))) + (assert (eq l (fill l 1))) + (assert (equal l '(1 1 1))) + (assert (raises-error? (fill l 0 :start 4))) + (assert (raises-error? (fill l 0 :end 4))) + (assert (raises-error? (fill l 0 :start 2 :end 1)))) + +;;; Both :TEST and :TEST-NOT provided +(with-test (:name :test-and-test-not-to-adjoin) + (let* ((wc 0) + (fun + (handler-bind (((and warning (not style-warning)) + (lambda (w) (incf wc)))) + (compile nil `(lambda (item test test-not) (adjoin item '(1 2 3 :foo) + :test test + :test-not test-not)))))) + (assert (= 1 wc)) + (assert (eq :error + (handler-case + (funcall fun 1 #'eql (complement #'eql)) + (error () + :error)))))) ;;; success -(sb-ext:quit :unix-status 104)