Merge branch 'master' of github.com:davazp/jscl

# Please enter a commit message to explain why this merge is necessary,
# especially if it merges an updated upstream into a topic branch.
#
# Lines starting with '#' will be ignored, and an empty message aborts
# the commit.

diff --git a/src/sequence.lisp b/src/sequence.lisp
index cda0b41..8b3708b 100644 (file)
--- a/src/sequence.lisp
+++ b/src/sequence.lisp
@@ -179,3 +179,29 @@
 
 (defun copy-seq (sequence)
   (subseq sequence 0))
+
+
+;;; Reduce (based on SBCL's version)
+
+(defun reduce (function sequence &key key from-end (start 0) end (initial-value nil ivp))
+  (let ((key (or key #'identity))
+        (end (or end (length sequence))))
+    (if (= end start)
+        (if ivp initial-value (funcall function))
+        (macrolet ((reduce-list (function sequence key start end initial-value ivp from-end)
+                     `(let ((sequence
+                             ,(if from-end
+                                  `(reverse (nthcdr ,start ,sequence))
+                                  `(nthcdr ,start ,sequence))))
+                        (do ((count (if ,ivp ,start (1+ ,start))
+                                    (1+ count))
+                             (sequence (if ,ivp sequence (cdr sequence))
+                                       (cdr sequence))
+                             (value (if ,ivp ,initial-value (funcall ,key (car sequence)))
+                                    ,(if from-end
+                                         `(funcall ,function (funcall ,key (car sequence)) value)
+                                         `(funcall ,function value (funcall ,key (car sequence))))))
+                            ((>= count ,end) value)))))
+          (if from-end
+              (reduce-list function sequence key start end initial-value ivp t)
+              (reduce-list function sequence key start end initial-value ivp nil))))))

diff --git a/tests/seq.lisp b/tests/seq.lisp
index ce1c8d6..a780b1b 100644 (file)
--- a/tests/seq.lisp
+++ b/tests/seq.lisp
@@ -55,3 +55,25 @@
   (test (equal (subseq nums 2 4) '(3 4)))
   ; Test that nums hasn't been altered: SUBSEQ should construct fresh lists
   (test (equal nums '(1 2 3 4 5))))
+
+;;; REDUCE
+(test (equal (reduce (lambda (x y) `(+ ,x ,y))
+                     '(1 2 3 4))
+             '(+ (+ (+ 1 2) 3) 4)))
+
+(test (equal (reduce (lambda (x y) `(+ ,x ,y))
+                     '(1 2 3 4)
+                     :from-end t)
+             '(+ 1 (+ 2 (+ 3 4)))))
+
+(test (equal (reduce #'+ nil)  0))
+(test (equal (reduce #'+ '(1)) 1))
+(test (equal (reduce #'+ nil :initial-value 1) 1))
+
+(test (equal (reduce #'+ '()
+                     :key #'1+
+                     :initial-value 100)
+             100))
+
+(test (equal (reduce #'+ '(100) :key #'1+)
+             101))