Allow reset of evaluated promises

diff --git a/promises.scm b/promises.scm
index 6f7ba7e047411de781a1b7ac5ecd295b20d910cc..98170b11f321ee40e54b1b6bbccd6a565628afcc 100644 (file)
--- a/promises.scm
+++ b/promises.scm
@@ -30,54 +30,66 @@
 
 ;; This module is documented in the Guile Reference Manual.
 
+;; This file has been modified by Vouivre Digital Corporation. The exact
+;; modifications can be seen in a shell using:
+;; $ git diff b4695cd888df6511915262884d2ce317156f92e8 promises.scm
+
 ;;; Code:
 
-(define-module (srfi srfi-45)
-  #:export (delay
-             lazy
-             force
-             eager
-             promise?)
-  #:replace (delay force promise?)
+(define-module (vouivre promises)
+  #:export (*promises* reset-promises)
+  #:replace (delay force)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu))
 
-(cond-expand-provide (current-module) '(srfi-45))
+(define *promises* (make-parameter #f))
 
 (define-record-type promise (make-promise val) promise?
   (val promise-val promise-val-set!))
 
-(define-record-type value (make-value tag proc) value?
+(define-record-type value (make-value tag proc rec) value?
   (tag value-tag value-tag-set!)
-  (proc value-proc value-proc-set!))
+  (proc value-proc value-proc-set!)
+  (rec value-rec value-rec-set!))
 
 (define-syntax-rule (lazy exp)
-  (make-promise (make-value 'lazy (lambda () exp))))
+  (let ((proc (lambda () exp)))
+    (make-promise (make-value 'lazy proc proc))))
 
 (define (eager x)
-  (make-promise (make-value 'eager x)))
+  (make-promise (make-value 'eager x #f)))
 
 (define-syntax-rule (delay exp)
-  (lazy (eager exp)))
+  (let ((promise (lazy (eager exp)))
+       (promises-ptr (*promises*)))
+    (set-car! promises-ptr (cons promise (car promises-ptr)))
+    promise))
 
 (define (force promise)
   (let ((content (promise-val promise)))
     (case (value-tag content)
-      ((eager) (value-proc content))
-      ((lazy)  (let* ((promise* ((value-proc content)))
-                      (content  (promise-val promise)))        ; *
-                 (if (not (eqv? (value-tag content) 'eager))   ; *
-                     (begin (value-tag-set! content
-                                            (value-tag (promise-val promise*)))
-                            (value-proc-set! content
-                                             (value-proc (promise-val promise*)))
-                            (promise-val-set! promise* content)))
-                 (force promise))))))
-
+      ((eager)
+       (value-proc content))
+      ((lazy)
+       (let* ((promise* ((value-proc content)))
+              (content  (promise-val promise)))           ; *
+         (unless (eqv? 'eager (value-tag content)) ; *
+           (value-tag-set! content (value-tag (promise-val promise*)))
+           (value-proc-set! content (value-proc (promise-val promise*)))
+           (promise-val-set! promise* content))
+         (force promise))))))
 ;; (*) These two lines re-fetch and check the original promise in case
 ;;     the first line of the let* caused it to be forced.  For an example
 ;;     where this happens, see reentrancy test 3 below.
 
+(define (reset-promises promises)
+  (unless (null? promises)
+    (let ((v (promise-val (car promises))))
+      (when (value-rec v)
+       (value-proc-set! v (value-rec v))
+       (value-tag-set! v 'lazy))
+      (reset-promises (cdr promises)))))
+
 (define* (promise-visit promise #:key on-eager on-lazy)
   (define content (promise-val promise))
   (case (value-tag content)