From f0547adffcf2519b06ec61e2f8a57902a324e9c7 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 7 Apr 2008 19:33:48 +0000 Subject: [PATCH] fix force for dealing with (lazy 0), add a test suite (simple one for now) svn: r9180 --- collects/scheme/promise.ss | 73 +++++++++++++++--------------- collects/tests/mzscheme/promise.ss | 73 ++++++++++++++++++++++++++++++ collects/tests/mzscheme/scheme.ss | 1 + 3 files changed, 111 insertions(+), 36 deletions(-) create mode 100644 collects/tests/mzscheme/promise.ss diff --git a/collects/scheme/promise.ss b/collects/scheme/promise.ss index 5acfd7dd50..2a5f7f4f3d 100644 --- a/collects/scheme/promise.ss +++ b/collects/scheme/promise.ss @@ -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))) diff --git a/collects/tests/mzscheme/promise.ss b/collects/tests/mzscheme/promise.ss new file mode 100644 index 0000000000..a7611de434 --- /dev/null +++ b/collects/tests/mzscheme/promise.ss @@ -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) diff --git a/collects/tests/mzscheme/scheme.ss b/collects/tests/mzscheme/scheme.ss index 672407ab83..3535ca42fc 100644 --- a/collects/tests/mzscheme/scheme.ss +++ b/collects/tests/mzscheme/scheme.ss @@ -4,3 +4,4 @@ (load-relative "for.ss") (load-relative "list.ss") (load-relative "function.ss") +(load-relative "promise.ss")