[movitz-cvs] CVS movitz/losp/muerte
ffjeld
ffjeld at common-lisp.net
Sat Apr 7 20:14:46 UTC 2007
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 at 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))
More information about the Movitz-cvs
mailing list