Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24550

Modified Files: sequences.lisp Log Message: Fix a rather nasty bug in reduce when :end nil was specified for a vector sequence: The length never got computed and the vector would be accessed out of bounds (and so cause all sorts of strange effects).

--- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/03/21 20:20:33 1.35 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/04/07 07:59:31 1.36 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld frodef@acm.org ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.35 2007/03/21 20:20:33 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.36 2007/04/07 07:59:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -124,57 +124,75 @@ ((= index end) result) (declare (index index))))))))))) (t (function sequence &key (key 'identity) from-end - (start 0) (end (length sequence)) + (start 0) end (initial-value nil initial-value-p)) (let ((start (check-the index start))) (with-funcallable (funcall-function function) (with-funcallable (key) - (case (- end start) - (0 (if initial-value-p - initial-value - (funcall-function))) - (1 (if initial-value-p - (funcall-function initial-value (key (elt sequence start))) - (key (elt sequence start)))) - (t (sequence-dispatch sequence - (list - (cond - ((not from-end) - (do* ((counter (1+ start) (1+ counter)) - (list (nthcdr start sequence)) - (result (funcall-function (if initial-value-p - initial-value - (key (pop list))) - (key (pop list))) - (funcall-function result (key (pop list))))) - ((or (null list) - (= end counter)) - result) - (declare (index counter)))) - (from-end - (do* ((counter (1+ start) (1+ counter)) - (list (nreverse (subseq sequence start end))) - (result (funcall-function (key (pop list)) - (if initial-value-p - initial-value - (key (pop list)))) - (funcall-function (key (pop list)) result))) - ((or (null list) - (= end counter)) - result) - (declare (index counter)))))) - (vector - (when from-end - (error "REDUCE from-end on vectors is not implemented.")) - (with-subvector-accessor (sequence-ref sequence start end) - (do* ((index start) - (result (funcall-function (if initial-value-p - initial-value - (key (sequence-ref (prog1 index (incf index))))) - (key (sequence-ref (prog1 index (incf index))))) - (funcall-function result (sequence-ref (prog1 index (incf index)))))) - ((= index end) result) - (declare (index index)))))))))))))) + (sequence-dispatch sequence + (list + (let ((list (nthcdr start sequence))) + (cond + ((null list) + (if initial-value-p + initial-value + (funcall-function))) + ((null (cdr list)) + (if initial-value-p + (funcall-function initial-value (key (car list))) + (key (car list)))) + ((not from-end) + (if (not end) + (do ((result (funcall-function (if initial-value-p + initial-value + (key (pop list))) + (key (pop list))) + (funcall-function result (key (pop list))))) + ((null list) result)) + (do ((counter (1+ start) (1+ counter)) + (result (funcall-function (if initial-value-p + initial-value + (key (pop list))) + (key (pop list))) + (funcall-function result (key (pop list))))) + ((or (null list) + (= end counter)) + result) + (declare (index counter))))) + (from-end + (do* ((end (or end (+ start (length list)))) + (counter (1+ start) (1+ counter)) + (list (nreverse (subseq sequence start end))) + (result (funcall-function (key (pop list)) + (if initial-value-p + initial-value + (key (pop list)))) + (funcall-function (key (pop list)) result))) + ((or (null list) + (= end counter)) + result) + (declare (index counter))))))) + (vector + (when from-end + (error "REDUCE from-end on vectors is not implemented.")) + (let ((end (or (check-the index end) + (length sequence)))) + (case (- end start) + (0 (if initial-value-p + initial-value + (funcall-function))) + (1 (if initial-value-p + (funcall-function initial-value (key (elt sequence start))) + (key (elt sequence start)))) + (t (with-subvector-accessor (sequence-ref sequence start end) + (do* ((index start) + (result (funcall-function (if initial-value-p + initial-value + (key (sequence-ref (prog1 index (incf index))))) + (key (sequence-ref (prog1 index (incf index))))) + (funcall-function result (sequence-ref (prog1 index (incf index)))))) + ((= index end) result) + (declare (index index)))))))))))))))

(defun subseq (sequence start &optional end) (sequence-dispatch sequence @@ -1569,6 +1587,25 @@ (right (1- end)) left-item right-item) (declare (index left right)) + ;; do median-of-three.. + (let ((p1 (vector-ref start)) + (p2 (vector-ref (+ start cut-off -1))) + (p3 (vector-ref (1- end)))) + (let ((kp1 (key p1)) + (kp2 (key p2)) + (kp3 (key p3))) + (cond + ((predicate p1 p2) + (if (predicate p2 p3) + (setf pivot p2 keyed-pivot kp2) + (if (predicate p1 p3) + (setf pivot p3 keyed-pivot kp3) + (setf pivot p1 keyed-pivot kp1)))) + ((predicate p2 p3) + (if (predicate p1 p3) + (setf pivot p1 keyed-pivot kp1) + (setf pivot p3 keyed-pivot kp3))) + (t (setf pivot p2 keyed-pivot kp2))))) partitioning-loop (do-while (not (predicate keyed-pivot (key (setf left-item (vector-ref left))))) (incf left) @@ -1586,8 +1623,10 @@ partitioning-complete (setf (vector-ref start) right-item ; (aref vector right) (vector-ref right) pivot) - (quick-sort vector predicate key start right cut-off) - (quick-sort vector predicate key (1+ right) end cut-off)))))))) + (when (and (> cut-off (- right start)) + (> cut-off (- end right))) + (quick-sort vector predicate key start right cut-off) + (quick-sort vector predicate key (1+ right) end cut-off))))))))) vector)

(defun sort (sequence predicate &key (key 'identity))