From d9f4380ae89cea20b0920e8d5dcbf6ef6ff73487 Mon Sep 17 00:00:00 2001
From: stibear <stibear.lisp@gmail.com>
Date: Thu, 2 Jun 2016 22:28:49 +0900
Subject: [PATCH] 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