fix SEARCH vector vector transform

 Didn't handle empty sequences correctly.

 Didn't handle NIL as KEY correctly.

diff --git a/NEWS b/NEWS
index 9f2db4e..88709b9 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -27,6 +27,8 @@ changes relative to sbcl-1.0.52:
     on 64 bit platforms. (lp#881445)
   * bug fix: DELETE-FILE did not MERGE-PATHNAMES, making it possible to
     delete the wrong file when using relative pathnames. (lp#882877)
+  * bug fix: optimized SEARCH of vectors-on-vectors mishandled zero-length
+    sequences and :KEY NIL.
 
 changes in sbcl-1.0.52 relative to sbcl-1.0.51:
   * enhancement: ASDF has been updated to version 2.017.

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index d086e3e..9b9db97 100644 (file)
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -1055,60 +1055,78 @@
                       :node node
                       :policy (> speed (max space safety)))
   "open code"
-  (let ((from-end (when (lvar-p from-end)
-                    (unless (constant-lvar-p from-end)
-                      (give-up-ir1-transform ":FROM-END is not constant."))
-                    (lvar-value from-end)))
-        (keyp (lvar-p key))
-        (testp (lvar-p test))
-        (check-bounds-p (policy node (plusp insert-array-bounds-checks))))
-    `(block search
-       (flet ((oops (vector start end)
-                (sequence-bounding-indices-bad-error vector start end)))
-         (let* ((len1 (length pattern))
-                (len2 (length text))
-                (end1 (or end1 len1))
-                (end2 (or end2 len2))
-               ,@(when keyp
-                       '((key (coerce key 'function))))
-               ,@(when testp
-                       '((test (coerce test 'function)))))
-          (declare (type index start1 start2 end1 end2))
-          ,@(when check-bounds-p
-             `((unless (<= start1 end1 len1)
-                 (oops pattern start1 end1))
-               (unless (<= start2 end2 len2)
-                 (oops pattern start2 end2))))
-          (do (,(if from-end
-                    '(index2 (- end2 (- end1 start1)) (1- index2))
-                    '(index2 start2 (1+ index2))))
-              (,(if from-end
-                    '(< index2 start2)
-                    '(>= index2 end2))
-               nil)
-            ;; INDEX2 is FIXNUM, not an INDEX, as right before the loop
-            ;; terminates is hits -1 when :FROM-END is true and :START2
-            ;; is 0.
-            (declare (type fixnum index2))
-            (when (do ((index1 start1 (1+ index1))
-                       (index2 index2 (1+ index2)))
-                      ((>= index1 end1) t)
-                    (declare (type index index1 index2)
-                             (optimize (insert-array-bounds-checks 0)))
-                    ,@(unless from-end
-                              '((when (= index2 end2)
-                                  (return-from search nil))))
-                    (unless (,@(if testp
-                                   '(funcall test)
-                                   '(eql))
-                               ,(if keyp
-                                    '(funcall key (aref pattern index1))
-                                    '(aref pattern index1))
-                               ,(if keyp
-                                    '(funcall key (aref text index2))
-                                    '(aref text index2)))
-                      (return nil)))
-              (return index2))))))))
+  (flet ((maybe (x)
+           (when (lvar-p x)
+             (if (constant-lvar-p x)
+                 (when (lvar-value x)
+                   :yes)
+                 :maybe))))
+    (let ((from-end (when (lvar-p from-end)
+                     (unless (constant-lvar-p from-end)
+                       (give-up-ir1-transform ":FROM-END is not constant."))
+                     (lvar-value from-end)))
+         (key? (maybe key))
+         (test? (maybe test))
+         (check-bounds-p (policy node (plusp insert-array-bounds-checks))))
+     `(block search
+        (flet ((oops (vector start end)
+                 (sequence-bounding-indices-bad-error vector start end)))
+          (let* ((len1 (length pattern))
+                 (len2 (length text))
+                 (end1 (or end1 len1))
+                 (end2 (or end2 len2))
+                 ,@(case key?
+                     (:yes `((key (%coerce-callable-to-fun key))))
+                     (:maybe `((key (when key
+                                      (%coerce-callable-to-fun key))))))
+                 ,@(when test?
+                     `((test (%coerce-callable-to-fun test)))))
+            (declare (type index start1 start2 end1 end2))
+            ,@(when check-bounds-p
+                `((unless (<= start1 end1 len1)
+                    (oops pattern start1 end1))
+                  (unless (<= start2 end2 len2)
+                    (oops pattern start2 end2))))
+            (when (= 0 end1)
+              (return-from search 0))
+            (do (,(if from-end
+                      '(index2 (- end2 (- end1 start1)) (1- index2))
+                      '(index2 start2 (1+ index2))))
+                (,(if from-end
+                      '(< index2 start2)
+                      '(>= index2 end2))
+                 nil)
+              ;; INDEX2 is FIXNUM, not an INDEX, as right before the loop
+              ;; terminates is hits -1 when :FROM-END is true and :START2
+              ;; is 0.
+              (declare (type fixnum index2))
+              (when (do ((index1 start1 (1+ index1))
+                         (index2 index2 (1+ index2)))
+                        ((>= index1 end1) t)
+                      (declare (type index index1 index2)
+                               (optimize (insert-array-bounds-checks 0)))
+                      ,@(unless from-end
+                          '((when (= index2 end2)
+                              (return-from search nil))))
+                      (unless (,@(if test?
+                                     `(funcall test)
+                                     `(eql))
+                               ,(case key?
+                                  (:yes `(funcall key (aref pattern index1)))
+                                  (:maybe `(let ((elt (aref pattern index1)))
+                                             (if key
+                                                 (funcall key elt)
+                                                 elt)))
+                                  (otherwise `(aref pattern index1)))
+                               ,(case key?
+                                  (:yes `(funcall key (aref text index2)))
+                                  (:maybe `(let ((elt (aref text index2)))
+                                             (if key
+                                                 (funcall key elt)
+                                                 elt)))
+                                  (otherwise `(aref text index2))))
+                        (return nil)))
+                (return index2)))))))))
 
 
 ;;; Open-code CONCATENATE for strings. It would be possible to extend

diff --git a/tests/seq.pure.lisp b/tests/seq.pure.lisp
index 2c1d638..3819f41 100644 (file)
--- a/tests/seq.pure.lisp
+++ b/tests/seq.pure.lisp
@@ -250,3 +250,44 @@
   ;; element is found before that's an issue.
   (assert (eq :foo (find :foo '(1 2 3 :foo) :start 1 :end 5)))
   (assert (= 3 (position :foo '(1 2 3 :foo) :start 1 :end 5))))
+
+(with-test (:name (:search :empty-seq))
+  (assert (eql 0
+               (funcall (compile nil
+                                 `(lambda (x)
+                                    (declare (optimize (speed 3)) (simple-vector x))
+                                    (search x #())))
+                        #())))
+  (assert (eql 0
+               (funcall (compile nil
+                                 `(lambda (x)
+                                    (declare (optimize (speed 3)) (simple-vector x))
+                                    (search x #(t t t))))
+                        #())))
+  (assert (eql 0
+               (funcall (compile nil
+                                 `(lambda (x)
+                                    (declare (optimize (speed 3)) (simple-vector x))
+                                    (search x #(t t t) :end1 0)))
+                        #(t t t))))
+  (assert (eql 0
+               (funcall (compile nil
+                                 `(lambda (x)
+                                    (declare (optimize (speed 3)) (simple-vector x))
+                                    (search x #(t t t) :key nil)))
+                        #())))
+  (assert (eql 0
+               (funcall (compile nil
+                                 `(lambda (x k)
+                                    (declare (optimize (speed 3)) (simple-vector x))
+                                    (search x #(t t t) :key k)))
+                        #() nil)))
+  (assert (eq :ok
+              (handler-case
+                  (funcall (compile nil
+                                    `(lambda (x)
+                                       (declare (optimize (speed 3)) (simple-vector x))
+                                       (search x #(t t t) :start2 1 :end2 0 :end1 0)))
+                           #(t t t))
+                (sb-kernel:bounding-indices-bad-error ()
+                  :ok)))))