Changeset 14157 in project


Ignore:
Timestamp:
04/07/09 18:34:35 (11 years ago)
Author:
Kon Lovett
Message:

Own boxing.

File:
1 edited

Legend:

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

    r14155 r14157  
    2525;; Recursive promise
    2626
    27 (define-inline (%make-promise tag val) (%make-structure tag val))
     27(define-inline (%make-promise-box tag val) (cons tag val))
     28(define-inline (%promise-box-tag prmbox) (%car prmbox))
     29(define-inline (%promise-box-tag-set! prmbox tag) (%set-car!/immediate prmbox tag))
     30(define-inline (%promise-box-value prmbox) (%cdr prmbox))
     31(define-inline (%promise-box-value-set! prmbox val) (%set-cdr! prmbox val))
    2832
    29 (define-inline (%eager-promise? obj) (%structure-instance? obj 'eager-promise))
    30 (define-inline (%lazy-promise? obj) (%structure-instance? obj 'lazy-promise))
    31 (define-inline (%promise? obj) (or (%eager-promise? obj) (%lazy-promise? obj)))
    32 (define-inline (%lazy-thunk? obj) (and-let* ((dat (procedure-data obj))) (%eq? thunk-tag dat)))
     33(define-inline (%eager-promise-box? prmbox) (%eq? 'eager (%promise-box-tag prmbox)))
     34(define-inline (%lazy-promise-box? prmbox) (%eq? 'lazy (%promise-box-tag prmbox)))
    3335
    34 (define-inline (%promise-tag prm) (%structure-ref prm 0))
    35 (define-inline (%promise-tag-set! prm tag) (%structure-set!/immediate prm 0 tag))
     36(define-inline (%make-promise tag val) (%make-structure 'promise (%make-promise-box tag val)))
     37(define-inline (%promise? obj) (%structure-instance? obj 'promise))
     38(define-inline (%promise-box prm) (%structure-ref prm 1))
     39(define-inline (%promise-box-set! prm prmbox) (%structure-set! prm 1 prmbox))
    3640
    37 (define-inline (%promise-value prm) (%structure-ref prm 1))
    38 (define-inline (%promise-value-set! prm prmbox) (%structure-set! prm 1 prmbox))
     41(define-inline (%make-eager-promise val) (%make-promise 'eager val))
     42(define-inline (%make-lazy-promise val) (%make-promise 'lazy val))
    3943
    40 (define-inline (%promise-set! prm prm2)
    41   (%promise-tag-set! prm (%promise-tag prm2))
    42   (%promise-value-set! prm (%promise-value prm2)) )
     44(define-inline (%eager-promise? obj)
     45  (and (%promise? obj) (%eager-promise-box? (%promise-box obj))) )
     46(define-inline (%lazy-promise? obj)
     47  (and (%promise? obj) (%lazy-promise-box? (%promise-box obj))) )
     48(define-inline (%recursive-promise? obj)
     49  (and (%promise? obj)
     50       (let ((prmbox (%promise-box obj)))
     51         (or (%eager-promise-box? prmbox) (%lazy-promise-box? prmbox)))) )
    4352
    4453;;; Module srfi-45
     
    4655(module srfi-45 (;export
    4756  ; SRFI 45
    48   (lazy $finlzy$)
     57  (lazy $$finlzy)
    4958  eager
    5059  promise?
     
    6776  (##sys#signal-hook #:type-error loc "promise is corrupt" prm) )
    6877
    69 ;; Unique Ids
    70 
    71 (define thunk-tag (%make-unique-object 'thunk))
    72 
    73 ;; Helpers
    74 
    75 (define ($finlzy$ thunk) (%make-promise 'lazy-promise (extend-procedure thunk thunk-tag)))
    76 
    7778;; Constructors
    7879
    79 (define-syntax lazy
    80   (syntax-rules ()
    81     ((_ ?expr) ($finlzy$ (lambda () ?expr)) ) ) )
     80(define ($$finlzy thunk) (%make-lazy-promise thunk))
    8281
    83 (define (eager value) (%make-promise 'eager-promise (list value)))
     82(define-syntax lazy (syntax-rules () ((_ ?expr) ($$finlzy (lambda () ?expr)))))
     83
     84(define (eager value) (%make-eager-promise (list value)))
    8485
    8586#; ;R5RS supported
    86 (define-syntax delay
    87   (syntax-rules ()
    88     ((_ ?exp) (lazy (eager ?exp)) ) ) )
     87(define (delay value) (lazy (eager value)))
    8988
    9089;; Predicates
     
    9291(define (lazy-promise? obj) (%lazy-promise? obj))
    9392(define (eager-promise? obj) (%eager-promise? obj))
    94 (define (recursive-promise? obj) (%promise? obj))
    95 (define (promise? obj) (or (r5rs:promise? obj) (%promise? obj)))
     93(define (recursive-promise? obj) (%recursive-promise? obj))
     94(define (promise? obj) (or (r5rs:promise? obj) (%recursive-promise? obj)))
    9695
    9796;; Force
    9897
    99 (define (force top)
     98(define (force prm)
    10099  ; What kind of promise?
    101100  (cond
    102101    ; New fashion promise?
    103     ((%promise? top)
     102    ((%recursive-promise? prm)
    104103      ; Unbox
    105       (let ((value (%promise-value top)))
     104      (let* ((prmbox (%promise-box prm))
     105             (value (%promise-box-value prmbox)))
    106106        ; Process by kind
    107         (case (%promise-tag top)
     107        (case (%promise-box-tag prmbox)
    108108          ; Eager has value ready
    109           ((eager-promise)
     109          ((eager)
    110110            (apply values value))
    111111          ; Force a lazy promise's value
    112           ((lazy-promise)
     112          ((lazy)
    113113            ; Better be an un-evaluated thunk
    114             (if (%lazy-thunk? value)
     114            (if (%procedure? value)
    115115                ; Force the promise by invoking the thunk
    116                 ; Re-fetch and check the top promise again in case it recursed into `force'
    117                 (let ((value* (receive (value))))
    118                   ;
    119                   (unless (%eq? 'eager-promise (%promise-tag top))
    120                     ; Another promise?
    121                     (let ((promise (and (= 1 (length value*)) (%car value*))))
    122                       (if promise
    123                           ; then copy the promise to the top
    124                           (%promise-set! top promise)
    125                           ; else this shouldn't happen
    126                           (error 'force "expected a promise" value*) ) ) )
     116                (let* ((value* (receive (value)))
     117                       ; Re-fetch and check the top promise again in case it recursed into `force'
     118                       (prmbox (%promise-box prm)) )
     119                  ; Copy the promise to the top
     120                  (unless (%eager-promise-box? prmbox)
     121                    (let* ((prm* (and (= 1 (length value*)) (%car value*)))
     122                           (prmbox* (if (and prm* (%recursive-promise? prm*))
     123                                        ; then we got our promise
     124                                        (%promise-box prm*)
     125                                        ; else this shouldn't happen
     126                                        (error 'force "expected a recursive promise" value*) ) ) )
     127                      (%promise-box-tag-set! prmbox (%promise-box-tag prmbox*))
     128                      (%promise-box-value-set! prmbox (%promise-box-value prmbox*))
     129                      (%promise-box-set! prm* prmbox) ) )
    127130                   ; Now that all the work has been done, return a result
    128                    (force top) )
     131                   (force prm) )
    129132                ; else this shouldn't happen
    130133                (error 'force "expected an un-forced lazy promise" value) ) )
    131134          ; This shouldn't happen
    132135          (else
    133             (error-promise-corrupt 'force top) ) ) ) )
     136            (error-promise-corrupt 'force prm) ) ) ) )
    134137    ; Old fashion promise?
    135     ((r5rs:promise? top)
    136       (r5rs:force top) )
     138    ((r5rs:promise? prm)
     139      (r5rs:force prm) )
    137140    ; No promise at all. Return object per the Chicken manual.
    138141    (else
    139       top ) ) )
     142      prm ) ) )
    140143
    141144;;;
Note: See TracChangeset for help on using the changeset viewer.