Changeset 14146 in project


Ignore:
Timestamp:
04/07/09 05:54:47 (11 years ago)
Author:
Kon Lovett
Message:

Experimental.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/srfi-45/trunk/srfi-45.scm

    r14107 r14146  
    8282;; Errors
    8383
    84 #; ;UNUSED
    85 (define (error-promise-type loc obj)
    86   (##sys#signal-hook #:type-error loc "bad argument type - not a promise" obj) )
    87 
    8884(define (error-promise-corrupt loc prm)
    8985  (##sys#signal-hook #:type-error loc "promise is corrupt" prm) )
     
    9793;; Helpers
    9894
    99 (define ($finlzy thunk)
    100   (%make-promise lazy-tag (extend-procedure thunk thunk-tag)) )
     95(define ($finlzy thunk) (%make-promise lazy-tag (extend-procedure thunk thunk-tag)))
    10196
    10297;; Constructors
     
    107102     ($finlzy (lambda () ?expr)) ) ) )
    108103
    109 (define (eager value) (%make-promise eager-tag value))
     104(define (eager value) (%make-promise eager-tag (list value)))
    110105
    111106;; Predicates
     
    147142
    148143             ; Force the promise by invoking the thunk
    149              (let* ((promise (call-with-values
    150                               value
    151                               (lambda xs
    152                                 (cond ((%null? xs) '())
    153                                       ((%null? (%cdr xs)) (%car xs))
    154                                       (else xs))))))
    155 
    156                ; Fetch and check the top promise again in case it recursed
    157                ; into `force'
     144             (let ((value* (receive (value))))
     145
     146               ; Re-fetch and check the top promise again in case it recursed into `force'
    158147               (let ((top-box (%promise-box-ref top)))
    159148
    160                  ; Possible eager, lazy, r5rs or actual results
    161                  (cond
    162 
    163                    ; Maybe eager now
    164                    ((%eq? eager-tag (%promise-box-tag top-box))
    165                     (apply values (%promise-box-value top-box)) )
    166 
    167                    ; Results or a R5RS promise - force w/ updated top
    168                    ((not (%lazy-promise? promise))
    169                     (%promise-box-value-set! top-box promise)
    170                     (force top) )
    171 
    172                    ; Lazy promise - force w/ updated top
    173                    (else
    174                     (let ((promise-box (%promise-box-ref promise)))
    175                       ; Copy the enclosed promise to the top
    176                       (%promise-box-tag-set! top-box (%promise-box-tag promise-box))
    177                       (%promise-box-value-set! top-box (%promise-box-value promise-box))
    178                       (%promise-box-set! promise top-box) )
    179                     (force top) ) ) ) ) )
     149                 ; Eager, lazy, r5rs or actual results
     150                 (unless (%eq? eager-tag (%promise-box-tag top-box))
     151
     152                   ; Try a promise
     153                   (let ((promise (and (not (%null? value*))
     154                                       (%null? (%cdr value*))
     155                                       (%car value*))))
     156                     (if (%lazy-promise? promise)
     157
     158                         ; then lazy promise
     159                         (let ((promise-box (%promise-box-ref promise)))
     160                            ; Copy the enclosed promise to the top
     161                            (%promise-box-tag-set! top-box (%promise-box-tag promise-box))
     162                            (%promise-box-value-set! top-box (%promise-box-value promise-box))
     163                            (%promise-box-set! promise top-box) )
     164
     165                         ; else results or a R5RS promise
     166                         (%promise-box-value-set! top-box promise) ) ) )
     167
     168                 ; Now that all the work has been done, return a result
     169                 (force top) ) ) )
    180170
    181171            ; Already "forced"
Note: See TracChangeset for help on using the changeset viewer.