diff --git a/contrib/20.r7rs/scheme/lazy.scm b/contrib/20.r7rs/scheme/lazy.scm index 0df49444..d934ad45 100644 --- a/contrib/20.r7rs/scheme/lazy.scm +++ b/contrib/20.r7rs/scheme/lazy.scm @@ -1,40 +1,45 @@ ;;; Appendix A. Standard Libraries Lazy (define-library (scheme lazy) - (import (scheme base) - (picrin macro)) + (import (scheme base)) + + ;; type 'a = cached of 'a | chained of 'a promise | pending of () -> 'a promise (define-record-type - (make-promise% done value) + (promise state value) promise? - (done promise-done? set-promise-done!) + (state promise-state set-promise-state!) (value promise-value set-promise-value!)) - (define-syntax delay-force - (syntax-rules () - ((_ expr) - (make-promise% #f (lambda () expr))))) - - (define-syntax delay - (syntax-rules () - ((_ expr) - (delay-force (make-promise% #t expr))))) - - (define (force promise) - (if (promise-done? promise) - (promise-value promise) - (let ((new-promise ((promise-value promise)))) - (if (promise-done? promise) - (promise-value promise) - (begin - (set-promise-done! promise (promise-done? new-promise)) - (set-promise-value! promise (promise-value new-promise)) - (force promise)))))) - (define (make-promise obj) (if (promise? obj) obj - (make-promise% #t obj))) + (promise 'cached obj))) + + (define-syntax delay-force + (syntax-rules () + ((_ expr) + (promise (string->symbol "pending") (lambda () expr))))) + + (define-syntax delay + (syntax-rules () + ((_ expr) + (delay-force (make-promise expr))))) + + (define (force p) + (let ((v (promise-value p))) + (case (promise-state p) + ((cached) v) + ((chained) (let () + (when (eq? 'cached (promise-state v)) + (set-promise-state! p 'cached) + (set-promise-value! p (promise-value v))) + (force v))) + ((pending) (let ((q (v))) + (when (eq? 'pending (promise-state p)) + (set-promise-state! p 'chained) + (set-promise-value! p q)) + (force p)))))) (export delay-force delay diff --git a/contrib/20.r7rs/t/r7rs.scm b/contrib/20.r7rs/t/r7rs.scm index 9334ad6e..cea02284 100644 --- a/contrib/20.r7rs/t/r7rs.scm +++ b/contrib/20.r7rs/t/r7rs.scm @@ -363,6 +363,15 @@ (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))) + (let () (define flag #f) (define p (delay (if flag