[PATCH] Add implementation of SRFI 45

[Andreas Rottmann <a.rottmann@gmx.at>]

[-- Attachment #1: srfi-45.patch --]
[-- Type: text/x-diff, Size: 21177 bytes --]

From: Andreas Rottmann <a.rottmann@gmx.at>
Subject: Add implementation of SRFI 45
    
* module/srfi/srfi-45.scm: New file, containing the reference implementation of
  SRFI 45, slightly adapted to use SRFI-9.
* module/Makefile.am (SRFI_SOURCES): Added srfi/srfi-45.scm.

* test-suite/tests/srfi-45.test: New file.
* test-suite/Makefile.am (SCM_TESTS): Add tests/srfi-45.test.

* doc/ref/srfi-modules.texi (SRFI-45): New node and subsection;
  essentially a shortended transcript of the SRFI-45 specification.

---
 NEWS                          |    1 +
 doc/ref/srfi-modules.texi     |  144 +++++++++++++++++++++++
 module/Makefile.am            |    1 +
 module/srfi/srfi-45.scm       |   78 ++++++++++++
 test-suite/Makefile.am        |    1 +
 test-suite/tests/srfi-45.test |  260 +++++++++++++++++++++++++++++++++++++++++
 6 files changed, 485 insertions(+), 0 deletions(-)

diff --git a/NEWS b/NEWS
index 5e9fd03..d05d39c 100644
--- a/NEWS
+++ b/NEWS
@@ -17,6 +17,7 @@ The following SRFIs have been added:
 
 - SRFI-27 "Sources of Random Bits"
 - SRFI-42 "Eager Comprehensions"
+- SRFI-45 "Primitives for Expressing Iterative Lazy Algorithms"
 
 ** Many R6RS bugfixes
 
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 2ca971e..238484c 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -44,6 +44,7 @@ get the relevant SRFI documents from the SRFI home page
 * SRFI-37::                     args-fold program argument processor
 * SRFI-39::                     Parameter objects
 * SRFI-42::                     Eager comprehensions
+* SRFI-45::                     Primitives for expressing iterative lazy algorithms
 * SRFI-55::                     Requiring Features.
 * SRFI-60::                     Integers as bits.
 * SRFI-61::                     A more general `cond' clause
@@ -3875,6 +3876,149 @@ as Guile-specific.
 See @uref{http://srfi.schemers.org/srfi-42/srfi-42.html, the
 specification of SRFI-42}.
 
+@node SRFI-45
+@subsection SRFI-45 - Primitives for Expressing Iterative Lazy Algorithms
+@cindex SRFI-45
+
+This subsection is based on @uref{http://srfi.schemers.org/srfi-45/srfi-45.html, the
+specification of SRFI-45} written by Andr@'e van Tonder.
+
+@c Copyright (C) André van Tonder (2003). All Rights Reserved.
+
+@c Permission is hereby granted, free of charge, to any person obtaining a
+@c copy of this software and associated documentation files (the
+@c "Software"), to deal in the Software without restriction, including
+@c without limitation the rights to use, copy, modify, merge, publish,
+@c distribute, sublicense, and/or sell copies of the Software, and to
+@c permit persons to whom the Software is furnished to do so, subject to
+@c the following conditions:
+
+@c The above copyright notice and this permission notice shall be included
+@c in all copies or substantial portions of the Software.
+
+@c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+@c OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+@c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+@c NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+@c LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+@c OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+@c WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+Lazy evaluation is traditionally simulated in Scheme using @code{delay}
+and @code{force}.  However, these primitives are not powerful enough to
+express a large class of lazy algorithms that are iterative.  Indeed, it
+is folklore in the Scheme community that typical iterative lazy
+algorithms written using delay and force will often require unbounded
+memory.
+
+This SRFI provides set of three operations: @{@code{lazy}, @code{delay},
+@code{force}@}, which allow the programmer to succinctly express lazy
+algorithms while retaining bounded space behavior in cases that are
+properly tail-recursive.  A general recipe for using these primitives is
+provided. An additional procedure @code{eager} is provided for the
+construction of eager promises in cases where efficiency is a concern.
+
+Although this SRFI redefines @code{delay} and @code{force}, the
+extension is conservative in the sense that the semantics of the subset
+@{@code{delay}, @code{force}@} in isolation (i.e., as long as the
+program does not use @code{lazy}) agrees with that in R5RS.  In other
+words, no program that uses the R5RS definitions of delay and force will
+break if those definition are replaced by the SRFI-45 definitions of
+delay and force.
+
+@deffn {Scheme Syntax} delay expression
+Takes an expression of arbitrary type @var{a} and returns a promise of
+type @code{(Promise @var{a})} which at some point in the future may be
+asked (by the @code{force} procedure) to evaluate the expression and
+deliver the resulting value.
+@end deffn
+
+@deffn {Scheme Syntax} lazy expression
+Takes an expression of type @code{(Promise @var{a})} and returns a
+promise of type @code{(Promise @var{a})} which at some point in the
+future may be asked (by the @code{force} procedure) to evaluate the
+expression and deliver the resulting promise.
+@end deffn
+
+@deffn {Scheme Procedure} force expression
+Takes an argument of type @code{(Promise @var{a})} and returns a value
+of type @var{a} as follows: If a value of type @var{a} has been computed
+for the promise, this value is returned.  Otherwise, the promise is
+first evaluated, then overwritten by the obtained promise or value, and
+then force is again applied (iteratively) to the promise.
+@end deffn
+
+@deffn {Scheme Procedure} eager expression
+Takes an argument of type @var{a} and returns a value of type
+@code{(Promise @var{a})}.  As opposed to @code{delay}, the argument is
+evaluated eagerly. Semantically, writing @code{(eager expression)} is
+equivalent to writing
+
+@lisp
+(let ((value expression)) (delay value)).
+@end lisp
+
+However, the former is more efficient since it does not require
+unnecessary creation and evaluation of thunks. We also have the
+equivalence
+
+@lisp
+(delay expression) = (lazy (eager expression))
+@end lisp
+@end deffn
+
+The following reduction rules may be helpful for reasoning about these
+primitives.  However, they do not express the memoization and memory
+usage semantics specified above:
+
+@lisp
+(force (delay expression)) -> expression
+(force (lazy  expression)) -> (force expression)
+(force (eager value))      -> value
+@end lisp
+
+@subsubheading Correct usage
+
+We now provide a general recipe for using the primitives @{@code{lazy},
+@code{delay}, @code{force}@} to express lazy algorithms in Scheme.  The
+transformation is best described by way of an example: Consider the
+stream-filter algorithm, expressed in a hypothetical lazy language as
+
+@lisp
+(define (stream-filter p? s)
+  (if (null? s) '()
+      (let ((h (car s))
+            (t (cdr s)))
+        (if (p? h)
+            (cons h (stream-filter p? t))
+            (stream-filter p? t)))))
+@end lisp
+
+This algorithm can be espressed as follows in Scheme:
+
+@lisp
+(define (stream-filter p? s)
+  (lazy
+     (if (null? (force s)) (delay '())
+         (let ((h (car (force s)))
+               (t (cdr (force s))))
+           (if (p? h)
+               (delay (cons h (stream-filter p? t)))
+               (stream-filter p? t))))))
+@end lisp
+
+In other words, we
+
+@itemize @bullet
+@item
+wrap all constructors (e.g., @code{'()}, @code{cons}) with @code{delay},
+@item 
+apply @code{force} to arguments of deconstructors (e.g., @code{car},
+@code{cdr} and @code{null?}),
+@item
+wrap procedure bodies with @code{(lazy ...)}.
+@end itemize
+
 @node SRFI-55
 @subsection SRFI-55 - Requiring Features
 @cindex SRFI-55
diff --git a/module/Makefile.am b/module/Makefile.am
index 8062d5a..9aa4c7a 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -255,6 +255,7 @@ SRFI_SOURCES = \
   srfi/srfi-37.scm \
   srfi/srfi-42.scm \
   srfi/srfi-39.scm \
+  srfi/srfi-45.scm \
   srfi/srfi-60.scm \
   srfi/srfi-67.scm \
   srfi/srfi-69.scm \
diff --git a/module/srfi/srfi-45.scm b/module/srfi/srfi-45.scm
new file mode 100644
index 0000000..1b912be
--- /dev/null
+++ b/module/srfi/srfi-45.scm
@@ -0,0 +1,78 @@
+;;; srfi-45.scm -- Primitives for Expressing Iterative Lazy Algorithms
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2003 André van Tonder. All Rights Reserved.
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+;;; Commentary:
+
+;; This is the code of the reference implementation of SRFI-45, slightly
+;; modified to use SRFI-9.
+
+;; This module is documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-45)
+  #:export (delay
+             lazy
+             force
+             eager)
+  #:replace (delay force)
+  #:use-module (srfi srfi-9))
+
+(define-record-type promise (make-promise val) promise?
+  (val promise-val promise-val-set!))
+
+(define-record-type value (make-value tag proc) value?
+  (tag value-tag value-tag-set!)
+  (proc value-proc value-proc-set!))
+
+(define-syntax lazy
+  (syntax-rules ()
+    ((lazy exp)
+     (make-promise (make-value 'lazy (lambda () exp))))))
+
+(define (eager x)
+  (make-promise (make-value 'eager x)))
+
+(define-syntax delay
+  (syntax-rules ()
+    ((delay exp) (lazy (eager exp)))))
+
+(define (force promise)
+  (let ((content (promise-val promise)))
+    (case (value-tag content)
+      ((eager) (value-proc content))
+      ((lazy)  (let* ((promise* ((value-proc content)))
+                      (content  (promise-val promise)))        ; *
+                 (if (not (eqv? (value-tag content) 'eager))   ; *
+                     (begin (value-tag-set! content
+                                            (value-tag (promise-val promise*)))
+                            (value-proc-set! content
+                                             (value-proc (promise-val promise*)))
+                            (promise-val-set! promise* content)))
+                 (force promise))))))
+
+;; (*) These two lines re-fetch and check the original promise in case
+;;     the first line of the let* caused it to be forced.  For an example
+;;     where this happens, see reentrancy test 3 below.
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 71094e4..70e49b2 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -120,6 +120,7 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/srfi-37.test			\
 	    tests/srfi-39.test			\
 	    tests/srfi-42.test			\
+	    tests/srfi-45.test			\
 	    tests/srfi-60.test			\
 	    tests/srfi-67.test			\
 	    tests/srfi-69.test			\
diff --git a/test-suite/tests/srfi-45.test b/test-suite/tests/srfi-45.test
new file mode 100644
index 0000000..573eea0
--- /dev/null
+++ b/test-suite/tests/srfi-45.test
@@ -0,0 +1,260 @@
+;;; -*- mode: scheme; coding: utf-8; -*-
+
+;; Copyright André van Tonder. All Rights Reserved.
+;;
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+;; Modified by Andreas Rottmann for Guile.
+
+(define-module (test-srfi-45)
+  #:use-module (test-suite lib)
+  #:use-module (srfi srfi-45))
+
+(define-syntax test-output
+  (syntax-rules ()
+    ((_ expected proc)
+     (let ((output (call-with-output-string proc)))
+       (pass-if (equal? expected output))))))
+
+(define-syntax test-equal
+  (syntax-rules ()
+    ((_ expected expr)
+     (pass-if (equal? expected expr)))))
+
+(define test-leaks? #f)
+
+(define-syntax test-leak
+  (syntax-rules ()
+    ((_ expr)
+     (cond (test-leaks?
+            (display "Leak test, please watch memory consumption;")
+            (display "  press C-c when satisfied.\n")
+            (call/cc
+              (lambda (k)
+                (sigaction SIGINT (lambda (signal) (k #t)))
+                expr)))))))
+
+;=========================================================================
+; TESTS AND BENCHMARKS:
+;=========================================================================
+
+;=========================================================================
+; Memoization test 1:
+
+(test-output "hello"
+  (lambda (port)
+    (define s (delay (begin (display 'hello port) 1)))
+    (test-equal 1 (force s))
+    (test-equal 1 (force s))))
+
+;=========================================================================
+; Memoization test 2:
+
+(test-output "bonjour"
+  (lambda (port)
+    (let ((s (delay (begin (display 'bonjour port) 2))))
+      (test-equal 4 (+ (force s) (force s))))))
+
+;=========================================================================
+; Memoization test 3: (pointed out by Alejandro Forero Cuervo) 
+
+(test-output "hi"
+  (lambda (port)
+    (define r (delay (begin (display 'hi port) 1)))
+    (define s (lazy r))
+    (define t (lazy s))
+    (test-equal 1 (force t))
+    (test-equal 1 (force r))))
+
+;=========================================================================
+; Memoization test 4: Stream memoization
+
+(define (stream-drop s index)
+  (lazy
+   (if (zero? index)
+       s
+       (stream-drop (cdr (force s)) (- index 1)))))
+
+(define (ones port)
+  (delay (begin
+           (display 'ho port)
+           (cons 1 (ones port)))))
+
+(test-output "hohohohoho"
+  (lambda (port)
+    (define s (ones port))
+    (test-equal 1
+                (car (force (stream-drop s 4))))
+    (test-equal 1
+                (car (force (stream-drop s 4))))))
+
+;=========================================================================
+; Reentrancy test 1: from R5RS
+
+(letrec ((count 0)
+         (p (delay (begin (set! count (+ count 1))
+                          (if (> count x)
+                              count
+                              (force p)))))
+         (x 5))
+  (test-equal 6 (force p))
+  (set! x 10)
+  (test-equal 6 (force p)))
+
+;=========================================================================
+; Reentrancy test 2: from SRFI 40
+
+(letrec ((f (let ((first? #t))
+              (delay
+                (if first?
+                    (begin
+                      (set! first? #f)
+                      (force f))
+                    'second)))))
+  (test-equal 'second (force f)))
+
+;=========================================================================
+; Reentrancy test 3: due to John Shutt
+
+(let* ((q (let ((count 5))
+            (define (get-count) count)
+            (define p (delay (if (<= count 0)
+                                 count
+                                 (begin (set! count (- count 1))
+                                        (force p)
+                                        (set! count (+ count 2))
+                                        count))))
+            (list get-count p)))
+       (get-count (car q))
+       (p (cadr q)))
+
+  (test-equal 5 (get-count))
+  (test-equal 0 (force p))
+  (test-equal 10 (get-count)))
+
+;=========================================================================
+; Test leaks:  All the leak tests should run in bounded space.
+
+;=========================================================================
+; Leak test 1: Infinite loop in bounded space.
+
+(define (loop) (lazy (loop)))
+(test-leak (force (loop)))   ;==> bounded space
+
+;=========================================================================
+; Leak test 2: Pending memos should not accumulate
+;              in shared structures.
+
+(let ()
+  (define s (loop))
+  (test-leak (force s)))     ;==> bounded space
+
+;=========================================================================
+; Leak test 3: Safely traversing infinite stream.
+
+(define (from n)
+  (delay (cons n (from (+ n 1)))))
+
+(define (traverse s)
+  (lazy (traverse (cdr (force s)))))
+
+(test-leak (force (traverse (from 0))))         ;==> bounded space
+
+;=========================================================================
+; Leak test 4: Safely traversing infinite stream
+;              while pointer to head of result exists.
+
+(let ()
+  (define s (traverse (from 0)))
+  (test-leak (force s)))     ;==> bounded space
+
+;=========================================================================
+; Convenient list deconstructor used below.
+
+(define-syntax match
+  (syntax-rules ()
+    ((match exp
+       (()      exp1)
+       ((h . t) exp2))
+     (let ((lst exp))
+       (cond ((null? lst) exp1)
+             ((pair? lst) (let ((h (car lst))
+                                (t (cdr lst)))
+                            exp2))
+             (else 'match-error))))))
+
+;========================================================================
+; Leak test 5: Naive stream-filter should run in bounded space.
+;              Simplest case.
+
+(define (stream-filter p? s)
+  (lazy (match (force s)
+          (()      (delay '()))
+          ((h . t) (if (p? h)
+                       (delay (cons h (stream-filter p? t)))
+                       (stream-filter p? t))))))
+
+(test-leak
+ (force (stream-filter (lambda (n) (= n 10000000000))
+                       (from 0))))                     ;==> bounded space
+
+;========================================================================
+; Leak test 6: Another long traversal should run in bounded space.
+
+; The stream-ref procedure below does not strictly need to be lazy.
+; It is defined lazy for the purpose of testing safe compostion of
+; lazy procedures in the times3 benchmark below (previous
+; candidate solutions had failed this).
+
+(define (stream-ref s index)
+  (lazy
+   (match (force s)
+     (()      'error)
+     ((h . t) (if (zero? index)
+                  (delay h)
+                  (stream-ref t (- index 1)))))))
+
+; Check that evenness is correctly implemented - should terminate:
+
+(test-equal 0
+  (force (stream-ref (stream-filter zero? (from 0))
+                     0)))
+
+;; Commented out since it takes too long
+#;
+(let ()
+  (define s (stream-ref (from 0) 100000000))
+  (test-equal 100000000 (force s)))     ;==> bounded space
+
+;======================================================================
+; Leak test 7: Infamous example from SRFI 40.
+
+(define (times3 n)
+  (stream-ref (stream-filter
+               (lambda (x) (zero? (modulo x n)))
+               (from 0))
+              3))
+
+(test-equal 21 (force (times3 7)))
+
+;; Commented out since it takes too long
+#;
+(test-equal 300000000 (force (times3 100000000)))    ;==> bounded space
-- 
tg: (5ad3881..) t/srfi-45 (depends on: master)

[-- Attachment #2: Type: text/plain, Size: 63 bytes --]


Regards, Rotty
-- 
Andreas Rottmann -- <http://rotty.yi.org/>