Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv25634
Modified Files: sequences.lisp Log Message: Fix nsubstitute-if for :from-end t. Previously it could spin eternally.
--- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/04/07 07:59:31 1.36 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/04/07 20:14:45 1.37 @@ -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.36 2007/04/07 07:59:31 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.37 2007/04/07 20:14:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------
@@ -1886,90 +1886,97 @@
(defun nsubstitute-if (newitem predicate sequence &key (start 0) end count (key 'identity) from-end) "=> sequence" - (with-funcallable (predicate) - (with-funcallable (key) - (sequence-dispatch sequence - (vector - (let ((end (or end (length sequence)))) - (with-subvector-accessor (ref sequence start end) - (cond - ((and (not count) (not from-end)) - (do ((i start (1+ i))) - ((>= i end) sequence) - (declare (index i)) - (when (predicate (key (ref i))) - (setf (ref i) newitem)))) - ((and count (not from-end)) - (do ((c 0) - (i start (1+ i))) - ((>= i end) sequence) - (declare (index i c)) - (when (predicate (key (ref i))) - (setf (ref i) newitem) - (when (>= (incf c) count) - (return sequence))))) - ((and (not count) from-end) - (do ((i (1- end) (1- i))) - ((< i start) sequence) - (declare (index i)) - (when (predicate (key (ref i))) - (setf (ref i) newitem)))) - ((and count from-end) - (do ((c 0) - (i (1- end) (1- i))) - ((< i start) sequence) - (declare (index c i)) - (when (predicate (key (ref i))) - (setf (ref i) newitem) - (when (>= (incf c) count) - (return sequence))))) - ((error 'program-error)))))) - (list - (let ((p (nthcdr start sequence))) - (if (and from-end count) - (let* ((end (and end (- end start))) - (existing-count (count-if predicate p :key key :end end))) - (do ((i count)) - ((>= i existing-count) - (nsubstitute-if newitem predicate p :end end :key key) - sequence) - (declare (index i)) - (when (predicate (key (car p))) - (incf i)) - (setf p (cdr p)))) - (cond - ((and (not end) (not count)) - (do ((p p (cdr p))) - ((endp p) sequence) - (when (predicate (key (car p))) - (setf (car p) newitem)))) - ((and end (not count)) - (do ((i start (1+ i)) - (p p (cdr p))) - ((or (endp p) (>= i end)) sequence) - (declare (index i)) - (when (predicate (key (car p))) - (setf (car p) newitem)))) - ((and (not end) count) - (do ((c 0) - (p p (cdr p))) - ((endp p) sequence) - (declare (index c)) - (when (predicate (key (car p))) - (setf (car p) newitem) - (when (>= (incf c) count) - (return sequence))))) - ((and end count) - (do ((c 0) - (i start (1+ i)) - (p p (cdr p))) - ((or (endp p) (>= i end)) sequence) - (declare (index c i)) - (when (predicate (key (car p))) - (setf (car p) newitem) - (when (>= (incf c) count) - (return sequence))))) - ((error 'program-error)))))))))) + (if (<= count 0) + sequence + (with-funcallable (predicate) + (with-funcallable (key) + (sequence-dispatch sequence + (vector + (let ((end (or end (length sequence)))) + (with-subvector-accessor (ref sequence start end) + (cond + ((and (not count) (not from-end)) + (do ((i start (1+ i))) + ((>= i end) sequence) + (declare (index i)) + (when (predicate (key (ref i))) + (setf (ref i) newitem)))) + ((and count (not from-end)) + (do ((c 0) + (i start (1+ i))) + ((>= i end) sequence) + (declare (index i c)) + (when (predicate (key (ref i))) + (setf (ref i) newitem) + (when (>= (incf c) count) + (return sequence))))) + ((and (not count) from-end) + (do ((i (1- end) (1- i))) + ((< i start) sequence) + (declare (index i)) + (when (predicate (key (ref i))) + (setf (ref i) newitem)))) + ((and count from-end) + (do ((c 0) + (i (1- end) (1- i))) + ((< i start) sequence) + (declare (index c i)) + (when (predicate (key (ref i))) + (setf (ref i) newitem) + (when (>= (incf c) count) + (return sequence))))) + ((error 'program-error)))))) + (list + (let ((p (nthcdr start sequence))) + (cond + (from-end + (nreverse (nsubstitute-if newitem predicate (nreverse sequence) + :start (if (not end) 0 (- (length sequence) end)) + :end (if (plusp start) nil (- (length sequence) start)) + :count count :key key))) + #+ignore ((and from-end count) + (let* ((end (and end (- end start))) + (existing-count (count-if predicate p :key key :end end))) + (do ((i count)) + ((>= i existing-count) + (nsubstitute-if newitem predicate p :end end :key key) + sequence) + (declare (index i)) + (when (predicate (key (car p))) + (incf i)) + (setf p (cdr p))))) + ((and (not end) (not count)) + (do ((p p (cdr p))) + ((endp p) sequence) + (when (predicate (key (car p))) + (setf (car p) newitem)))) + ((and end (not count)) + (do ((i start (1+ i)) + (p p (cdr p))) + ((or (endp p) (>= i end)) sequence) + (declare (index i)) + (when (predicate (key (car p))) + (setf (car p) newitem)))) + ((and (not end) count) + (do ((c 0) + (p p (cdr p))) + ((endp p) sequence) + (declare (index c)) + (when (predicate (key (car p))) + (setf (car p) newitem) + (when (>= (incf c) count) + (return sequence))))) + ((and end count) + (do ((c 0) + (i start (1+ i)) + (p p (cdr p))) + ((or (endp p) (>= i end)) sequence) + (declare (index c i)) + (when (predicate (key (car p))) + (setf (car p) newitem) + (when (>= (incf c) count) + (return sequence))))) + ((error 'program-error))))))))))
(defun nsubstitute-if-not (newitem predicate sequence &rest keyargs) (declare (dynamic-extent keyargs))