basic CAS

1 files changed, 27 insertions, 1 deletions

diff --git a/values-lib.scm b/values-lib.scm
index 79e8d98..88ba4b4 100644
--- a/values-lib.scm
+++ b/values-lib.scm
@@ -31,8 +31,34 @@
 ;;; If any of the lists end, then ANY-VALUES returns no values.
 (define (any-values f . lists)
   (after ((when (not (null? lists)))
-          (when (all pair? lists)))
+          (when (every pair? lists)))
     (let-values ((returned (apply f (map car lists))))
       (if (null? returned)
           (apply any-values f (map cdr lists))
           (apply values returned)))))
+
+;;; REVMAP-VALUES is a tail-recursive version of MAP-VALUES that returns
+;;; (REVERSE (MAP-VALUES F . LISTS)).
+(define (revmap-values f . lists)
+  (if (or (null? lists)
+          (any null? lists))
+      '()
+      (let revmap-values ((collected (apply f (map car lists)))
+                          (lists (map cdr lists)))
+        (if (any null? lists)
+            collected
+            (let-values ((returned (apply f (map car lists))))
+              (revmap-values (map cons returned collected)
+                             (map cdr lists)))))))
+
+;;; (FOLD-VALUES F (LIST INIT-ARG ...) LIST ...)
+;;; does
+;;; (F (CAR LIST) ... INIT-ARG ...) => (NEW-ARG ...)
+;;; (F (CADR LIST) ... NEW-ARG ..) => (NEW-ARG2 ...)
+;;; and so on until at least one of LIST is NULL?.
+(define (fold-values f init-arguments . lists)
+  (if (any null? lists)
+      (apply values init-arguments)
+      (let-values ((returned (apply f (append (map car lists)
+                                              init-arguments))))
+        (apply fold-values f returned (map cdr lists)))))