fix promise bug
fix the first one in https://github.com/picrin-scheme/picrin/issues/339
This commit is contained in:
parent
dd75267f8e
commit
842a0290f3
|
@ -6,32 +6,52 @@
|
||||||
|
|
||||||
(define-record-type <promise>
|
(define-record-type <promise>
|
||||||
(make-promise% done value)
|
(make-promise% done value)
|
||||||
promise?
|
promise?%
|
||||||
(done promise-done? set-promise-done!)
|
(done promise-done?% set-promise-done!%)
|
||||||
(value promise-value set-promise-value!))
|
(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
|
(define-syntax delay-force
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ expr)
|
((_ expr)
|
||||||
(make-promise% #f (lambda () expr)))))
|
(make-promise%% #f (lambda () expr)))))
|
||||||
|
|
||||||
(define-syntax delay
|
(define-syntax delay
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ expr)
|
((_ expr)
|
||||||
(delay-force (make-promise% #t expr)))))
|
(delay-force (make-promise%% #t expr)))))
|
||||||
|
|
||||||
(define (force promise)
|
(define (force promise)
|
||||||
(if (promise-done? promise)
|
(if (promise-done? promise)
|
||||||
(promise-value promise)
|
(promise-value promise)
|
||||||
(let ((new-promise ((promise-value promise))))
|
(let ((new-promise ((promise-value promise))))
|
||||||
(set-promise-done! promise (promise-done? new-promise))
|
(set-promise-done! promise (promise-done? new-promise))
|
||||||
(set-promise-value! promise (promise-value new-promise))
|
(set-promise-value! promise (promise-value new-promise))
|
||||||
(force promise))))
|
(set-box! new-promise (unbox promise))
|
||||||
|
(force promise))))
|
||||||
|
|
||||||
(define (make-promise obj)
|
(define (make-promise obj)
|
||||||
(if (promise? obj)
|
(if (and (box? obj) (promise? obj))
|
||||||
obj
|
obj
|
||||||
(make-promise% #t obj)))
|
(make-promise%% #t obj)))
|
||||||
|
|
||||||
(export delay-force
|
(export delay-force
|
||||||
delay
|
delay
|
||||||
|
|
|
@ -363,7 +363,14 @@
|
||||||
(force x)
|
(force x)
|
||||||
(promise? 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
|
(define radix
|
||||||
|
|
Loading…
Reference in New Issue