suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix force for dealing with (lazy 0), add a test suite (simple one for now)

Browse Source 
svn: r9180
This commit is contained in:
Eli Barzilay 2008-04-07 19:33:48 +00:00
parent 37e0416575
commit f0547adffc
3 changed files with 111 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
collects/scheme/promise.ss
View File

@ -86,45 +86,46 @@
;; * does not deal with multiple values, since they're not used by the lazy
;; language (but see below)
(define handle-results
(case-lambda
[(single) (values #f single)]
[multi (values #t multi)]))
(define (force-proc p root)
(define (return-vals vals)
;; error here for "library approach" (see above URL)
(set-promise-val! root vals)
(apply values vals))
(let loop1 ([p p])
(let-values ([(multi? v) (call-with-values p handle-results)])
(let-values ([(multi? v) (call-with-values p
(case-lambda [(single) (values #f single)]
[multi (values #t multi)]))])
(if multi?
(return-vals v)
(if (promise? v)
(let loop2 ([promise* v])
(let ([p* (promise-val promise*)])
(set-promise-val! promise* root) ; share with root
(cond [(procedure? p*) (loop1 p*)]
[(or (pair? p*) (null? p*)) (return-vals p*)]
[(promise? p*) (loop2 p*)]
[else p*])))
(return-vals
(if (or (null? v) (pair? v) (procedure? v)) (list v) v)))))))
(begin ; error here for "library approach" (see above URL)
(set-promise-val! root v)
(apply values v))
(if (promise? v)
(let loop2 ([promise* v])
(let ([p* (promise-val promise*)])
(set-promise-val! promise* root) ; share with root
(cond [(procedure? p*) (loop1 p*)]
[(promise? p*) (loop2 p*)]
[else (set-promise-val! root p*)
(cond [(null? p*) (values)]
[(not (pair? p*)) p*] ; is this needed?
[(null? (cdr p*)) (car p*)]
[else (apply values p*)])])))
(begin ; error here for "library approach" (see above URL)
(set-promise-val! root (list v))
v))))))
(define (force promise)
(if (promise? promise)
(let loop ([p (promise-val promise)])
(cond
[(procedure? p)
;; mark root for cycle detection:
(set-promise-val! promise running)
(with-handlers*
([void (lambda (e)
(set-promise-val! promise (lambda () (raise e)))
(raise e))])
(force-proc p promise))]
[(or (pair? p) (null? p)) (apply values p)]
[(promise? p) (loop (promise-val p))]
[else p]))
;; different from srfi-45: identity for non-promises
promise)))
(let loop ([p (promise-val promise)])
(cond
[(procedure? p)
;; mark root for cycle detection:
(set-promise-val! promise running)
(with-handlers* ([void (lambda (e)
(set-promise-val! promise
(lambda () (raise e)))
(raise e))])
(force-proc p promise))]
[(promise? p) (loop (promise-val p))]
[else (cond [(null? p) (values)]
[(not (pair? p)) p] ; is this needed?
[(null? (cdr p)) (car p)]
[else (apply values p)])]))
;; different from srfi-45: identity for non-promises
promise)))

73
collects/tests/mzscheme/promise.ss Normal file
View File

@ -0,0 +1,73 @@
(load-relative "loadtest.ss")
(Section 'promise)
(require scheme/promise)
;; check that things are `promise?'s or not
(for ([v (list 1 '(1) (lambda () 1))])
(test #f promise? v))
(for ([v (list (delay 1) (lazy 1) (delay (delay 1)) (lazy (lazy 1)))])
(test #t promise? v))
(let ()
(define thunk1 (lambda () 1))
;; test a few different values
(define-syntax (t stx)
(define _ (datum->syntax stx '_ stx))
(syntax-case stx ()
[(t (f x ...))
(with-syntax ([_ _])
#'(begin (let ([_ 1]) (test _ f x ...))
(let ([_ '()]) (test _ f x ...))
(let ([_ '(1)]) (test _ f x ...))
(let ([_ thunk1]) (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 _)))))))))
(report-errs)

1
collects/tests/mzscheme/scheme.ss
View File

@ -4,3 +4,4 @@
(load-relative "for.ss")
(load-relative "list.ss")
(load-relative "function.ss")
(load-relative "promise.ss")