Changeset 14152 in project


Ignore:
Timestamp:
04/07/09 15:36:45 (11 years ago)
Author:
Kon Lovett
Message:

Testing of SRFI 45 `delay'. Better (?) re-fetch handling.

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

Legend:

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

    r14146 r14152  
    5353  (and-let* ((boxed (%promise-box?->promise-box obj)))
    5454    (let ((tag (%promise-box-tag boxed)))
    55       (or (%eq? lazy-tag tag)
    56           (%eq? eager-tag tag) ) ) ) )
     55      (or (%eq? lazy-tag tag) (%eq? eager-tag tag) ) ) ) )
    5756
    5857(define-inline (%lazy-thunk? obj)
     
    6968  eager
    7069  promise?
     70  #;delay ;R5RS supported
    7171  force
    7272  ; Extras
     
    7575  recursive-promise?)
    7676
    77 (import (rename scheme (force r5rs:force))
     77(import (rename scheme (force r5rs:force) #;(delay r5rs:delay))
    7878        (rename chicken (promise? r5rs:promise?))
    7979        (only lolevel procedure-data extend-procedure)
     
    9999(define-syntax lazy
    100100  (syntax-rules ()
    101     ((_ ?expr)
    102      ($finlzy (lambda () ?expr)) ) ) )
    103 
    104 (define (eager value) (%make-promise eager-tag (list value)))
     101    ((_ ?expr) ($finlzy (lambda () ?expr)) ) ) )
     102
     103(define (eager value) (%make-promise eager-tag #;value (list value)))
     104
     105#; ;R5RS supported
     106(define-syntax delay
     107  (syntax-rules ()
     108    ((_ ?exp) (lazy (eager ?exp)) ) ) )
    105109
    106110;; Predicates
     
    129133
    130134         ; Eager has value ready
    131          ((eager-tag) (apply values value))
     135         ((eager-tag) #;value (apply values value))
    132136
    133137         ; Force a lazy promise's value
     
    135139          (cond
    136140
    137             ; Wrapped r5rs promise?
    138             ((r5rs:promise? value) (r5rs:force value))
    139 
    140141            ; Actual lazy promise?
    141142            ((%lazy-thunk? value)
     
    148149
    149150                 ; 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)))
     151                 (when (%eq? lazy-tag (%promise-box-tag top-box))
     152
     153                   ; Another promise?
     154                   (let ((value1 (and (= 1 (length value*)) (%car value*))))
     155
     156                     (cond ((not value1)
     157                            (%promise-box-value-set! top-box value*) )
     158
     159                           ((%lazy-promise? value1)
     160
    160161                            ; 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) ) ) )
     162                            (let ((promise-box (%promise-box-ref value1)))
     163                               (%promise-box-tag-set! top-box (%promise-box-tag promise-box))
     164                               (%promise-box-value-set! top-box (%promise-box-value promise-box))
     165                               (%promise-box-set! value1 top-box) ) )
     166
     167                           (else
     168                            (%promise-box-value-set! top-box value1) ) ) ) )
    167169
    168170                 ; Now that all the work has been done, return a result
    169171                 (force top) ) ) )
    170172
     173            ; Wrapped promise?
     174            ((or (%eager-promise? value) (r5rs:promise? value)) (force value))
     175
    171176            ; Already "forced"
    172             (else (apply values value) ) ) )
     177            (else #;value (apply values value) ) ) )
    173178
    174179         ; This shouldn't happen
  • release/4/srfi-45/trunk/tests/run.scm

    r13848 r14152  
    22
    33(require-extension srfi-45)
     4
     5;; Since Chicken SRFI 45 implementation does not redefine `delay'
     6;; define a version for testing purposes only.
     7
     8(define-syntax d-lay
     9  (syntax-rules ()
     10    ((_ ?exp) (lazy (eager ?exp)) ) ) )
     11
     12;; Perform, or not, a bounded space test.
     13;; The infinite tests are not performed by default.
    414
    515(define-syntax +bounded-space
     
    2434(print "+++ Should print 'hello once +++")
    2535
    26 (define s (delay (begin (print 'hello) 1)))
     36(define s (d-lay (begin (print 'hello) 1)))
    2737
    2838(force s)
     
    3444(print "+++ Should print 'bonjour once +++")
    3545
    36 (let ((s (delay (begin (print 'bonjour) 2))))
     46(let ((s (d-lay (begin (print 'bonjour) 2))))
    3747  (+ (force s) (force s)))
    3848
     
    4252(print "+++ Should print 'hi once +++")
    4353
    44 (define r (delay (begin (print 'hi) 1)))
     54(define r (d-lay (begin (print 'hi) 1)))
    4555(define s (lazy r))
    4656(define t (lazy s))
     
    6171
    6272(define (ones)
    63   (delay (begin
     73  (d-lay (begin
    6474           (print 'ho)
    6575           (cons 1 (ones)))))
     
    7787(define count 0)
    7888(define p
    79   (delay (begin (set! count (+ count 1))
     89  (d-lay (begin (set! count (+ count 1))
    8090                (if (> count x)
    8191                    count
     
    94104(define f
    95105  (let ((first? #t))
    96     (delay
     106    (d-lay
    97107      (if first?
    98108          (begin
     
    111121  (let ((count 5))
    112122    (define (get-count) count)
    113     (define p (delay (if (<= count 0)
     123    (define p (d-lay (if (<= count 0)
    114124                         count
    115125                         (begin (set! count (- count 1))
     
    147157
    148158(define (from n)
    149   (delay (cons n (from (+ n 1)))))
     159  (d-lay (cons n (from (+ n 1)))))
    150160
    151161(define (traverse s)
     
    183193(define (stream-filter p? s)
    184194  (lazy (test:match (force s)
    185           (()      (delay '()))
     195          (()      (d-lay '()))
    186196          ((h . t) (if (p? h)
    187                        (delay (cons h (stream-filter p? t)))
     197                       (d-lay (cons h (stream-filter p? t)))
    188198                       (stream-filter p? t))))))
    189199
     
    203213     (()      'error)
    204214     ((h . t) (if (zero? index)
    205                   (delay h)
     215                  (d-lay h)
    206216                  (stream-ref t (- index 1)))))))
    207217
Note: See TracChangeset for help on using the changeset viewer.