diff --git a/contrib/20.r7rs/scheme/lazy.scm b/contrib/20.r7rs/scheme/lazy.scm index c2118797..f429dcd0 100644 --- a/contrib/20.r7rs/scheme/lazy.scm +++ b/contrib/20.r7rs/scheme/lazy.scm @@ -1,60 +1,41 @@ ;;; 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?% - (done promise-done?% set-promise-done!%) - (value promise-value% set-promise-value!%)) + (promise state value) + promise? + (state promise-state set-promise-state!) + (value promise-value set-promise-value!)) - (define (box x) (list x)) - (define box? list?) - (define unbox car) - (define set-box! set-car!) + (define (make-promise obj) + (if (promise? obj) + obj + (promise 'cached obj))) - (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))))) + (promise (string->symbol "pending") (lambda () expr))))) (define-syntax delay (syntax-rules () ((_ expr) - (delay-force (make-promise%% #t expr))))) + (delay-force (make-promise 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)) - (set-box! new-promise (unbox promise)) - (force promise)))))) - - (define (make-promise obj) - (if (and (box? obj) (promise? obj)) - obj - (make-promise%% #t obj))) + (define (force p) + (let ((v (promise-value p))) + (case (promise-state p) + ((cached) v) + ((chained) (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