fix promise bug

fix the first one in https://github.com/picrin-scheme/picrin/issues/339

contrib/20.r7rs/scheme/lazy.scm

@@ -6,32 +6,52 @@
 
   (define-record-type <promise>
       (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

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