diff --git a/contrib/20.r7rs/scheme/lazy.scm b/contrib/20.r7rs/scheme/lazy.scm index 7378c384..88a4739f 100644 --- a/contrib/20.r7rs/scheme/lazy.scm +++ b/contrib/20.r7rs/scheme/lazy.scm @@ -6,32 +6,52 @@ (define-record-type (make-promise% done value) - promise? - (done promise-done? set-promise-done!) - (value promise-value set-promise-value!)) + promise?% + (done promise-done?% set-promise-done!%) + (value promise-value% set-promise-value!%)) + (define (box x) (list x)) + (define box? list?) + (define unbox car) + (define set-box! set-car!) + + (define (promise? x) + (promise?% (unbox x))) + (define (promise-done? x) + (promise-done?% (unbox x))) + (define (set-promise-done! boxed x) + (set-promise-done!% (unbox boxed) x)) + (define (promise-value x) + (promise-value% (unbox x))) + (define (set-promise-value! boxed x) + (set-promise-value!% (unbox boxed) x)) + + (define (make-promise%% done value) + (box (make-promise% done value))) + (define-syntax delay-force (syntax-rules () ((_ expr) - (make-promise% #f (lambda () expr))))) + (make-promise%% #f (lambda () expr))))) (define-syntax delay (syntax-rules () ((_ expr) - (delay-force (make-promise% #t expr))))) + (delay-force (make-promise%% #t expr))))) (define (force promise) (if (promise-done? promise) (promise-value promise) (let ((new-promise ((promise-value promise)))) - (set-promise-done! promise (promise-done? new-promise)) - (set-promise-value! promise (promise-value new-promise)) - (force promise)))) + (set-promise-done! promise (promise-done? new-promise)) + (set-promise-value! promise (promise-value new-promise)) + (set-box! new-promise (unbox promise)) + (force promise)))) (define (make-promise obj) - (if (promise? obj) + (if (and (box? obj) (promise? obj)) obj - (make-promise% #t obj))) + (make-promise%% #t obj))) (export delay-force delay diff --git a/contrib/20.r7rs/t/r7rs.scm b/contrib/20.r7rs/t/r7rs.scm index f329d781..483e7625 100644 --- a/contrib/20.r7rs/t/r7rs.scm +++ b/contrib/20.r7rs/t/r7rs.scm @@ -363,7 +363,14 @@ (force x) (promise? x))) - +(let () + (define x 0) + (define np (delay (begin + (set! x (+ x 1)) + (if (= x 1) 'ok 'ng)))) + (define op (delay-force np)) + (force op) + (test 'ok (force np))) (define radix