From 7459df91b61021951b42c75bb9cd5d0245db2fd1 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Wed, 5 Oct 2011 21:21:27 +0900
Subject: [PATCH] adding lazy

---
 eval.c         |  8 +++-----
 lib/init-7.scm | 33 ++++++++++++++++++++++-----------
 opcodes.c      |  3 ++-
 vm.c           |  9 +++++----
 4 files changed, 32 insertions(+), 21 deletions(-)

diff --git a/eval.c b/eval.c
index efaf67ef..a42dea2f 100644
--- a/eval.c
+++ b/eval.c
@@ -1490,12 +1490,10 @@ sexp sexp_string_utf8_index_set (sexp ctx sexp_api_params(self, n), sexp str, se
 #endif
 
 #if SEXP_USE_AUTO_FORCE
-sexp sexp_make_promise (sexp ctx sexp_api_params(self, n), sexp thunk) {
-  sexp_assert_type(ctx, sexp_applicablep, SEXP_PROCEDURE, thunk);
+sexp sexp_make_promise (sexp ctx sexp_api_params(self, n), sexp done, sexp val) {
   sexp res = sexp_alloc_type(ctx, promise, SEXP_PROMISE);
-  sexp_promise_donep(res) = 0;
-  sexp_promise_thunk(res) = thunk;
-  sexp_promise_value(res) = SEXP_VOID;
+  sexp_promise_donep(res) = sexp_unbox_boolean(done);
+  sexp_promise_value(res) = val;
   return res;
 }
 #endif
diff --git a/lib/init-7.scm b/lib/init-7.scm
index 1279b99a..8c9dcf02 100644
--- a/lib/init-7.scm
+++ b/lib/init-7.scm
@@ -308,10 +308,15 @@
          ,(map (lambda (x) (list (car x) (cadr x))) (cadr expr))
          ,wrap)))))
 
+(define-syntax lazy
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     `(,(rename 'make-promise) #f (,(rename 'lambda) () ,(cadr expr))))))
+
 (define-syntax delay
   (er-macro-transformer
    (lambda (expr rename compare)
-     `(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr expr))))))
+     `(,(rename 'lazy) (,(rename 'make-promise) #t ,(cadr expr))))))
 
 (define-syntax define-auxiliary-syntax
   (er-macro-transformer
@@ -896,17 +901,23 @@
 
 (cond-expand
  (auto-force
-  (define (force x) x))
+  )
  (else
-  (define (make-promise thunk)
-   (lambda ()
-     (let ((computed? #f) (result #f))
-       (if (not computed?)
-           (begin
-             (set! result (thunk))
-             (set! computed? #t)))
-       result)))
-  (define (force x) (if (procedure? x) (x) x))))
+  (define (make-promise done? proc)
+    (list (cons done? proc)))
+  (define (promise-done? x) (car (car x)))
+  (define (promise-value x) (cdr (car x)))
+  (define (promise-update! new old)
+    (set-car! (car old) (promise-done? new))
+    (set-cdr! (car old) (promise-value new))
+    (set-car! new (car old)))
+  (define (force promise)
+    (if (promise-done? promise)
+        (promise-value promise)
+        (let ((promise* ((promise-value promise))))
+          (if (not (promise-done? promise))
+            (promise-update! promise* promise))
+          (force promise))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; math utils
diff --git a/opcodes.c b/opcodes.c
index 9b50c314..f6e18e5e 100644
--- a/opcodes.c
+++ b/opcodes.c
@@ -223,7 +223,8 @@ _FN0(SEXP_VOID, "reset-vm-profile", 0, sexp_reset_vm_profile),
 _FN0(SEXP_VOID, "print-vm-profile", 0, sexp_print_vm_profile),
 #endif
 #if SEXP_USE_AUTO_FORCE
-_FN1(_I(SEXP_PROMISE), _I(SEXP_PROCEDURE), "make-promise", 0, sexp_make_promise),
+_OP(SEXP_OPC_GENERIC, SEXP_OP_FORCE, 1, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "force", 0, NULL),
+_FN2(_I(SEXP_PROMISE), _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "make-promise", 0, sexp_make_promise),
 #endif
 };
 
diff --git a/vm.c b/vm.c
index d922406c..0a218a7f 100644
--- a/vm.c
+++ b/vm.c
@@ -1780,10 +1780,11 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
         _ARG1 = sexp_promise_value(_ARG1);
       } else {
         sexp_context_top(ctx) = top;
-        tmp1 = sexp_apply(ctx, sexp_promise_thunk(_ARG1), SEXP_NULL);
-        sexp_promise_value(_ARG1) = tmp1;
-        sexp_promise_donep(_ARG1) = 1;
-        sexp_promise_thunk(_ARG1) = SEXP_FALSE;
+        tmp1 = sexp_apply(ctx, sexp_promise_value(_ARG1), SEXP_NULL);
+        if (!sexp_promise_donep(_ARG1)) {
+          sexp_promise_value(_ARG1) = tmp1;
+          sexp_promise_donep(_ARG1) = 1;
+        }
         _ARG1 = tmp1;
       }
     }