1.0.3.20: better SEARCH transform

[sbcl.git] / tests / seq.impure.lisp

diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp
index 8356b90..ae10560 100644 (file)
--- a/tests/seq.impure.lisp
+++ b/tests/seq.impure.lisp
@@ -162,7 +162,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 +258,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 +292,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 +305,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 +340,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"))
@@ -511,7 +531,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)))
@@ -986,6 +1008,8 @@
                      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