12211fff72
* A long-standing bug, which happened with
(let ([x (lazy (delay 1))]) (force x) (force x))
not being properly handled.
* Added `delay/strict', mostly for the below.
* Made srfi/45 reprovide it as `eager'.
* Also restricted the exports from srfi/45 to its interface.
All of these issues were reported by Andreas Rottmann.
197 lines
7.5 KiB
Racket
197 lines
7.5 KiB
Racket
#lang scheme/base
|
|
|
|
(require scheme/promise tests/eli-tester (for-syntax scheme/base))
|
|
|
|
;; check that things are `promise?'s or not
|
|
(define (test-types)
|
|
(for ([v (list 1 '(1) (lambda () 1))])
|
|
(test (promise? v) => #f))
|
|
(for ([v (list (delay 1) (lazy 1) (delay (delay 1)) (lazy (lazy 1)))])
|
|
(test (promise? v) => #t)))
|
|
|
|
(define (test-syntax)
|
|
(test (delay) =error> "bad syntax"
|
|
(lazy) =error> "bad syntax"
|
|
(delay #:foo 1 2) =error> "bad syntax"
|
|
(force (delay/thread #:group #f)) =error> "bad syntax"
|
|
(force (delay/thread #:group #f 1)) => 1
|
|
(force (delay/thread 1 #:group #f 2)) => 2
|
|
(force (delay/thread #:groupie #f 1)) =error> "bad syntax"))
|
|
|
|
;; basic delay/lazy/force tests
|
|
(define (test-basic-promises)
|
|
(define thunk1 (lambda () 1))
|
|
(define promise1 (delay 1))
|
|
(define ? #f)
|
|
;; test a few different values
|
|
(define-syntax-rule (t (f x ...))
|
|
(begin (set! ? 1) (test (f x ...) => ?)
|
|
(set! ? '()) (test (f x ...) => ?)
|
|
(set! ? '(1)) (test (f x ...) => ?)
|
|
(set! ? thunk1) (test (f x ...) => ?)))
|
|
(define-syntax-rule (t* (f x ...))
|
|
(begin (t (f x ...)) (set! ? promise1) (test (f x ...) => ?)))
|
|
;; `force' is identity for non-promises
|
|
(t (force ?))
|
|
;; basic checks that `delay' works as expected with all kinds of values
|
|
(t* (force (delay ?)))
|
|
(t* (force (force (delay (delay ?)))))
|
|
(t* (force (delay (force (delay ?)))))
|
|
;; basic checks that `lazy' works as expected with all kinds of values
|
|
(t (force (lazy ?)))
|
|
(t (force (lazy (lazy ?))))
|
|
(t (force (force (lazy (lazy ?)))))
|
|
(t (force (lazy (lazy (lazy (lazy ?))))))
|
|
;; check that `lazy' combines as expected with `delay' in regards to `force'
|
|
;; (generally, each `L*D?' sequence requires a force)
|
|
(t* (force (lazy (delay ?))))
|
|
(t* (force (lazy (lazy (delay ?)))))
|
|
(t* (force (lazy (lazy (lazy (delay ?))))))
|
|
;; two delays = two forces
|
|
(t* (force (force (lazy (delay (delay ?))))))
|
|
(t* (force (force (delay (lazy (delay ?))))))
|
|
(t* (force (force (lazy (lazy (delay (delay ?)))))))
|
|
(t* (force (force (lazy (delay (lazy (delay ?)))))))
|
|
(t* (force (force (delay (lazy (lazy (delay ?)))))))
|
|
(t* (force (force (lazy (lazy (lazy (delay (delay ?))))))))
|
|
(t* (force (force (lazy (lazy (delay (lazy (delay ?))))))))
|
|
(t* (force (force (lazy (delay (lazy (lazy (delay ?))))))))
|
|
(t* (force (force (delay (lazy (lazy (lazy (delay ?))))))))
|
|
;; now push the second force inside
|
|
(t* (force (lazy (force (delay (delay ?))))))
|
|
(t* (force (delay (force (lazy (delay ?))))))
|
|
(t* (force (lazy (force (lazy (delay (delay ?)))))))
|
|
(t* (force (lazy (force (delay (lazy (delay ?)))))))
|
|
(t* (force (delay (force (lazy (lazy (delay ?)))))))
|
|
(t* (force (lazy (force (lazy (lazy (delay (delay ?))))))))
|
|
(t* (force (lazy (force (lazy (delay (lazy (delay ?))))))))
|
|
(t* (force (lazy (force (delay (lazy (lazy (delay ?))))))))
|
|
(t* (force (delay (force (lazy (lazy (lazy (delay ?))))))))
|
|
(t* (force (lazy (delay (force (delay ?))))))
|
|
(t* (force (lazy (lazy (force (delay (delay ?)))))))
|
|
(t* (force (lazy (delay (force (lazy (delay ?)))))))
|
|
(t* (force (lazy (lazy (force (lazy (delay (delay ?))))))))
|
|
(t* (force (lazy (lazy (force (delay (lazy (delay ?))))))))
|
|
(t* (force (lazy (delay (force (lazy (lazy (delay ?))))))))
|
|
(t* (force (lazy (lazy (delay (force (delay ?)))))))
|
|
(t* (force (lazy (lazy (lazy (force (delay (delay ?))))))))
|
|
(t* (force (lazy (lazy (delay (force (lazy (delay ?)))))))))
|
|
|
|
(define (test-basic-promise-behavior)
|
|
(define (force+catch p) (with-handlers ([exn? values]) (force p)))
|
|
;; results are cached
|
|
(let* ([c 0] [p (delay (set! c (add1 c)) c)])
|
|
(test c => 0
|
|
(force p) => 1
|
|
(force p) => 1
|
|
(force p) => 1
|
|
c => 1))
|
|
;; errors are caught
|
|
(let ([p #f])
|
|
(test (void? (set! p (delay (error "BOOM"))))
|
|
(force p) =error> "BOOM"
|
|
(eq? (force+catch p) (force+catch p)))) ; and cached
|
|
;; raised values too
|
|
(let ([c 0] [p #f])
|
|
(test (void? (set! p (delay (set! c (add1 c)) (raise c))))
|
|
c => 0
|
|
(force p) => (raise 1)
|
|
(force p) => (raise 1)
|
|
c => 1))
|
|
;; test the predicates
|
|
(letrec ([forced+running?
|
|
(lambda (p) (list (promise-forced? p) (promise-running? p)))]
|
|
[p (delay (forced+running? p))])
|
|
(test (forced+running? p) => '(#f #f)
|
|
(force p) => '(#f #t)
|
|
(forced+running? p) => '(#t #f))))
|
|
|
|
(define (test-printout)
|
|
(letrec ([foo (delay (set! s (format "~a" foo)) 3)] [s #f])
|
|
(test (format "~a" foo) => "#<promise:foo>"
|
|
(force foo) => 3
|
|
s => "#<promise:!running!foo>"
|
|
(format "~a" foo) => "#<promise!3>"))
|
|
(let ([foo (delay (values 1 2 3))])
|
|
(test (format "~a" foo) => "#<promise:foo>"
|
|
(force foo) => (values 1 2 3)
|
|
(format "~a" foo) => "#<promise!(values 1 2 3)>"))
|
|
(let ([foo (delay (error "boom"))])
|
|
(test (format "~a" foo) => "#<promise:foo>"
|
|
(force foo) => (error "boom")
|
|
(format "~a" foo) => "#<promise!exn!boom>"
|
|
(format "~s" foo) => "#<promise!exn!\"boom\">"))
|
|
(let ([foo (delay (raise 3))])
|
|
(test (format "~a" foo) => "#<promise:foo>"
|
|
(force foo) => (raise 3)
|
|
(format "~a" foo) => "#<promise!raise!3>")))
|
|
|
|
(define (test-delay/name)
|
|
(let* ([x 1] [p (delay/name (set! x (add1 x)) x)])
|
|
(test (promise? p)
|
|
x => 1
|
|
(force p) => 2
|
|
x => 2
|
|
(format "~a" p) => "#<promise:p>"
|
|
(force p) => 3
|
|
x => 3)))
|
|
|
|
(define (test-delay/strict)
|
|
(let* ([x 1] [p (delay/strict (set! x (add1 x)) x)])
|
|
(test (promise? p)
|
|
x => 2
|
|
(force p) => 2
|
|
x => 2
|
|
(force (delay/strict (values 1 2 3))) => (values 1 2 3)
|
|
(promise? (force (delay/strict (delay 1)))))))
|
|
|
|
(define (test-delay/sync)
|
|
(letrec ([p (delay/sync (force p))])
|
|
(test (force p) =error> "reentrant"))
|
|
(let* ([ch (make-channel)]
|
|
[p (delay/sync (channel-get ch) (channel-get ch) 99)])
|
|
(test (format "~a" p) => "#<promise:p>")
|
|
(thread (lambda () (force p) (channel-get ch)))
|
|
(channel-put ch 'x)
|
|
(test (format "~a" p) => "#<promise:!running!p>")
|
|
(channel-put ch 'x)
|
|
(channel-put ch 'x)
|
|
(test (format "~a" p) => "#<promise!99>"
|
|
(force p) => 99)))
|
|
|
|
(define (test-delay/thread)
|
|
(define-syntax-rule (t delayer)
|
|
(begin (let* ([ch (make-channel)]
|
|
[p (delayer (channel-get ch) 99)])
|
|
(thread (lambda () (channel-put ch 'x)))
|
|
(test (force p) => 99))
|
|
(test (force (delayer (+ 1 "2"))) =error> "expects type")))
|
|
(t delay/sync)
|
|
(t delay/idle)
|
|
(let* ([ch (make-channel)] [p (delay/idle #:wait-for ch 99)])
|
|
(test (format "~a" p) => "#<promise:p>"
|
|
(force p) => 99
|
|
(format "~a" p) => "#<promise!99>"))
|
|
(let* ([ch (make-channel)]
|
|
[p (delay/idle #:wait-for ch (channel-get ch) 99)])
|
|
(channel-put ch 'x)
|
|
(test (format "~a" p) => "#<promise:!running!p>"
|
|
(channel-put ch 'x)
|
|
(force p) => 99
|
|
(format "~a" p) => "#<promise!99>")))
|
|
|
|
(provide promise-tests)
|
|
(define (promise-tests)
|
|
(test do (test-syntax)
|
|
do (test-types)
|
|
do (test-basic-promises)
|
|
do (test-basic-promise-behavior)
|
|
do (test-printout)
|
|
do (test-delay/name)
|
|
do (test-delay/strict)
|
|
do (test-delay/sync)
|
|
do (test-delay/thread)
|
|
;; misc tests
|
|
(let ([x (lazy (delay 1))]) (force x) (force x)) => 1
|
|
))
|