From ec9fc2571ab947034e346cd4f1b59bfc8dbf01a5 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 27 Aug 2009 09:15:52 +0000 Subject: [PATCH] Added `in-producer'. (Note that `test-generator' tests use quasiquote for the expected result). svn: r15811 --- collects/scheme/private/for.ss | 75 ++++++++++++++++++- .../scribblings/reference/sequences.scrbl | 10 +++ collects/tests/mzscheme/for.ss | 64 +++++++++------- 3 files changed, 123 insertions(+), 26 deletions(-) diff --git a/collects/scheme/private/for.ss b/collects/scheme/private/for.ss index 7607d60a55..b644940001 100644 --- a/collects/scheme/private/for.ss +++ b/collects/scheme/private/for.ss @@ -43,6 +43,7 @@ in-parallel stop-before stop-after + (rename *in-producer in-producer) (rename *in-indexed in-indexed) (rename *in-value in-value) @@ -651,6 +652,22 @@ poses vals)))))))) + (define (in-producer producer stop . more) + (make-do-sequence + (lambda () + (values (if (null? more) + (lambda (_) (producer)) + (lambda (_) (apply producer more))) + void + (void) + void + (if (procedure? stop) + (if (equal? 1 (procedure-arity stop)) + (lambda (x) (not (stop x))) + (lambda xs (not (apply stop xs)))) + (lambda (x) (not (eq? x stop)))) + void)))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; running sequences outside of a loop: @@ -1138,4 +1155,60 @@ [((id) (_ expr)) #'[(id) (:do-in ([(id) expr]) - #t () #t () #t #f ())]])))) + #t () #t () #t #f ())]]))) + + (define-sequence-syntax *in-producer + (lambda () #'in-producer) + (lambda (stx) + (syntax-case stx () + [((id) (_ producer stop more ...)) + (with-syntax ([(more* ...) (generate-temporaries #'(more ...))]) + #'[(id) + (:do-in + ;;outer bindings + ([(producer*) producer] [(more*) more] ... + [(stop?) (let ([s stop]) + (if (procedure? s) s (lambda (x) (eq? x s))))]) + ;; outer check + #t + ;; loop bindings + () + ;; pos check + #t + ;; inner bindings + ([(id) (producer* more* ...)]) + ;; pre guard + (not (stop? id)) + ;; post guard + #t + ;; loop args + ())])] + ;; multiple-values version + [((id ...) (_ producer stop more ...)) + (with-syntax ([(more* ...) (generate-temporaries #'(more ...))]) + #'[(id ...) + (:do-in + ;;outer bindings + ([(producer*) producer] [(more*) more] ... + [(stop?) (let ([s stop]) + (if (procedure? s) + s + (error 'in-producer + "stop condition for ~a, got: ~e" + "multiple values must be a predicate" s)))]) + ;; outer check + #t + ;; loop bindings + () + ;; pos check + #t + ;; inner bindings + ([(id ...) (producer* more* ...)]) + ;; pre guard + (not (stop? id ...)) + ;; post guard + #t + ;; loop args + ())])]))) + + ) diff --git a/collects/scribblings/reference/sequences.scrbl b/collects/scribblings/reference/sequences.scrbl index 609c5c7ee6..692b9ea2a0 100644 --- a/collects/scribblings/reference/sequences.scrbl +++ b/collects/scribblings/reference/sequences.scrbl @@ -166,6 +166,16 @@ its value from @scheme[hash] (as opposed to using @scheme[hash] directly as a sequence to get the key and value as separate values for each element).} +@defproc[(in-producer [producer procedure?] [stop any/c] [args any/c] ...) + sequence]{ +Returns a sequence that contains values from sequential calls to +@scheme[producer]. @scheme[stop] identifies the value that marks the +end of the sequence --- this value is not included in the sequence. +@scheme[stop] can be a predicate or a value that is tested against the +results with @scheme[eq?]. Note that you must use a predicate function +if the stop value is itself a function, or if the @scheme[producer] +returns multiple values.} + @defproc[(in-value [v any/c]) sequence]{ Returns a sequence that produces a single value: @scheme[v]. This form is mostly useful for @scheme[let]-like bindings in forms such as diff --git a/collects/tests/mzscheme/for.ss b/collects/tests/mzscheme/for.ss index 6bd78d5129..a75e8b40c4 100644 --- a/collects/tests/mzscheme/for.ss +++ b/collects/tests/mzscheme/for.ss @@ -13,21 +13,21 @@ [((v2 ...) ...) (apply map list (map syntax->list (syntax->list #'((v ...) ...))))]) #'(begin - (test '((v2 ...) ...) 'gen (for/list ([(id ...) gen]) + (test `((v2 ...) ...) 'gen (for/list ([(id ...) gen]) (list id ...))) - (test-values '((v ...) ...) (lambda () + (test-values `((v ...) ...) (lambda () (for/lists (id2 ...) ([(id ...) gen]) (values id ...)))) (test #t 'gen (for/and ([(id ...) gen]) - (and (member (list id ...) '((v2 ...) ...)) #t))) + (and (member (list id ...) `((v2 ...) ...)) #t))) (test (list (for/last ([(id ...) gen]) (list id ...))) 'gen (for/and ([(id ...) gen]) - (member (list id ...) '((v2 ...) ...)))) + (member (list id ...) `((v2 ...) ...)))) (test (for/first ([(id ...) gen]) (list id ...)) 'gen (for/or ([(id ...) gen]) - (car (member (list id ...) '((v2 ...) ...))))) + (car (member (list id ...) `((v2 ...) ...))))) (void)))])) (define-syntax test-generator @@ -35,45 +35,45 @@ [(_ [seq] gen) ; we assume that seq has at least 2 elements, and all are unique (begin ;; Some tests specific to single-values: - (test 'seq 'gen (for/list ([i gen]) i)) - (test 'seq 'gen (for/list ([i gen][b gen]) i)) - (test 'seq 'gen (for/list ([i gen][b gen]) b)) - (test 'seq 'gen (for*/list ([i gen][b '(#t)]) i)) - (test (map (lambda (x) #t) 'seq) 'gen (for*/list ([i gen][b '(#t)]) b)) - (test (append 'seq 'seq) 'gen (for*/list ([b '(#f #t)][i gen]) i)) - (test (append 'seq 'seq) 'gen (for/list ([b '(#f #t)] #:when #t [i gen]) i)) - (test 'seq 'gen (let ([g gen]) (for/list ([i g]) i))) - (test 'seq 'gen (let ([r null]) + (test `seq 'gen (for/list ([i gen]) i)) + (test `seq 'gen (for/list ([i gen][b gen]) i)) + (test `seq 'gen (for/list ([i gen][b gen]) b)) + (test `seq 'gen (for*/list ([i gen][b '(#t)]) i)) + (test (map (lambda (x) #t) `seq) 'gen (for*/list ([i gen][b '(#t)]) b)) + (test (append `seq `seq) 'gen (for*/list ([b '(#f #t)][i gen]) i)) + (test (append `seq `seq) 'gen (for/list ([b '(#f #t)] #:when #t [i gen]) i)) + (test `seq 'gen (let ([g gen]) (for/list ([i g]) i))) + (test `seq 'gen (let ([r null]) (for ([i gen]) (set! r (cons i r))) (reverse r))) - (test 'seq 'gen (reverse (for/fold ([a null]) ([i gen]) + (test `seq 'gen (reverse (for/fold ([a null]) ([i gen]) (cons i a)))) - (test 'seq 'gen (let-values ([(more? next) (sequence-generate gen)]) + (test `seq 'gen (let-values ([(more? next) (sequence-generate gen)]) (let loop () (if (more?) (cons (next) (loop)) - null)))) - (test-values '(seq seq) (lambda () + null)))) + (test-values `(seq seq) (lambda () (for/lists (r1 r2) ([id gen]) (values id id)))) - (test (list (for/last ([i gen]) i)) 'gen (for/and ([i gen]) (member i 'seq))) - (test 'seq 'gen (for/or ([i gen]) (member i 'seq))) - (test (for/first ([i gen]) i) 'gen (for/or ([i gen]) (and (member i 'seq) i))) - (test #t 'gen (for/and ([(i k) (in-parallel gen 'seq)]) + (test (list (for/last ([i gen]) i)) 'gen (for/and ([i gen]) (member i `seq))) + (test `seq 'gen (for/or ([i gen]) (member i `seq))) + (test (for/first ([i gen]) i) 'gen (for/or ([i gen]) (and (member i `seq) i))) + (test #t 'gen (for/and ([(i k) (in-parallel gen `seq)]) (equal? i k))) (test #f 'gen (for/and ([i gen]) - (member i (cdr (reverse 'seq))))) + (member i (cdr (reverse `seq))))) (test #f 'gen (for/or ([i gen]) (equal? i 'something-else))) (let ([count 0]) (test #t 'or (for/or ([i gen]) (set! count (add1 count)) #t)) (test 1 'count count) (test #f 'or (for/or ([i gen]) (set! count (add1 count)) #f)) - (test (+ 1 (length 'seq)) 'count count) + (test (+ 1 (length `seq)) 'count count) (set! count 0) (let ([second (for/last ([(i pos) (in-parallel gen (in-naturals))] #:when (< pos 2)) (set! count (add1 count)) i)]) - (test second list-ref 'seq 1) + (test second list-ref `seq 1) (test 2 values count) (for ([i gen] #:when (equal? i second)) (set! count (add1 count))) (for* ([i gen] #:when (equal? i second)) (set! count (add1 count))) @@ -161,6 +161,20 @@ (test-generator [(a b c) (0 1 2)] (in-indexed '(a b c))) +(test-generator [(1 2 3 4 5)] + (parameterize ([current-input-port (open-input-string "1 2 3\n4 5")]) + (for/list ([i (in-producer read eof)]) i))) +(test-generator [(1 2 3 4 5)] + (for/list ([i (in-producer read eof (open-input-string "1 2 3\n4 5"))]) i)) +(test-generator [("1 2 3" "4 5")] + (for/list ([i (in-producer read-line eof-object? (open-input-string "1 2 3\n4 5"))]) i)) +(test-generator [((1 2) (3 4) (5 ,eof))] + (for/list ([(i j) + (in-producer (lambda (p) (values (read p) (read p))) + (lambda (x y) (and (eof-object? x) (eof-object? y))) + (open-input-string "1 2 3\n4 5"))]) + (list i j))) + (test #hash((a . 1) (b . 2) (c . 3)) 'mk-hash (for/hash ([v (in-naturals)] [k '(a b c)])