~ chicken-core (chicken-5) 0fc30833918e25090f5e7da0911cf970f21a13a1

commit 0fc30833918e25090f5e7da0911cf970f21a13a1
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Jul 2 23:04:02 2011 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Sat Jul 2 23:04:02 2011 +0200

    added foldl and foldr

diff --git a/c-platform.scm b/c-platform.scm
index bd6f4605..6c76d94a 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -146,6 +146,7 @@
     block-ref block-set! number-of-slots substring-index substring-index-ci
     hash-table-ref any? read-string substring=? substring-ci=?
     first second third fourth make-record-instance
+    foldl foldr
     u8vector-length s8vector-length u16vector-length s16vector-length u32vector-length s32vector-length
     f32vector-length f64vector-length setter
     u8vector-ref s8vector-ref u16vector-ref s16vector-ref u32vector-ref s32vector-ref
diff --git a/chicken.import.scm b/chicken.import.scm
index 2a294282..f3a88efb 100644
--- a/chicken.import.scm
+++ b/chicken.import.scm
@@ -93,6 +93,8 @@
    flonum-radix
    flonum?
    flush-output
+   foldl
+   foldr
    force-finalizers
    fp-
    fp*
diff --git a/compiler-syntax.scm b/compiler-syntax.scm
index eec4f7e6..67a919e2 100644
--- a/compiler-syntax.scm
+++ b/compiler-syntax.scm
@@ -133,7 +133,7 @@
   (if (and (fx> (length x) 1)
 	   (memq 'o extended-bindings) ) ; s.a.
       (let ((%tmp (r 'tmp)))
-	`(,(r 'lambda) (,%tmp) ,(fold-right list %tmp (cdr x))))
+	`(,(r 'lambda) (,%tmp) ,(fold-right list %tmp (cdr x)))) ;XXX use foldr
       x))
 
 (define-internal-compiler-syntax ((sprintf #%sprintf format #%format) x r c)
@@ -253,3 +253,51 @@
 				      (fail #t "illegal format-string character `~c'" dchar) ) ) )
 			       (loop '()) )
 			     (loop (cons c chunk)))))))))))))
+
+(define-internal-compiler-syntax ((foldr #%foldr) x r c)
+  (pair?)
+  (if (and (fx= (length x) 4)
+	   (memq 'foldr extended-bindings) ) ; s.a.
+      (let ((f (cadr x))
+	    (z (caddr x))
+	    (lst (cadddr x))
+	    (%let* (r 'let*))
+	    (%let (r 'let))
+	    (%pair? (r 'pair?))
+	    (%if (r 'if))
+	    (loopvar (gensym "foldr"))
+	    (lstvar (gensym)))
+	`(,%let* ((,lstvar ,lst))
+		 (##core#check (##sys#check-list ,lstvar (##core#quote foldr)))
+		 (,%let ,loopvar ((,lstvar ,lstvar))
+			(,%if (,%pair? ,lstvar)
+			      (,f (##sys#slot ,lstvar 0) 
+				     (##core#app ,loopvar (##sys#slot ,lstvar 1)))
+			      ,z))))
+      x))
+
+(define-internal-compiler-syntax ((foldl #%foldl) x r c) 
+  (pair?)
+  (if (and (fx= (length x) 4)
+	   (memq 'foldl extended-bindings) ) ; s.a.
+      (let ((f (cadr x))
+	    (z (caddr x))
+	    (lst (cadddr x))
+	    (%let* (r 'let*))
+	    (%let (r 'let))
+	    (%if (r 'if))
+	    (%pair? (r 'pair?))
+	    (zvar (gensym))
+	    (loopvar (gensym "foldl"))
+	    (lstvar (gensym)))
+	`(,%let* ((,zvar ,z)
+		  (,lstvar ,lst))
+		 (##core#check (##sys#check-list ,lstvar (##core#quote foldl)))
+		 (,%let ,loopvar ((,lstvar ,lstvar) (,zvar ,zvar))
+			(,%if (,%pair? ,lstvar)
+			      (##core#app 
+			       ,loopvar
+			       (##sys#slot ,lstvar 1) 
+			       (,f ,zvar (##sys#slot ,lstvar 0)))
+			      ,zvar))))
+      x))
diff --git a/library.scm b/library.scm
index 4e8a538f..c6ed34b7 100644
--- a/library.scm
+++ b/library.scm
@@ -4874,3 +4874,20 @@ EOF
 
 (define ##sys#dump-heap-state (##core#primitive "C_dump_heap_state"))
 (define ##sys#filter-heap-objects (##core#primitive "C_filter_heap_objects"))
+
+
+;;; fast folds with correct argument order
+
+(define (foldl f z lst)
+  (##sys#check-list lst 'foldl)
+  (let loop ((lst lst) (z z))
+    (if (not (pair? lst))
+	z
+	(loop (##sys#slot lst 1) (f z (##sys#slot lst 0))))))
+
+(define (foldr f z lst)
+  (##sys#check-list lst 'foldr)
+  (let loop ((lst lst))
+    (if (not (pair? lst))
+	z
+	(f (##sys#slot lst 0) (loop (##sys#slot lst 1))))))
diff --git a/manual/Unit library b/manual/Unit library
index fd4158e0..b200fff3 100644
--- a/manual/Unit library	
+++ b/manual/Unit library	
@@ -913,6 +913,33 @@ Returns {{#t}} if the two argument blobs are of the same
 size and have the same content.
 
 
+=== Lists
+
+==== foldl
+
+<procedure>(foldl PROCEDURE INIT LIST)</procedure>
+
+Applies {{PROCEDURE}} to the elements from {{LIST}}, beginning from the left:
+
+<enscript hightlight=scheme>
+(foldl + 0 '(1 2 3))    ==>    (+ (+ (+ 0 1) 2) 3)
+</enscript>
+
+Note that the order of arguments taken by {{PROCEDURE}} is different
+from the {{SRFI-1}} {{fold}} procedure, but matches the more intuitive
+order used in Haskell.
+
+
+==== foldr
+
+<procedure>(foldr PROCEDURE INIT LIST)</procedure>
+
+Applies {{PROCEDURE}} to the elements from {{LIST}}, beginning from the right:
+
+<enscript hightlight=scheme>
+(foldr + 0 '(1 2 3))    ==>    (+ 1 (+ 2 (+ 3 0)))
+</enscript>
+
 
 === Vectors
 
diff --git a/manual/faq b/manual/faq
index ca26480d..b471871b 100644
--- a/manual/faq
+++ b/manual/faq
@@ -473,6 +473,7 @@ The following extended bindings are handled specially:
 {{cpu-time}} {{error}} {{call/cc}} {{any?}}
 {{substring=?}} {{substring-ci=?}} {{substring-index}} {{substring-index-ci}}
 {{printf}} {{sprintf}} {{fprintf}} {{format}} {{o}}
+{{foldl}} {{foldr}}
 
 ==== What's the difference betweem "block" and "local" mode?