From: Jan Moringen Date: Sun, 10 Mar 2013 15:28:55 +0000 (+0100) Subject: Fix SEQUENCE:SEARCH, test seq. functions with user-defined sequences X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=363c1e9417029fd9a27257d5e872eca8c88510b7;p=sbcl.git 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 --- 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: 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 diff --git a/src/pcl/sequence.lisp b/src/pcl/sequence.lisp index 295cc71..7dc5904 100644 --- 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)) - `(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) @@ -625,33 +632,40 @@ (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)) - (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) diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp index 2df75d1..e497115 100644 --- a/tests/seq.impure.lisp +++ b/tests/seq.impure.lisp @@ -21,58 +21,82 @@ (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) - (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)))) - (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)