From 9964679f600c8fb7a9fb30d1b0131a064af2592f Mon Sep 17 00:00:00 2001
From: admin <admin@vouivredigital.com>
Date: Mon, 20 Nov 2023 15:35:31 +0900
Subject: [PATCH] Allow reset of evaluated promises
---
promises.scm | 60 +++++++++++++++++++++++++++++++---------------------
1 file changed, 36 insertions(+), 24 deletions(-)
diff --git a/promises.scm b/promises.scm
index 6f7ba7e..98170b1 100644
--- 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)
--
2.39.5