~ chicken-core (chicken-5) 58bc37692fff883dd735ec320087885aca5da603
commit 58bc37692fff883dd735ec320087885aca5da603
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Wed Oct 30 20:43:10 2013 +1300
Commit: Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sun Nov 3 12:33:41 2013 +0100
R7RS delay/force/delay-force
Implement R7RS's lazy semantics, specifically the space-safe
tail-recursive forcing via delay-force, and a set of tests (mostly taken
from SRFI 45).
Also make promise a single-slot record type, whose value is dispatched
on by type when forcing (since it can now be a procedure, the resulting
values, or (in the case of iterative forcing) another promise).
Signed-off-by: Peter Bex <peter.bex@xs4all.nl>
diff --git a/distribution/manifest b/distribution/manifest
index c16826ed..32da5357 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -121,6 +121,7 @@ tests/runbench.sh
tests/srfi-4-tests.scm
tests/srfi-13-tests.scm
tests/srfi-14-tests.scm
+tests/srfi-45-tests.scm
tests/simple-thread-test.scm
tests/mutex-test.scm
tests/hash-table-tests.scm
diff --git a/expand.scm b/expand.scm
index 2f34df36..5838bcf4 100644
--- a/expand.scm
+++ b/expand.scm
@@ -1316,6 +1316,16 @@
(##sys#er-transformer
(lambda (form r c)
(##sys#check-syntax 'delay form '(_ _))
+ `(,(r 'delay-force)
+ (##sys#make-promise
+ (##sys#call-with-values (##core#lambda () ,(cadr form)) ##sys#list))))))
+
+(##sys#extend-macro-environment
+ 'delay-force
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'delay-force form '(_ _))
`(##sys#make-promise (##core#lambda () ,(cadr form))))))
(##sys#extend-macro-environment
diff --git a/library.scm b/library.scm
index d95724ac..364b4778 100644
--- a/library.scm
+++ b/library.scm
@@ -334,17 +334,29 @@ EOF
(##core#inline "C_i_check_closure_2" x (car loc))
(##core#inline "C_i_check_closure" x) ) )
-(define (##sys#force promise)
- (if (##sys#structure? promise 'promise)
- (apply ##sys#values
- (or (##sys#slot promise 2)
- (let ((results (##sys#call-with-values (##sys#slot promise 1) (lambda xs xs))))
- (or (##sys#slot promise 2)
- (begin
- (##sys#setslot promise 1 #f)
- (##sys#setslot promise 2 results)
- results)))))
- promise))
+(define (##sys#force obj)
+ (if (##sys#structure? obj 'promise)
+ (let lp ((promise obj)
+ (forward #f))
+ (let ((val (##sys#slot promise 1)))
+ (cond ((null? val) (##sys#values))
+ ((pair? val) (apply ##sys#values val))
+ ((procedure? val)
+ (when forward (##sys#setslot forward 1 promise))
+ (let ((results (##sys#call-with-values val ##sys#list)))
+ (cond ((not (procedure? (##sys#slot promise 1)))
+ (lp promise forward)) ; in case of reentrance
+ ((and (not (null? results)) (null? (cdr results))
+ (##sys#structure? (##sys#slot results 0) 'promise))
+ (let ((result0 (##sys#slot results 0)))
+ (##sys#setslot promise 1 (##sys#slot result0 1))
+ (lp promise result0)))
+ (else
+ (##sys#setslot promise 1 results)
+ (apply ##sys#values results)))))
+ ((##sys#structure? val 'promise)
+ (lp val forward)))))
+ obj))
(define force ##sys#force)
@@ -4823,7 +4835,7 @@ EOF
;;; Promises:
(define (##sys#make-promise proc)
- (##sys#make-structure 'promise proc #f))
+ (##sys#make-structure 'promise proc))
(define (promise? x)
(##sys#structure? x 'promise) )
diff --git a/manual/Non-standard macros and special forms b/manual/Non-standard macros and special forms
index 728ce3b0..23f69dd9 100644
--- a/manual/Non-standard macros and special forms
+++ b/manual/Non-standard macros and special forms
@@ -539,6 +539,14 @@ In addition the following feature-identifiers may exist: {{cross-chicken}},
For further information, see the documentation for
[[http://srfi.schemers.org/srfi-0/srfi-0.html|SRFI-0]].
+=== {{delay-force}}
+
+CHICKEN supports the R7RS {{delay-force}} syntax which allows for
+iterative lazy algorithms to be expressed in bounded space.
+
+For more information regarding this behaviour, see the
+[[http://srfi.schemers.org/srfi-45/srfi-45.html|SRFI-45]] rationale.
+
==== ensure
<macro>(ensure PREDICATE EXP [ARGUMENTS ...])</macro>
diff --git a/manual/The R5RS standard b/manual/The R5RS standard
index 753c70a3..3ca3b73e 100644
--- a/manual/The R5RS standard
+++ b/manual/The R5RS standard
@@ -507,14 +507,42 @@ execution of <body> may be repeated by invoking the procedure named by
<macro>(delay <expression>)</macro><br>
The delay construct is used together with the procedure force to
-implement lazy evaluation or call by need. (delay <expression>) returns
-an object called a promise which at some point in the future may be
-asked (by the force procedure) to evaluate <expression>, and deliver
-the resulting value. The effect of <expression> returning multiple
-values is unspecified.
+implement lazy evaluation or call by need. {{(delay <expression>)}}
+returns an object called a promise which at some point in the future
+may be asked (by the force procedure) to evaluate {{<expression>}},
+and deliver the resulting value. The {{<expression>}} may return
+multiple values, which will be correctly memoized and returned by
+subsequent calls to {{force}}. This is a CHICKEN extension to R5RS.
+
+See the description of {{force}} (section 6.4) for a more complete
+description of {{delay}}.
+
+<macro>(delay-force <expression>)</macro><br>
+
+The expression {{(delay-force expression)}} is conceptually similar to
+{{(delay (force expression))}}, with the difference that forcing the
+result of {{delay-force}} will in effect result in a tail call to
+{{(force expression)}}, while forcing the result of
+{{(delay (force expression))}} might not.
+
+Thus iterative lazy algorithms that might result in a long series of
+chains of delay and force can be rewritten using delay-force to
+prevent consuming unbounded space during evaluation.
+
+The {{delay-force}} macro is a CHICKEN extension to R5RS, taken from
+R7RS.
See the description of force (section 6.4) for a more complete
-description of delay.
+description of delayed evaluation.
+
+<procedure>(make-promise obj)</procedure>
+
+The make-promise procedure returns a promise which, when forced, will
+return {{obj}} . It is similar to {{delay}}, but does not delay its
+argument: it is a procedure rather than syntax. If {{obj}} is already
+a promise, it is returned.
+
+This procedure is a CHICKEN extension to R5RS, taken from R7RS.
==== Quasiquotation
diff --git a/tests/r7rs-tests.scm b/tests/r7rs-tests.scm
index f47eacd5..670e9593 100644
--- a/tests/r7rs-tests.scm
+++ b/tests/r7rs-tests.scm
@@ -77,7 +77,60 @@
(test #t procedure? (force (make-promise (lambda _ 1))))
(test 1 force (make-promise (make-promise 1)))
-
+;; delay/force/delay-force
+(test #t promise? (delay 1))
+(test #t promise? (delay (delay 1)))
+(test 1 force 1)
+(test force force (force (delay force)))
+
+(test 3 force (delay (+ 1 2))) ; pp. 18
+(let ((p (delay (+ 1 2))))
+ (test '(3 3) list (force p) (force p)))
+
+(let () ; pp. 19
+ (define integers
+ (letrec ((next
+ (lambda (n)
+ (delay (cons n (next (+ n 1)))))))
+ (next 0)))
+ (define head
+ (lambda (stream) (car (force stream))))
+ (define tail
+ (lambda (stream) (cdr (force stream))))
+ (test 0 head integers)
+ (test 0 head integers)
+ (test 1 head (tail integers))
+ (test 2 head (tail (tail integers))))
+
+(let () ; later on pp. 19
+ (define count 0)
+ (define p
+ (delay (begin (set! count (+ count 1))
+ (if (> count x)
+ count
+ (force p)))))
+ (define x 5)
+ (test #t promise? p)
+ (test 6 force p)
+ (test #t promise? p)
+ (set! x 10)
+ (test 6 force p))
+
+(test #t promise? (delay-force 1))
+(test 1 force (delay-force 1))
+(test 6 force (delay-force (+ 1 2 3)))
+(test #t promise? (delay-force (delay 1)))
+
+;; delayed MVs
+(call-with-values
+ (lambda () (force (delay (values 1 2 3))))
+ (lambda mv (test '(1 2 3) #f mv)))
+(call-with-values
+ (lambda () (force (delay-force (values 4 5 6))))
+ (lambda mv (test '(4 5 6) #f mv)))
+(call-with-values
+ (lambda () (force (delay (values))))
+ (lambda mv (test '() #f mv)))
(SECTION 6 6)
diff --git a/tests/runtests.bat b/tests/runtests.bat
index 2bdecf54..c503f153 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -382,6 +382,10 @@ echo ======================================== path tests ...
%interpret% -bnq path-tests.scm
if errorlevel 1 exit /b 1
+echo ======================================== srfi-45 tests ...
+%interpret% -s srfi-45-tests.scm
+if errorlevel 1 exit /b 1
+
echo ======================================== posix tests ...
%compile% posix-tests.scm
if errorlevel 1 exit /b 1
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 43dd3922..16e4bc26 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -335,6 +335,9 @@ $interpret -s data-structures-tests.scm
echo "======================================== path tests ..."
$interpret -bnq path-tests.scm
+echo "======================================== srfi-45 tests ..."
+$interpret -s srfi-45-tests.scm
+
echo "======================================== posix tests ..."
$compile posix-tests.scm
./a.out
diff --git a/tests/srfi-45-tests.scm b/tests/srfi-45-tests.scm
new file mode 100644
index 00000000..1950fd39
--- /dev/null
+++ b/tests/srfi-45-tests.scm
@@ -0,0 +1,93 @@
+;;; Tests adapted from SRFI 45 (for "lazy" -> "delay-force").
+;;; That SRFI Copyright (C) André van Tonder (2003).
+
+(use (only ports with-output-to-string))
+
+(define *errors* 0)
+
+(define-syntax test
+ (syntax-rules ()
+ ((_ name expect form)
+ (let ((ok (equal? expect form)))
+ (printf "(~a) ~a~n" (if ok "PASS" "FAIL") name)
+ (when (not ok) (set! *errors* (add1 *errors*)))))))
+
+(define-syntax output
+ (syntax-rules ()
+ ((_ . body) (with-output-to-string (lambda () . body)))))
+
+(test "Memoization test 1"
+ "hello"
+ (output (define s (delay (begin (display 'hello) 1)))
+ (force s)
+ (force s)))
+
+(test "Memoization test 2"
+ "bonjour"
+ (output (let ((s (delay (begin (display 'bonjour) 2))))
+ (+ (force s) (force s)))))
+
+(test "Memoization test 3"
+ "hi"
+ (output (define r (delay (begin (display 'hi) 1)))
+ (define s (delay-force r))
+ (define t (delay-force s))
+ (force t)
+ (force r)))
+
+(test "Memoization test 4"
+ "hohohohoho"
+ (output (define (stream-drop s index)
+ (delay-force
+ (if (zero? index)
+ s
+ (stream-drop (cdr (force s)) (- index 1)))))
+ (define (ones)
+ (delay (begin
+ (display 'ho)
+ (cons 1 (ones)))))
+ (define s (ones))
+ (car (force (stream-drop s 4)))
+ (car (force (stream-drop s 4)))))
+
+(let ()
+ (define count 0)
+ (define p
+ (delay (begin (set! count (+ count 1))
+ (if (> count x)
+ count
+ (force p)))))
+ (define x 5)
+ (test "Reentrancy test 1 (1)" 6 (force p))
+ (set! x 10)
+ (test "Reentrancy test 1 (2)" 6 (force p)))
+
+(let ()
+ (define f
+ (let ((first? #t))
+ (delay
+ (if first?
+ (begin
+ (set! first? #f)
+ (force f))
+ 'second))))
+ (test "Reentrancy test 2" 'second (force f)))
+
+(let ()
+ (define 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)))
+ (define get-count (car q))
+ (define p (cadr q))
+ (test "Reentrancy test 3 (1)" 5 (get-count))
+ (test "Reentrancy test 3 (2)" 0 (force p))
+ (test "Reentrancy test 3 (3)" 10 (get-count)))
+
+(exit *errors*)
Trap