Skip to content
Snippets Groups Projects
Commit 3629f30f authored by ram's avatar ram
Browse files

Added :KEY argument to REDUCE.

Fixed SUBSTITUTE & friends to pass arguments to the TEST in the right order.
Fixed SUBSTITUTE not to randomly apply the KEY to the OLD value.
Changed LIST NSUBSTITUTE & friends to work in the :FROM-END case.
parent 59d3c553
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.9 1991/08/13 13:59:31 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.10 1991/10/01 16:12:59 ram Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -700,47 +700,50 @@ ...@@ -700,47 +700,50 @@
(eval-when (compile eval) (eval-when (compile eval)
(defmacro mumble-reduce (function sequence start end initial-value ref) (defmacro mumble-reduce (function sequence key start end initial-value ref)
`(do ((index ,start (1+ index)) `(do ((index ,start (1+ index))
(value ,initial-value)) (value ,initial-value))
((= index (the fixnum ,end)) value) ((= index (the fixnum ,end)) value)
(declare (fixnum index)) (declare (fixnum index))
(setq value (funcall ,function value (,ref ,sequence index))))) (setq value (funcall ,function value
(apply-key ,key (,ref ,sequence index))))))
(defmacro mumble-reduce-from-end (function sequence start end initial-value ref) (defmacro mumble-reduce-from-end (function sequence key start end initial-value ref)
`(do ((index (1- ,end) (1- index)) `(do ((index (1- ,end) (1- index))
(value ,initial-value) (value ,initial-value)
(terminus (1- ,start))) (terminus (1- ,start)))
((= index terminus) value) ((= index terminus) value)
(declare (fixnum index terminus)) (declare (fixnum index terminus))
(setq value (funcall ,function (,ref ,sequence index) value)))) (setq value (funcall ,function
(apply-key ,key (,ref ,sequence index))
value))))
(defmacro list-reduce (function sequence start end initial-value ivp) (defmacro list-reduce (function sequence key start end initial-value ivp)
`(let ((sequence (nthcdr ,start ,sequence))) `(let ((sequence (nthcdr ,start ,sequence)))
(do ((count (if ,ivp ,start (1+ (the fixnum ,start))) (do ((count (if ,ivp ,start (1+ (the fixnum ,start)))
(1+ count)) (1+ count))
(sequence (if ,ivp sequence (cdr sequence)) (sequence (if ,ivp sequence (cdr sequence))
(cdr sequence)) (cdr sequence))
(value (if ,ivp ,initial-value (car sequence)) (value (if ,ivp ,initial-value (apply-key ,key (car sequence)))
(funcall ,function value (car sequence)))) (funcall ,function value (apply-key ,key (car sequence)))))
((= count (the fixnum ,end)) value) ((= count (the fixnum ,end)) value)
(declare (fixnum count))))) (declare (fixnum count)))))
(defmacro list-reduce-from-end (function sequence start end initial-value ivp) (defmacro list-reduce-from-end (function sequence key start end initial-value ivp)
`(let ((sequence (nthcdr (- (the fixnum (length ,sequence)) (the fixnum ,end)) `(let ((sequence (nthcdr (- (the fixnum (length ,sequence)) (the fixnum ,end))
(reverse ,sequence)))) (reverse ,sequence))))
(do ((count (if ,ivp ,start (1+ (the fixnum ,start))) (do ((count (if ,ivp ,start (1+ (the fixnum ,start)))
(1+ count)) (1+ count))
(sequence (if ,ivp sequence (cdr sequence)) (sequence (if ,ivp sequence (cdr sequence))
(cdr sequence)) (cdr sequence))
(value (if ,ivp ,initial-value (car sequence)) (value (if ,ivp ,initial-value (apply-key ,key (car sequence)))
(funcall ,function (car sequence) value))) (funcall ,function (apply-key ,key (car sequence)) value)))
((= count (the fixnum ,end)) value) ((= count (the fixnum ,end)) value)
(declare (fixnum count))))) (declare (fixnum count)))))
) )
(defun reduce (function sequence &key from-end (start 0) (defun reduce (function sequence &key key from-end (start 0)
end (initial-value nil ivp)) end (initial-value nil ivp))
"The specified Sequence is ``reduced'' using the given Function. "The specified Sequence is ``reduced'' using the given Function.
See manual for details." See manual for details."
...@@ -750,18 +753,20 @@ ...@@ -750,18 +753,20 @@
(if ivp initial-value (funcall function))) (if ivp initial-value (funcall function)))
((listp sequence) ((listp sequence)
(if from-end (if from-end
(list-reduce-from-end function sequence start end initial-value ivp) (list-reduce-from-end function sequence key start end
(list-reduce function sequence start end initial-value ivp))) initial-value ivp)
(list-reduce function sequence key start end initial-value ivp)))
(from-end (from-end
(when (not ivp) (when (not ivp)
(setq end (1- (the fixnum end))) (setq end (1- (the fixnum end)))
(setq initial-value (aref sequence end))) (setq initial-value (apply-key key (aref sequence end))))
(mumble-reduce-from-end function sequence start end initial-value aref)) (mumble-reduce-from-end function sequence key start end
initial-value aref))
(t (t
(when (not ivp) (when (not ivp)
(setq initial-value (aref sequence start)) (setq initial-value (apply-key key (aref sequence start)))
(setq start (1+ start))) (setq start (1+ start)))
(mumble-reduce function sequence start end initial-value aref)))) (mumble-reduce function sequence key start end initial-value aref))))
;;; Coerce: ;;; Coerce:
...@@ -1461,8 +1466,8 @@ ...@@ -1461,8 +1466,8 @@
(normal (normal
(if test-not (if test-not
(not (not
(funcall test-not (apply-key key elt) old)) (funcall test-not old (apply-key key elt)))
(funcall test (apply-key key elt) old))) (funcall test old (apply-key key elt))))
(if (funcall test (apply-key key elt))) (if (funcall test (apply-key key elt)))
(if-not (not (funcall test (apply-key key elt))))) (if-not (not (funcall test (apply-key key elt)))))
(setq count (1- count)) (setq count (1- count))
...@@ -1494,8 +1499,8 @@ ...@@ -1494,8 +1499,8 @@
(cond ((case pred (cond ((case pred
(normal (normal
(if test-not (if test-not
(not (funcall test-not (apply-key key elt) old)) (not (funcall test-not old (apply-key key elt)))
(funcall test (apply-key key elt) old))) (funcall test old (apply-key key elt))))
(if (funcall test (apply-key key elt))) (if (funcall test (apply-key key elt)))
(if-not (not (funcall test (apply-key key elt))))) (if-not (not (funcall test (apply-key key elt)))))
(setq count (1- count)) (setq count (1- count))
...@@ -1540,8 +1545,7 @@ ...@@ -1540,8 +1545,7 @@
for details." for details."
(declare (fixnum start count)) (declare (fixnum start count))
(when (null end) (setf end (length sequence))) (when (null end) (setf end (length sequence)))
(let ((length (length sequence)) (let ((length (length sequence)))
(old (apply-key key old)))
(declare (fixnum length)) (declare (fixnum length))
(subst-dispatch 'normal))) (subst-dispatch 'normal)))
...@@ -1588,21 +1592,18 @@ ...@@ -1588,21 +1592,18 @@
may be destroyed. See manual for details." may be destroyed. See manual for details."
(declare (fixnum count start)) (declare (fixnum count start))
(when (null end) (setf end (length sequence))) (when (null end) (setf end (length sequence)))
(let ((incrementer 1)) (if (listp sequence)
(declare (fixnum incrementer)) (if from-end
(if from-end (nreverse (nlist-substitute*
(psetq start (1- end) new old (nreverse (the list sequence))
end (1- start) test test-not start end count key))
incrementer -1)) (nlist-substitute* new old sequence
(if (listp sequence) test test-not start end count key))
(if from-end (if from-end
(nreverse (nlist-substitute* (nvector-substitute* new old sequence -1
new old (nreverse (the list sequence)) test test-not (1- end) (1- start) count key)
test test-not start end count key)) (nvector-substitute* new old sequence 1
(nlist-substitute* new old sequence test test-not start end count key))))
test test-not start end count key))
(nvector-substitute* new old sequence incrementer
test test-not start end count key))))
(defun nlist-substitute* (new old sequence test test-not start end count key) (defun nlist-substitute* (new old sequence test test-not start end count key)
(declare (fixnum start count end)) (declare (fixnum start count end))
...@@ -1611,8 +1612,8 @@ ...@@ -1611,8 +1612,8 @@
((or (= index end) (null list) (= count 0)) sequence) ((or (= index end) (null list) (= count 0)) sequence)
(declare (fixnum index)) (declare (fixnum index))
(when (if test-not (when (if test-not
(not (funcall test-not (apply-key key (car list)) old)) (not (funcall test-not old (apply-key key (car list))))
(funcall test (apply-key key (car list)) old)) (funcall test old (apply-key key (car list))))
(rplaca list new) (rplaca list new)
(setq count (1- count))))) (setq count (1- count)))))
...@@ -1623,8 +1624,8 @@ ...@@ -1623,8 +1624,8 @@
((or (= index end) (= count 0)) sequence) ((or (= index end) (= count 0)) sequence)
(declare (fixnum index)) (declare (fixnum index))
(when (if test-not (when (if test-not
(not (funcall test-not (apply-key key (aref sequence index)) old)) (not (funcall test-not old (apply-key key (aref sequence index))))
(funcall test (apply-key key (aref sequence index)) old)) (funcall test old (apply-key key (aref sequence index))))
(setf (aref sequence index) new) (setf (aref sequence index) new)
(setq count (1- count))))) (setq count (1- count)))))
...@@ -1632,18 +1633,13 @@ ...@@ -1632,18 +1633,13 @@
;;; NSubstitute-If: ;;; NSubstitute-If:
(defun nsubstitute-if (new test sequence &key from-end (start 0) (defun nsubstitute-if (new test sequence &key from-end (start 0)
end (count most-positive-fixnum) key) end (count most-positive-fixnum) key)
"Returns a sequence of the same kind as Sequence with the same elements "Returns a sequence of the same kind as Sequence with the same elements
except that all elements satisfying the Test are replaced with New. The except that all elements satisfying the Test are replaced with New. The
Sequence may be destroyed. See manual for details." Sequence may be destroyed. See manual for details."
(declare (fixnum start count)) (declare (fixnum start count))
(let ((incrementer 1) (let ((end (or end (length sequence))))
(end (or end (length sequence)))) (declare (fixnum end))
(declare (fixnum incrementer end))
(if from-end
(psetq start (1- end)
end (1- start)
incrementer -1))
(if (listp sequence) (if (listp sequence)
(if from-end (if from-end
(nreverse (nlist-substitute-if* (nreverse (nlist-substitute-if*
...@@ -1651,8 +1647,11 @@ ...@@ -1651,8 +1647,11 @@
start end count key)) start end count key))
(nlist-substitute-if* new test sequence (nlist-substitute-if* new test sequence
start end count key)) start end count key))
(nvector-substitute-if* new test sequence incrementer (if from-end
start end count key)))) (nvector-substitute-if* new test sequence -1
(1- end) (1- start) count key)
(nvector-substitute-if* new test sequence 1
start end count key)))))
(defun nlist-substitute-if* (new test sequence start end count key) (defun nlist-substitute-if* (new test sequence start end count key)
(declare (fixnum end)) (declare (fixnum end))
...@@ -1675,27 +1674,25 @@ ...@@ -1675,27 +1674,25 @@
;;; NSubstitute-If-Not: ;;; NSubstitute-If-Not:
(defun nsubstitute-if-not (new test sequence &key from-end (start 0) (defun nsubstitute-if-not (new test sequence &key from-end (start 0)
end (count most-positive-fixnum) key) end (count most-positive-fixnum) key)
"Returns a sequence of the same kind as Sequence with the same elements "Returns a sequence of the same kind as Sequence with the same elements
except that all elements not satisfying the Test are replaced with New. except that all elements not satisfying the Test are replaced with New.
The Sequence may be destroyed. See manual for details." The Sequence may be destroyed. See manual for details."
(declare (fixnum start count)) (declare (fixnum start count))
(let ((end (or end (length sequence)))) (let ((end (or end (length sequence))))
(declare (fixnum end)) (declare (fixnum end))
(let ((incrementer 1)) (if (listp sequence)
(if from-end (if from-end
(psetq start (1- end) (nreverse (nlist-substitute-if-not*
end (1- start) new test (nreverse (the list sequence))
incrementer -1)) start end count key))
(if (listp sequence) (nlist-substitute-if-not* new test sequence
(if from-end start end count key))
(nreverse (nlist-substitute-if-not* (if from-end
new test (nreverse (the list sequence)) (nvector-substitute-if-not* new test sequence -1
start end count key)) (1- end) (1- start) count key)
(nlist-substitute-if-not* new test sequence (nvector-substitute-if-not* new test sequence 1
start end count key)) start end count key)))))
(nvector-substitute-if-not* new test sequence incrementer
start end count key)))))
(defun nlist-substitute-if-not* (new test sequence start end count key) (defun nlist-substitute-if-not* (new test sequence start end count key)
(declare (fixnum end)) (declare (fixnum end))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment