From 842a0290f396b7db91bcd7f1e153419427a4f620 Mon Sep 17 00:00:00 2001 From: stibear Date: Wed, 1 Jun 2016 17:21:07 +0900 Subject: [PATCH 1/4] fix promise bug fix the first one in https://github.com/picrin-scheme/picrin/issues/339 --- contrib/20.r7rs/scheme/lazy.scm | 40 ++++++++++++++++++++++++--------- contrib/20.r7rs/t/r7rs.scm | 9 +++++++- 2 files changed, 38 insertions(+), 11 deletions(-) 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 From d9f4380ae89cea20b0920e8d5dcbf6ef6ff73487 Mon Sep 17 00:00:00 2001 From: stibear Date: Thu, 2 Jun 2016 22:28:49 +0900 Subject: [PATCH 2/4] fix promise bug fix the second one in https://github.com/picrin-scheme/picrin/issues/339 --- contrib/20.r7rs/scheme/lazy.scm | 11 +++++++---- contrib/20.r7rs/t/r7rs.scm | 10 ++++++++++ 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/contrib/20.r7rs/scheme/lazy.scm b/contrib/20.r7rs/scheme/lazy.scm index 88a4739f..c2118797 100644 --- a/contrib/20.r7rs/scheme/lazy.scm +++ b/contrib/20.r7rs/scheme/lazy.scm @@ -43,10 +43,13 @@ (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)) - (set-box! new-promise (unbox promise)) - (force 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)) diff --git a/contrib/20.r7rs/t/r7rs.scm b/contrib/20.r7rs/t/r7rs.scm index 483e7625..cea02284 100644 --- a/contrib/20.r7rs/t/r7rs.scm +++ b/contrib/20.r7rs/t/r7rs.scm @@ -372,6 +372,16 @@ (force op) (test 'ok (force np))) +(let () + (define flag #f) + (define p (delay (if flag + 'ok + (begin + (set! flag #t) + (force p) + 'ng)))) + (test 'ok (force p))) + (define radix (make-parameter From 365ccc7a510154f5669bd606d579f755199a6e51 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 3 Jun 2016 01:44:03 +0900 Subject: [PATCH 3/4] fix #339 --- contrib/20.r7rs/scheme/lazy.scm | 65 ++++++++++++--------------------- 1 file changed, 23 insertions(+), 42 deletions(-) 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 From f1b6109b2f34bd937ac553228832c6dfca14b370 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 3 Jun 2016 02:42:48 +0900 Subject: [PATCH 4/4] make a small optimization --- contrib/20.r7rs/scheme/lazy.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/contrib/20.r7rs/scheme/lazy.scm b/contrib/20.r7rs/scheme/lazy.scm index f429dcd0..d934ad45 100644 --- a/contrib/20.r7rs/scheme/lazy.scm +++ b/contrib/20.r7rs/scheme/lazy.scm @@ -30,7 +30,11 @@ (let ((v (promise-value p))) (case (promise-state p) ((cached) v) - ((chained) (force 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)