adding lazy

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

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

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
 };
 

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;
       }
     }