Fix SEQUENCE:SEARCH, test seq. functions with user-defined sequences

Extending the tests in tests/seq.impure.lisp to user-defined sequences
revealed that the previous implementation produced incorrect results
for some inputs.

SEQUENCE:WITH-SEQUENCE-ITERATOR now accepts NIL in the list of
variables and generates ignored bindings for these elements.

The new implementation is also slightly faster (at least for the
inputs in tests/seq.impure.lisp).

fixes lp#1153312

diff --git a/NEWS b/NEWS
index 27bca79..f7ef9d8 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -22,6 +22,9 @@ changes relative to sbcl-1.1.5:
   * bug fix: compiling make-array no longer signals an error when the
     element-type is an uknown type, a warning is issued instead.
     Thanks to James Kalenius (lp#1156095)
   * bug fix: compiling make-array no longer signals an error when the
     element-type is an uknown type, a warning is issued instead.
     Thanks to James Kalenius (lp#1156095)

+  * bug fix: SEARCH on generic (non-VECTOR non-LIST) sequence types no longer
+    produces wrong results for some inputs.  (Thanks to Jan Moringen.)
+    (lp#1153312)

 
 changes in sbcl-1.1.5 relative to sbcl-1.1.4:
   * minor incompatible change: SB-SPROF:WITH-PROFILING no longer loops
 
 changes in sbcl-1.1.5 relative to sbcl-1.1.4:
   * minor incompatible change: SB-SPROF:WITH-PROFILING no longer loops

diff --git a/src/pcl/sequence.lisp b/src/pcl/sequence.lisp
index 295cc71..7dc5904 100644 (file)
--- a/src/pcl/sequence.lisp
+++ b/src/pcl/sequence.lisp
@@ -198,9 +198,16 @@
 (defmacro sequence:with-sequence-iterator
     ((&rest vars) (s &rest args &key from-end start end) &body body)
   (declare (ignore from-end start end))
 (defmacro sequence:with-sequence-iterator
     ((&rest vars) (s &rest args &key from-end start end) &body body)
   (declare (ignore from-end start end))

-  `(multiple-value-bind (,@vars) (sequence:make-sequence-iterator ,s ,@args)
-    (declare (type function ,@(nthcdr 3 vars)))
-    ,@body))
+  (let* ((ignored '())
+         (vars (mapcar (lambda (x)
+                         (or x (let ((name (gensym)))
+                                 (push name ignored)
+                                 name)))
+                       vars)))
+   `(multiple-value-bind (,@vars) (sequence:make-sequence-iterator ,s ,@args)
+      (declare (type function ,@(nthcdr 3 vars))
+               (ignore ,@ignored))
+      ,@body)))

 
 (defmacro sequence:with-sequence-iterator-functions
     ((step endp elt setf index copy)
 
 (defmacro sequence:with-sequence-iterator-functions
     ((step endp elt setf index copy)

@@ -625,33 +632,40 @@
 (defmethod sequence:search
     ((sequence1 sequence) (sequence2 sequence) &key from-end (start1 0) end1
      (start2 0) end2 test test-not key)
 (defmethod sequence:search
     ((sequence1 sequence) (sequence2 sequence) &key from-end (start1 0) end1
      (start2 0) end2 test test-not key)

-  (let ((test (sequence:canonize-test test test-not))
-        (key (sequence:canonize-key key))
-        (mainend2 (- (or end2 (length sequence2))
-                     (- (or end1 (length sequence1)) start1))))
-    (when (< mainend2 0)
+  (let* ((test (sequence:canonize-test test test-not))
+         (key (sequence:canonize-key key))
+         (range1 (- (or end1 (length sequence1)) start1))
+         (range2 (- (or end2 (length sequence2)) start2))
+         (count (1+ (- range2 range1))))
+    (when (minusp count)

       (return-from sequence:search nil))
       (return-from sequence:search nil))

-    (sequence:with-sequence-iterator (statem limitm from-endm stepm endpm)
-        (sequence2 :start start2 :end mainend2 :from-end from-end)
-      (do ((s2 (if from-end mainend2 0) (if from-end (1- s2) (1+ s2))))
-          (nil)
-        (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1)
-            (sequence1 :start start1 :end end1)
-          (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
-              (sequence2 :start s2)
-            (declare (ignore limit2 endp2))
-            (when (do ()
-                      ((funcall endp1 sequence1 state1 limit1 from-end1) t)
-                    (let ((o1 (funcall key (funcall elt1 sequence1 state1)))
-                          (o2 (funcall key (funcall elt2 sequence2 state2))))
-                      (unless (funcall test o1 o2)
-                        (return nil)))
-                    (setq state1 (funcall step1 sequence1 state1 from-end1))
-                    (setq state2 (funcall step2 sequence2 state2 from-end2)))
-              (return-from sequence:search s2))))
-        (when (funcall endpm sequence2 statem limitm from-endm)
-          (return nil))
-        (setq statem (funcall stepm sequence2 statem from-endm))))))
+    ;; Create an iteration state for SEQUENCE1 for the interesting
+    ;;range within SEQUENCE1. To compare this range against ranges in
+    ;;SEQUENCE2, we copy START-STATE1 and then mutate the copy.
+    (sequence:with-sequence-iterator (start-state1 nil from-end1 step1 nil elt1)
+        (sequence1 :start start1 :end end1 :from-end from-end)
+      ;; Create an iteration state for the interesting range within
+      ;; SEQUENCE2.
+      (sequence:with-sequence-iterator (start-state2 nil from-end2 step2 nil elt2 nil index2)
+          (sequence2 :start start2 :end end2 :from-end from-end)
+        ;; Copy both iterators at all COUNT possible match positions.
+        (dotimes (i count)
+          (let ((state1 (sequence:iterator-copy sequence1 start-state1))
+                (state2 (sequence:iterator-copy sequence2 start-state2)))
+            ;; Determine whether there is a match at the current
+            ;; position. Return immediately, if there is a match.
+            (dotimes
+                (j range1
+                   (return-from sequence:search
+                     (let ((position (funcall index2 sequence2 start-state2)))
+                       (if from-end (- position range1 -1) position))))
+              (unless (funcall test
+                               (funcall key (funcall elt1 sequence1 state1))
+                               (funcall key (funcall elt2 sequence2 state2)))
+                (return nil))
+              (setq state1 (funcall step1 sequence1 state1 from-end1))
+              (setq state2 (funcall step2 sequence2 state2 from-end2))))
+          (setq start-state2 (funcall step2 sequence2 start-state2 from-end2)))))))

 
 (defgeneric sequence:delete
     (item sequence &key from-end test test-not start end count key)
 
 (defgeneric sequence:delete
     (item sequence &key from-end test test-not start end count key)

diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp
index 2df75d1..e497115 100644 (file)
--- a/tests/seq.impure.lisp
+++ b/tests/seq.impure.lisp
@@ -21,58 +21,82 @@
 
 (in-package :seq-test)
 
 
 (in-package :seq-test)
 

+(defclass list-backed-sequence (standard-object
+                                sequence)
+  ((elements :initarg :elements :type list :accessor %elements)))
+
+(defmethod sequence:make-sequence-like ((sequence list-backed-sequence) length
+                                        &rest args &key
+                                        initial-element initial-contents)
+  (declare (ignore initial-element initial-contents))
+  (make-instance 'list-backed-sequence
+                 :elements (apply #'sequence:make-sequence-like
+                                  '() length args)))
+
+(defmethod sequence:length ((sequence list-backed-sequence))
+  (length (%elements sequence)))
+
+(defmethod sequence:elt
+    ((sequence list-backed-sequence) index)
+  (nth index (%elements sequence)))
+
+(defmethod (setf sequence:elt)
+    (new-value (sequence list-backed-sequence) index)
+  (setf (nth index (%elements sequence)) new-value))
+

 ;;; helper functions for exercising SEQUENCE code on data of many
 ;;; specialized types, and in many different optimization scenarios
 (defun for-every-seq-1 (base-seq snippet)
 ;;; helper functions for exercising SEQUENCE code on data of many
 ;;; specialized types, and in many different optimization scenarios
 (defun for-every-seq-1 (base-seq snippet)

-  (dolist (seq-type '(list
-                      (simple-array t 1)
-                      (vector t)
-                      (simple-array character 1)
-                      (vector character)
-                      (simple-array (signed-byte 4) 1)
-                      (vector (signed-byte 4))))
-    (flet ((entirely (eltype)
-             (every (lambda (el) (typep el eltype)) base-seq)))
+  (labels
+      ((entirely (eltype)
+         (every (lambda (el) (typep el eltype)) base-seq))
+       (make-sequence-for-type (type)
+         (etypecase type
+           ((member list list-backed-sequence)
+            (coerce base-seq type))
+           ((cons (eql simple-array) (cons * (cons (eql 1) null)))
+            (destructuring-bind (eltype one) (rest type)
+              (when (entirely eltype)
+                (coerce base-seq type))))
+           ((cons (eql vector))
+            (destructuring-bind (eltype) (rest type)
+              (when (entirely eltype)
+                (let ((initial-element
+                        (cond ((subtypep eltype 'character)
+                               #\!)
+                              ((subtypep eltype 'number)
+                               0)
+                                (t #'error))))
+                  (replace (make-array
+                            (+ (length base-seq)
+                               (random 3))
+                            :element-type eltype
+                            :fill-pointer
+                            (length base-seq)
+                            :initial-element
+                            initial-element)
+                           base-seq))))))))
+    (dolist (seq-type '(list
+                        (simple-array t 1)
+                        (vector t)
+                        (simple-array character 1)
+                        (vector character)
+                        (simple-array (signed-byte 4) 1)
+                        (vector (signed-byte 4))
+                        list-backed-sequence))

       (dolist (declaredness '(nil t))
         (dolist (optimization '(((speed 3) (space 0))
                                 ((speed 2) (space 2))
                                 ((speed 1) (space 2))
                                 ((speed 0) (space 1))))
       (dolist (declaredness '(nil t))
         (dolist (optimization '(((speed 3) (space 0))
                                 ((speed 2) (space 2))
                                 ((speed 1) (space 2))
                                 ((speed 0) (space 1))))

-          (let* ((seq (if (eq seq-type 'list)
-                          (coerce base-seq 'list)
-                          (destructuring-bind (type-first &rest type-rest)
-                              seq-type
-                            (ecase type-first
-                              (simple-array
-                               (destructuring-bind (eltype one) type-rest
-                                 (assert (= one 1))
-                                 (if (entirely eltype)
-                                     (coerce base-seq seq-type)
-                                     (return))))
-                              (vector
-                               (destructuring-bind (eltype) type-rest
-                                 (if (entirely eltype)
-                                     (let ((initial-element
-                                            (cond ((subtypep eltype 'character)
-                                                   #\!)
-                                                  ((subtypep eltype 'number)
-                                                   0)
-                                                  (t #'error))))
-                                       (replace (make-array
-                                                 (+ (length base-seq)
-                                                    (random 3))
-                                                 :element-type eltype
-                                                 :fill-pointer
-                                                 (length base-seq)
-                                                 :initial-element
-                                                 initial-element)
-                                                base-seq))
-                                     (return))))))))
-                 (lambda-expr `(lambda (seq)
-                                 ,@(when declaredness
-                                     `((declare (type ,seq-type seq))))
-                                 (declare (optimize ,@optimization))
-                                 ,snippet)))
+          (let ((seq (make-sequence-for-type seq-type))
+                (lambda-expr `(lambda (seq)
+                                ,@(when declaredness
+                                    `((declare (type ,seq-type seq))))
+                                (declare (optimize ,@optimization))
+                                ,snippet)))
+            (when (not seq)
+              (return))

             (format t "~&~S~%" lambda-expr)
             (multiple-value-bind (fun warnings-p failure-p)
                 (compile nil lambda-expr)
             (format t "~&~S~%" lambda-expr)
             (multiple-value-bind (fun warnings-p failure-p)
                 (compile nil lambda-expr)