Changeset 14155 in project


Ignore:
Timestamp:
04/07/09 17:22:30 (11 years ago)
Author:
Kon Lovett
Message:

Removed use of box.

Location:
release/4/srfi-45/trunk
Files:
2 edited

Legend:

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

    r13837 r14155  
    99 (needs setup-helper)
    1010 (files
     11  "tests"
    1112  "chicken-primitive-object-inlines.scm"
    12   "tests"
    1313  "srfi-45.scm"
    1414  "srfi-45.setup") )
  • release/4/srfi-45/trunk/srfi-45.scm

    r14154 r14155  
    2525;; Recursive promise
    2626
    27 (define-inline (%make-promise-box tag val) (%cons tag val))
    28 (define-inline (%promise-box? obj) (%pair? obj))
    29 (define-inline (%promise-box-tag prm) (%car prm))
    30 (define-inline (%promise-box-value prm) (%cdr prm))
    31 (define-inline (%promise-box-tag-set! prm tag) (%set-car!/mutate prm tag))
    32 (define-inline (%promise-box-value-set! prm val) (%set-cdr! prm val))
     27(define-inline (%make-promise tag val) (%make-structure tag val))
    3328
    34 (define-inline (%make-promise tag val) (make-box (%make-promise-box tag val)))
    35 (define-inline (%promise-box-ref prmbox) (*box-structure-ref prmbox))
    36 (define-inline (%promise-box-set! box prmbox) (*box-structure-set! box prmbox))
     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)))
    3733
    38 (define-inline (%checked-promise-box obj)
    39   (and (*box-structure? obj)
    40        (let ((boxed (%promise-box-ref obj)))
    41          (and (%promise-box? boxed)
    42               boxed ) ) ) )
     34(define-inline (%promise-tag prm) (%structure-ref prm 0))
     35(define-inline (%promise-tag-set! prm tag) (%structure-set!/immediate prm 0 tag))
    4336
    44 (define-inline (%lazy-promise? obj)
    45   (and-let* ((boxed (%checked-promise-box obj)))
    46     (%eq? lazy-tag (%promise-box-tag boxed))) )
     37(define-inline (%promise-value prm) (%structure-ref prm 1))
     38(define-inline (%promise-value-set! prm prmbox) (%structure-set! prm 1 prmbox))
    4739
    48 (define-inline (%eager-promise? obj)
    49   (and-let* ((boxed (%checked-promise-box obj)))
    50     (%eq? eager-tag (%promise-box-tag boxed) ) ) )
    51 
    52 (define-inline (%promise? obj)
    53   (and-let* ((boxed (%checked-promise-box obj)))
    54     (let ((tag (%promise-box-tag boxed)))
    55       (or (%eq? lazy-tag tag) (%eq? eager-tag tag) ) ) ) )
    56 
    57 (define-inline (%lazy-thunk? obj)
    58   (and-let* ((dat (procedure-data obj)))
    59     (%eq? thunk-tag dat) ) )
     40(define-inline (%promise-set! prm prm2)
     41  (%promise-tag-set! prm (%promise-tag prm2))
     42  (%promise-value-set! prm (%promise-value prm2)) )
    6043
    6144;;; Module srfi-45
    6245
    63 (require-library box)
    64 
    6546(module srfi-45 (;export
    6647  ; SRFI 45
    67   (lazy $finlzy)
     48  (lazy $finlzy$)
    6849  eager
    6950  promise?
     
    7758(import (rename scheme (force r5rs:force) #;(delay r5rs:delay))
    7859        (rename chicken (promise? r5rs:promise?))
    79         (only lolevel procedure-data extend-procedure)
    80         (only box make-box *box-structure? *box-structure-ref *box-structure-set!))
     60        (only lolevel procedure-data extend-procedure))
     61
     62(require-library lolevel)
    8163
    8264;; Errors
     
    8769;; Unique Ids
    8870
    89 (define lazy-tag (%make-unique-object 'lazy))
    90 (define eager-tag (%make-unique-object 'eager))
    9171(define thunk-tag (%make-unique-object 'thunk))
    9272
    9373;; Helpers
    9474
    95 (define ($finlzy thunk) (%make-promise lazy-tag (extend-procedure thunk thunk-tag)))
     75(define ($finlzy$ thunk) (%make-promise 'lazy-promise (extend-procedure thunk thunk-tag)))
    9676
    9777;; Constructors
     
    9979(define-syntax lazy
    10080  (syntax-rules ()
    101     ((_ ?expr) ($finlzy (lambda () ?expr)) ) ) )
     81    ((_ ?expr) ($finlzy$ (lambda () ?expr)) ) ) )
    10282
    103 (define (eager value) (%make-promise eager-tag #;value (list value)))
     83(define (eager value) (%make-promise 'eager-promise (list value)))
    10484
    10585#; ;R5RS supported
     
    11898
    11999(define (force top)
    120 
    121100  ; What kind of promise?
    122101  (cond
    123 
    124102    ; New fashion promise?
    125103    ((%promise? top)
    126 
    127      ; Unbox
    128      (let* ((top-box (%promise-box-ref top))
    129             (value (%promise-box-value top-box)))
    130 
    131        ; Process by kind
    132        (select (%promise-box-tag top-box)
    133 
    134          ; Eager has value ready
    135          ((eager-tag) #;value (apply values value))
    136 
    137          ; Force a lazy promise's value
    138          ((lazy-tag)
    139           (cond
    140 
    141             ; Actual lazy promise?
    142             ((%lazy-thunk? value)
    143 
    144              ; Force the promise by invoking the thunk
    145              (let ((value* (receive (value))))
    146 
    147                ; Re-fetch and check the top promise again in case it recursed into `force'
    148                (let ((top-box (%promise-box-ref top)))
    149 
    150                  ; Could be eager, lazy, r5rs or actual results
    151                  (when (%eq? lazy-tag (%promise-box-tag top-box))
    152 
    153                    ; Another promise?
    154                    (let ((promise (and (= 1 (length value*)) (%car value*))))
    155 
    156                      ; Copy the enclosed promise to the top
    157                      (let ((promise-box (%promise-box-ref promise)))
    158                         (%promise-box-tag-set! top-box (%promise-box-tag promise-box))
    159                         (%promise-box-value-set! top-box (%promise-box-value promise-box))
    160                         (%promise-box-set! promise top-box) ) ) )
    161 
    162                  ; Now that all the work has been done, return a result
    163                  (force top) ) ) )
    164 
    165             ; Wrapped promise?
    166             ((or (%eager-promise? value) (r5rs:promise? value)) (force value))
    167 
    168             ; Already "forced"
    169             (else #;value (apply values value) ) ) )
    170 
    171          ; This shouldn't happen
    172          (else
    173           (error-promise-corrupt 'force top) ) ) ) )
    174 
     104      ; Unbox
     105      (let ((value (%promise-value top)))
     106        ; Process by kind
     107        (case (%promise-tag top)
     108          ; Eager has value ready
     109          ((eager-promise)
     110            (apply values value))
     111          ; Force a lazy promise's value
     112          ((lazy-promise)
     113            ; Better be an un-evaluated thunk
     114            (if (%lazy-thunk? value)
     115                ; 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*) ) ) )
     127                   ; Now that all the work has been done, return a result
     128                   (force top) )
     129                ; else this shouldn't happen
     130                (error 'force "expected an un-forced lazy promise" value) ) )
     131          ; This shouldn't happen
     132          (else
     133            (error-promise-corrupt 'force top) ) ) ) )
    175134    ; Old fashion promise?
    176     ((r5rs:promise? top) (r5rs:force top) )
    177 
     135    ((r5rs:promise? top)
     136      (r5rs:force top) )
    178137    ; No promise at all. Return object per the Chicken manual.
    179138    (else
    180      top ) ) )
     139      top ) ) )
    181140
    182141;;;
Note: See TracChangeset for help on using the changeset viewer.