Changeset 15602 in project


Ignore:
Timestamp:
08/28/09 16:57:22 (10 years ago)
Author:
Kon Lovett
Message:

Redefines 'delay'

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

Legend:

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

    r15585 r15602  
    2929  (lazy make-lazy-promise)
    3030  (eager make-eager-promise)
     31  delay
    3132  promise?
    32   #;delay
    3333  force
    3434  ; Extras
    35   delay-recursive d-lay ; since we don't redefine R5RS `delay'
    3635  lazy-promise?
    3736  eager-promise?
    3837  recursive-promise?)
    3938
    40 (import (rename scheme (force r5rs:force) #;(delay r5rs:delay))
     39(import (rename scheme (force r5rs:force) (delay r5rs:delay))
    4140        (rename chicken (promise? r5rs:promise?))
    4241        type-errors)
     
    7776(define-syntax lazy (syntax-rules () ((_ ?expr) (make-lazy-promise (lambda () ?expr)))))
    7877(define-syntax eager (syntax-rules () ((_ ?expr) (make-eager-promise (receive ?expr)))))
    79 #;(define-syntax delay (syntax-rules () ((_ ?expr) (lazy (eager ?expr)))))
    80 
    81 (define-syntax delay-recursive (syntax-rules () ((_ ?expr) (lazy (eager ?expr)))))
    82 (define-syntax d-lay (syntax-rules () ((_ ?expr) (lazy (eager ?expr)))))
     78(define-syntax delay (syntax-rules () ((_ ?expr) (lazy (eager ?expr)))))
    8379
    8480;; Predicates
     
    110106            (if (%procedure? value)
    111107                ; Force the promise by invoking the thunk
    112                 (let ((value (receive (value))))
     108                (let ((value* (receive (value))))
    113109                  ; Re-fetch and check the top promise again in case it recursed into `force'
    114110                  (let ((prmbox (and (%promise? prm) (%promise-box prm))))
     
    116112                    (if (or (not prmbox) (%eager-promise-box? prmbox)) (force prm)
    117113                        ; Value better be a promise (and only a promise)
    118                         (let ((prm* (and (= 1 (length value)) (%car value))))
     114                        (let ((prm* (and (= 1 (length value*)) (%car value*))))
    119115                          (cond
    120116                            ((%promise? prm*)
     
    128124                              (r5rs:force prm*) )
    129125                            (else
    130                               (error-promise 'force value) ) ) ) ) ) )
     126                              (error-promise 'force value*) ) ) ) ) ) )
    131127                ; This shouldn't happen
    132128                (error-promise-unforced-lazy 'force value) ) )
  • release/4/srfi-45/trunk/tests/run.scm

    r15585 r15602  
    11;;;; srfi-45 test
    22
    3 (require-extension srfi-45)
     3(module test ()
     4
     5(import (rename scheme (force r5rs:force) (delay r5rs:delay))
     6        (rename chicken (promise? r5rs:promise?))
     7        srfi-45)
     8
     9(require-library srfi-45)
    410
    511;; Perform, or not, a bounded space test.
     
    2733(print "+++ Should print 'hi 1 +++")
    2834
    29 (define r (delay (begin (display 'hi) (display #\space) 1)))
     35(define r (r5rs:delay (begin (display 'hi) (display #\space) 1)))
    3036(define s (lazy r))
    3137(define t (lazy s))
     
    3339
    3440;=========================================================================
     41; Multiple values test 1:
     42
     43(print "+++ Should print '(1 2 3) +++")
     44
     45(define r (delay (values 1 2 3)))
     46(define s (lazy r))
     47(define t (lazy s))
     48(print (receive (force t)))
     49
     50;=========================================================================
    3551; Memoization test 1:
    3652
    3753(print "+++ Should print 'hello once +++")
    3854
    39 (define s (d-lay (begin (print 'hello) 1)))
     55(define s (delay (begin (print 'hello) 1)))
    4056
    4157(force s)
     
    4763(print "+++ Should print 'bonjour once +++")
    4864
    49 (let ((s (d-lay (begin (print 'bonjour) 2))))
     65(let ((s (delay (begin (print 'bonjour) 2))))
    5066  (+ (force s) (force s)))
    5167
     
    5571(print "+++ Should print 'hi once +++")
    5672
    57 (define r (d-lay (begin (print 'hi) 1)))
     73(define r (delay (begin (print 'hi) 1)))
    5874(define s (lazy r))
    5975(define t (lazy s))
     
    7288
    7389(define (ones)
    74   (d-lay (begin
     90  (delay (begin
    7591           (print 'ho)
    7692           (cons 1 (ones)))))
     
    88104(define count 0)
    89105(define p
    90   (d-lay (begin
     106  (delay (begin
    91107           (set! count (+ count 1))
    92108           (if (> count x) count
     
    105121(define f
    106122  (let ((first? #t))
    107     (d-lay (if (not first?) 'second
     123    (delay (if (not first?) 'second
    108124               (begin
    109125                 (set! first? #f)
     
    120136  (let ((count 5))
    121137    (define (get-count) count)
    122     (define p (d-lay (if (<= count 0) count
     138    (define p (delay (if (<= count 0) count
    123139                         (begin
    124140                           (set! count (- count 1))
     
    157173
    158174(define (from n)
    159   (d-lay (cons n (from (+ n 1)))))
     175  (delay (cons n (from (+ n 1)))))
    160176
    161177(define (traverse s)
     
    197213  (lazy (test:match (force s)
    198214          (()
    199            (d-lay '()))
     215           (delay '()))
    200216          ((h . t)
    201            (if (p? h) (d-lay (cons h (stream-filter p? t)))
     217           (if (p? h) (delay (cons h (stream-filter p? t)))
    202218               (stream-filter p? t))))))
    203219
     
    217233           'error)
    218234          ((h . t)
    219            (if (zero? index) (d-lay h)
     235           (if (zero? index) (delay h)
    220236               (stream-ref t (- index 1)))))))
    221237
     
    241257
    242258(+bounded-space (force (times3 10000 #;100000000)))
     259
     260)
Note: See TracChangeset for help on using the changeset viewer.