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

revise generator names in for.ss

Browse Source 
svn: r6329
This commit is contained in:
Matthew Flatt 2007-05-26 00:52:55 +00:00
parent 5cd9016cc1
commit 4074eb593a
1 changed files with 147 additions and 149 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

296
collects/mzlib/for.ss
View File

@ -9,55 +9,55 @@
first-for first-for-values first-for* first-for*-values first-for first-for-values first-for* first-for*-values
last-for last-for-values last-for* last-for*-values last-for last-for-values last-for* last-for*-values
(rename *range range) (rename *in-range in-range)
(rename *nat-gen nat-gen) (rename *in-nats in-nats)
(rename *list->gen list->gen) (rename *in-list in-list)
(rename *vector->gen vector->gen) (rename *in-vector in-vector)
(rename *string->gen string->gen) (rename *in-string in-string)
(rename *bytes->gen bytes->gen) (rename *in-bytes in-bytes)
input-port->byte-gen in-input-port-bytes
input-port->char-gen in-input-port-chars
parallel-gen in-parallel
stop-before-gen stop-before
stop-after-gen stop-after
(rename *index-gen index-gen) (rename *in-indexed in-indexed)
generator-run sequence-run
define-generator-syntax define-sequence-syntax
make-do-generator make-do-sequence
:do-gen) :do-gen)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; generator transformers: ;; sequence transformers:
(begin-for-syntax (begin-for-syntax
(define-values (struct:generator-transformer (define-values (struct:sequence-transformer
make-generator-transformer make-sequence-transformer
generator-transformer? sequence-transformer?
generator-transformer-ref sequence-transformer-ref
generator-transformer-set!) sequence-transformer-set!)
(make-struct-type 'generator-transformer #f (make-struct-type 'sequence-transformer #f
3 0 #f 3 0 #f
null (current-inspector) null (current-inspector)
0)) 0))
(define (create-generator-transformer proc1 proc2 cert) (define (create-sequence-transformer proc1 proc2 cert)
(unless (if (identifier? proc1) (unless (if (identifier? proc1)
(and (procedure? proc1) (and (procedure? proc1)
(procedure-arity-includes? proc1 1)) (procedure-arity-includes? proc1 1))
(raise-type-error 'define-generator-syntax (raise-type-error 'define-sequence-syntax
"identifier of procedure (arity 1)" "identifier of procedure (arity 1)"
0 0
proc1 proc2)) proc1 proc2))
(unless (and (procedure? proc2) (unless (and (procedure? proc2)
(procedure-arity-includes? proc2 2)) (procedure-arity-includes? proc2 2))
(raise-type-error 'define-generator-syntax (raise-type-error 'define-sequence-syntax
"procedure (arity 1)" "procedure (arity 1)"
1 1
proc1 proc2)) proc1 proc2))
(make-generator-transformer (if (identifier? proc1) (make-sequence-transformer (if (identifier? proc1)
(lambda (stx) (lambda (stx)
(if (identifier? stx) (if (identifier? stx)
proc1 proc1
@ -115,7 +115,7 @@
(define (expand-clause orig-stx clause) (define (expand-clause orig-stx clause)
(let eloop ([use-transformer? #t]) (let eloop ([use-transformer? #t])
(syntax-case clause (values parallel-gen stop-before-gen stop-after-gen :do-gen) (syntax-case clause (values in-parallel stop-before stop-after :do-gen)
[[(id ...) rhs] [[(id ...) rhs]
(let ([ids (syntax->list #'(id ...))]) (let ([ids (syntax->list #'(id ...))])
(for-each (lambda (id) (for-each (lambda (id)
@ -130,7 +130,7 @@
(when dup (when dup
(raise-syntax-error (raise-syntax-error
#f #f
"duplicate identifier as generator binding" "duplicate identifier as sequence binding"
orig-stx orig-stx
dup))) dup)))
#f) #f)
@ -138,11 +138,11 @@
[[(id ...) (form . rest)] [[(id ...) (form . rest)]
(and use-transformer? (and use-transformer?
(identifier? #'form) (identifier? #'form)
(generator-transformer? (syntax-local-value #'form (lambda () #f)))) (sequence-transformer? (syntax-local-value #'form (lambda () #f))))
(let ([m (syntax-local-value #'form)]) (let ([m (syntax-local-value #'form)])
(let ([xformer (generator-transformer-ref m 1)] (let ([xformer (sequence-transformer-ref m 1)]
[introducer (make-syntax-introducer)] [introducer (make-syntax-introducer)]
[certifier (generator-transformer-ref m 2)]) [certifier (sequence-transformer-ref m 2)])
(let ([xformed (xformer orig-stx (introducer (syntax-local-introduce clause)))]) (let ([xformed (xformer orig-stx (introducer (syntax-local-introduce clause)))])
(if xformed (if xformed
(expand-clause orig-stx (certify-clause (syntax-local-introduce (introducer xformed)) (expand-clause orig-stx (certify-clause (syntax-local-introduce (introducer xformed))
@ -162,10 +162,10 @@
[else (raise-syntax-error #f "bad :do-gen clause" orig-stx clause)])] [else (raise-syntax-error #f "bad :do-gen clause" orig-stx clause)])]
[[(id) (values rhs)] [[(id) (values rhs)]
(expand-clause orig-stx #'[(id) rhs])] (expand-clause orig-stx #'[(id) rhs])]
[[(id ...) (parallel-gen rhs ...)] [[(id ...) (in-parallel rhs ...)]
(and (= (length (syntax->list #'(id ...))) (and (= (length (syntax->list #'(id ...)))
(length (syntax->list #'(rhs ...))))) (length (syntax->list #'(rhs ...)))))
;; flatten parallel-gen iterations: ;; flatten in-parallel iterations:
(with-syntax ([(((outer-binding ...) (with-syntax ([(((outer-binding ...)
outer-check outer-check
(loop-binding ...) (loop-binding ...)
@ -186,7 +186,7 @@
(and pre-guard ...) (and pre-guard ...)
(and post-guard ...) (and post-guard ...)
(loop-arg ... ...)))] (loop-arg ... ...)))]
[[(id ...) (stop-before-gen gen-expr pred)] [[(id ...) (stop-before gen-expr pred)]
(with-syntax ([((outer-binding ...) (with-syntax ([((outer-binding ...)
outer-check outer-check
(loop-binding ...) (loop-binding ...)
@ -204,7 +204,7 @@
(and pre-guard (not (pred id ...))) (and pre-guard (not (pred id ...)))
post-guard post-guard
(loop-arg ...)))] (loop-arg ...)))]
[[(id ...) (stop-after-gen gen-expr pred)] [[(id ...) (stop-after gen-expr pred)]
(with-syntax ([((outer-binding ...) (with-syntax ([((outer-binding ...)
outer-check outer-check
(loop-binding ...) (loop-binding ...)
@ -228,7 +228,7 @@
(syntax-local-introduce (syntax-local-introduce
(introducer (introducer
#`(([(pos->vals pos-next init pos-cont? val-cont? all-cont?) #`(([(pos->vals pos-next init pos-cont? val-cont? all-cont?)
(#,((syntax-local-certifier #f) #'make-generator) '(id ...) rhs)]) (#,((syntax-local-certifier #f) #'make-sequence) '(id ...) rhs)])
(void) (void)
([pos init]) ([pos init])
(pos-cont? pos) (pos-cont? pos)
@ -239,7 +239,7 @@
[_else [_else
(raise-syntax-error (raise-syntax-error
#f #f
"bad generator binding clause" "bad sequence binding clause"
orig-stx orig-stx
clause)])))) clause)]))))
@ -247,48 +247,48 @@
(raise-syntax-error #f "illegal outside of a loop or comprehension binding" stx)) (raise-syntax-error #f "illegal outside of a loop or comprehension binding" stx))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; generators ;; sequences
(define-values (prop:generator :generator? :generator-ref) (define-values (prop:sequence :sequence? :sequence-ref)
(make-struct-type-property 'generator (make-struct-type-property 'sequence
(lambda (v sinfo) (lambda (v sinfo)
(unless (and (procedure? v) (unless (and (procedure? v)
(procedure-arity-includes? v 1)) (procedure-arity-includes? v 1))
(raise-type-error (raise-type-error
'generator-property-guard 'sequence-property-guard
"procedure (arity 1)" "procedure (arity 1)"
v)) v))
v))) v)))
(define-values (struct:do-generator (define-values (struct:do-sequence
make-do-generator make-do-sequence
do-generator? do-sequence?
do-generator-ref do-sequence-ref
do-generator-set!) do-sequence-set!)
(make-struct-type 'generator #f (make-struct-type 'sequence #f
1 0 #f 1 0 #f
(list (cons prop:generator (lambda (v) (list (cons prop:sequence (lambda (v)
((do-generator-ref v 0))))))) ((do-sequence-ref v 0)))))))
(define-syntax define-generator-syntax (define-syntax define-sequence-syntax
(syntax-rules () (syntax-rules ()
[(_ id expr-transformer-expr clause-transformer-expr) [(_ id expr-transformer-expr clause-transformer-expr)
(define-syntax id (create-generator-transformer (define-syntax id (create-sequence-transformer
expr-transformer-expr expr-transformer-expr
clause-transformer-expr clause-transformer-expr
(syntax-local-certifier #f)))])) (syntax-local-certifier #f)))]))
(define (generator? v) (define (sequence? v)
(or (:generator? v) (or (:sequence? v)
(list? v) (list? v)
(vector? v) (vector? v)
(string? v) (string? v)
(bytes? v) (bytes? v)
(input-port? v))) (input-port? v)))
(define (make-generator who v) (define (make-sequence who v)
(cond (cond
[(:generator? v) ((:generator-ref v) v)] [(:sequence? v) ((:sequence-ref v) v)]
[(list? v) (:list-gen v)] [(list? v) (:list-gen v)]
[(vector? v) (:vector-gen v)] [(vector? v) (:vector-gen v)]
[(string? v) (:string-gen v)] [(string? v) (:string-gen v)]
@ -296,22 +296,22 @@
[(input-port? v) (:input-port-gen v)] [(input-port? v) (:input-port-gen v)]
[else (raise [else (raise
(make-exn:fail:contract (make-exn:fail:contract
(format "for: expected a generator for ~a, got something else: ~v" (format "for: expected a sequence for ~a, got something else: ~v"
(if (= 1 (length who)) (if (= 1 (length who))
(car who) (car who)
who) who)
v) v)
(current-continuation-marks)))])) (current-continuation-marks)))]))
(define range (define in-range
(case-lambda (case-lambda
[(b) (range 0 b 1)] [(b) (in-range 0 b 1)]
[(a b) (range a b 1)] [(a b) (in-range a b 1)]
[(a b step) [(a b step)
(unless (real? a) (raise-type-error 'range "real-number" a)) (unless (real? a) (raise-type-error 'in-range "real-number" a))
(unless (real? b) (raise-type-error 'range "real-number" b)) (unless (real? b) (raise-type-error 'in-range "real-number" b))
(unless (real? step) (raise-type-error 'range "real-number" step)) (unless (real? step) (raise-type-error 'in-range "real-number" step))
(make-do-generator (lambda () (make-do-sequence (lambda ()
(values (values
(lambda (x) x) (lambda (x) x)
(lambda (x) (+ x step)) (lambda (x) (+ x step))
@ -322,8 +322,8 @@
(lambda (x) #t) (lambda (x) #t)
(lambda (x y) #t))))])) (lambda (x y) #t))))]))
(define (nat-gen) (define (in-nats)
(make-do-generator (lambda () (make-do-sequence (lambda ()
(values values (values values
add1 add1
0 0
@ -331,16 +331,16 @@
(lambda (x) #t) (lambda (x) #t)
(lambda (x y) #t))))) (lambda (x y) #t)))))
(define (list->gen l) (define (in-list l)
(unless (list? l) (raise-type-error 'list->gen "list" l)) (unless (list? l) (raise-type-error 'in-list "list" l))
(make-do-generator (lambda () (:list-gen l)))) (make-do-sequence (lambda () (:list-gen l))))
(define (:list-gen l) (define (:list-gen l)
(values car cdr l pair? (lambda (x) #t) (lambda (p x) #t))) (values car cdr l pair? (lambda (x) #t) (lambda (p x) #t)))
(define (vector->gen l) (define (in-vector l)
(unless (vector? l) (raise-type-error 'vector->gen "vector" l)) (unless (vector? l) (raise-type-error 'in-vector "vector" l))
(make-do-generator (lambda () (:vector-gen l)))) (make-do-sequence (lambda () (:vector-gen l))))
(define (:vector-gen v) (define (:vector-gen v)
(let ([len (vector-length v)]) (let ([len (vector-length v)])
@ -352,9 +352,9 @@
(lambda (x) #t) (lambda (x) #t)
(lambda (x y) #t)))) (lambda (x y) #t))))
(define (string->gen l) (define (in-string l)
(unless (string? l) (raise-type-error 'string->gen "string" l)) (unless (string? l) (raise-type-error 'in-string "string" l))
(make-do-generator (lambda () (:string-gen l)))) (make-do-sequence (lambda () (:string-gen l))))
(define (:string-gen v) (define (:string-gen v)
(let ([len (string-length v)]) (let ([len (string-length v)])
@ -366,9 +366,9 @@
(lambda (x) #t) (lambda (x) #t)
(lambda (x y) #t)))) (lambda (x y) #t))))
(define (bytes->gen l) (define (in-bytes l)
(unless (bytes? l) (raise-type-error 'bytes->gen "bytes" l)) (unless (bytes? l) (raise-type-error 'in-bytes "bytes" l))
(make-do-generator (lambda () (:bytes-gen l)))) (make-do-sequence (lambda () (:bytes-gen l))))
(define (:bytes-gen v) (define (:bytes-gen v)
(let ([len (bytes-length v)]) (let ([len (bytes-length v)])
@ -380,9 +380,9 @@
(lambda (x) #t) (lambda (x) #t)
(lambda (x y) #t)))) (lambda (x y) #t))))
(define (input-port->byte-gen l) (define (in-input-port-bytes l)
(unless (input-port? l) (raise-type-error 'input-port->byte-gen "input-port" l)) (unless (input-port? l) (raise-type-error 'in-input-port-bytes "input-port" l))
(make-do-generator (lambda () (:input-port-gen l)))) (make-do-sequence (lambda () (:input-port-gen l))))
(define (:input-port-gen v) (define (:input-port-gen v)
(values (lambda (v) (read-byte v)) (values (lambda (v) (read-byte v))
@ -392,9 +392,9 @@
(lambda (x) (not (eof-object? x))) (lambda (x) (not (eof-object? x)))
(lambda (x v) #t))) (lambda (x v) #t)))
(define (input-port->char-gen v) (define (in-input-port-chars v)
(unless (input-port? v) (raise-type-error 'input-port->char-gen "input-port" v)) (unless (input-port? v) (raise-type-error 'in-input-port-chars "input-port" v))
(make-do-generator (lambda () (make-do-sequence (lambda ()
(values (lambda (v) (read-char v)) (values (lambda (v) (read-char v))
(lambda (v) v) (lambda (v) v)
v v
@ -402,14 +402,14 @@
(lambda (x) (not (eof-object? x))) (lambda (x) (not (eof-object? x)))
(lambda (x v) #t))))) (lambda (x v) #t)))))
(define (stop-before-gen g pred) (define (stop-before g pred)
(unless (generator? g) (raise-type-error 'stop-before-gen "generator" g)) (unless (sequence? g) (raise-type-error 'stop-before "sequence" g))
(unless (and (procedure? pred) (unless (and (procedure? pred)
(procedure-arity-includes? pred 1)) (procedure-arity-includes? pred 1))
(raise-type-error 'stop-before-gen "procedure (arity 1)" pred)) (raise-type-error 'stop-before "procedure (arity 1)" pred))
(make-do-generator (lambda () (make-do-sequence (lambda ()
(let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?) (let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?)
(make-generator #f g)]) (make-sequence #f g)])
(values pos->val (values pos->val
pos-next pos-next
init init
@ -421,14 +421,14 @@
(not (apply pred vals)))]) (not (apply pred vals)))])
post-cont?))))) post-cont?)))))
(define (stop-after-gen g pred) (define (stop-after g pred)
(unless (generator? g) (raise-type-error 'stop-after-gen "generator" g)) (unless (sequence? g) (raise-type-error 'stop-after "sequence" g))
(unless (and (procedure? pred) (unless (and (procedure? pred)
(procedure-arity-includes? pred 1)) (procedure-arity-includes? pred 1))
(raise-type-error 'stop-after-gen "procedure (arity 1)" pred)) (raise-type-error 'stop-after "procedure (arity 1)" pred))
(make-do-generator (lambda () (make-do-sequence (lambda ()
(let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?) (let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?)
(make-generator #f g)]) (make-sequence #f g)])
(values pos->val (values pos->val
pos-next pos-next
init init
@ -440,11 +440,11 @@
[(pos . vals) (and (apply pos-cont? pos vals) [(pos . vals) (and (apply pos-cont? pos vals)
(not (apply pred vals)))])))))) (not (apply pred vals)))]))))))
(define (index-gen g) (define (in-indexed g)
(unless (generator? g) (raise-type-error 'index-gen "generator" g)) (unless (sequence? g) (raise-type-error 'in-indexed "sequence" g))
(make-do-generator (lambda () (make-do-sequence (lambda ()
(let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?) (let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?)
(make-generator #f g)]) (make-sequence #f g)])
(values (lambda (pos) (values (pos->val (car pos)) (cdr pos))) (values (lambda (pos) (values (pos->val (car pos)) (cdr pos)))
(lambda (pos) (cons (pos-next (car pos)) (add1 (cdr pos)))) (lambda (pos) (cons (pos-next (car pos)) (add1 (cdr pos))))
(cons init 0) (cons init 0)
@ -454,18 +454,18 @@
;; ---------------------------------------- ;; ----------------------------------------
(define (parallel-gen . generators) (define (in-parallel . sequences)
(for-each (lambda (g) (for-each (lambda (g)
(unless (generator? g) (unless (sequence? g)
(raise-type-error 'parallel-gen "generator" g))) (raise-type-error 'in-parallel "sequence" g)))
generators) sequences)
(if (= 1 (length generators)) (if (= 1 (length sequences))
(car generators) (car sequences)
(make-do-generator (make-do-sequence
(lambda () (lambda ()
(let-values ([(pos->vals pos-nexts inits pos-cont?s pre-cont?s post-cont?s) (let-values ([(pos->vals pos-nexts inits pos-cont?s pre-cont?s post-cont?s)
(lists-for (p->v p-s i ps? pr? po?) ([g generators]) (lists-for (p->v p-s i ps? pr? po?) ([g sequences])
(make-generator #f g))]) (make-sequence #f g))])
(values (values
(lambda (poses) (apply values (map (lambda (pos->val pos) (pos->val pos)) (lambda (poses) (apply values (map (lambda (pos->val pos) (pos->val pos))
pos->vals pos->vals
@ -486,19 +486,19 @@
vals)))))))) vals))))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; runnign generators outside of a loop: ;; runnign sequences outside of a loop:
(define (generator-run g) (define (sequence-run g)
(unless (generator? g) (unless (sequence? g)
(raise-type-error 'generator-run "generator" g)) (raise-type-error 'sequence-run "sequence" g))
(let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?) (let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?)
(make-generator #f g)]) (make-sequence #f g)])
(let ([pos init]) (let ([pos init])
(letrec ([more? #f] (letrec ([more? #f]
[prep-val! #f] [prep-val! #f]
[next #f]) [next #f])
(letrec ([no-more (lambda () (letrec ([no-more (lambda ()
(error "generator has no more values"))] (error "sequence has no more values"))]
[init-more? [init-more?
(lambda () (prep-val!) (more?))] (lambda () (prep-val!) (more?))]
[init-next [init-next
@ -539,10 +539,10 @@
(set! more? init-more?) (set! more? init-more?)
(set! prep-val! init-prep-val!) (set! prep-val! init-prep-val!)
(set! next init-next) (set! next init-next)
(let ([generator-more? (lambda () (more?))] (let ([sequence-more? (lambda () (more?))]
[generator-next (lambda () (next))]) [sequence-next (lambda () (next))])
(values generator-more? (values sequence-more?
generator-next))))))) sequence-next)))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; core `fold-for' syntax ;; core `fold-for' syntax
@ -588,12 +588,12 @@
[(_ [orig-stx . _rest] fold-bind ()) [(_ [orig-stx . _rest] fold-bind ())
(raise-syntax-error (raise-syntax-error
#f #f
"missing body expression after generator bindings" "missing body expression after sequence bindings"
#'orig-stx)] #'orig-stx)]
[(_ [orig-stx . _rest] fold-bind () . rest) [(_ [orig-stx . _rest] fold-bind () . rest)
(raise-syntax-error (raise-syntax-error
#f #f
"bad syntax (illegal use of `.') after generator bindings" "bad syntax (illegal use of `.') after sequence bindings"
#'orig-stx)] #'orig-stx)]
;; Guard case, no pending emits: ;; Guard case, no pending emits:
[(_ [orig-stx multi? first-multi? nested? #f ()] ([fold-var fold-init] ...) (#:when expr . rest) . body) [(_ [orig-stx multi? first-multi? nested? #f ()] ([fold-var fold-init] ...) (#:when expr . rest) . body)
@ -611,7 +611,7 @@
[(_ [orig-stx #f #f nested? #f binds] fold-bind (clause . rest) . body) [(_ [orig-stx #f #f nested? #f binds] fold-bind (clause . rest) . body)
(raise-syntax-error (raise-syntax-error
#f #f
"bad generator binding clause" "bad sequence binding clause"
#'orig-stx #'orig-stx
#'clause)] #'clause)]
;; Expand one multi-value clause, and push it into the results to emit: ;; Expand one multi-value clause, and push it into the results to emit:
@ -745,19 +745,19 @@
(define-for-variants (and-for and-for-values and-for* and-for*-values) (define-for-variants (and-for and-for-values and-for* and-for*-values)
([result #t]) ([result #t])
(lambda (x) x) (lambda (x) x)
(lambda (rhs) #`(stop-after-gen #,rhs (lambda x (not result)))) (lambda (rhs) #`(stop-after #,rhs (lambda x (not result))))
(lambda (x) x)) (lambda (x) x))
(define-for-variants (or-for or-for-values or-for* or-for*-values) (define-for-variants (or-for or-for-values or-for* or-for*-values)
([result #f]) ([result #f])
(lambda (x) x) (lambda (x) x)
(lambda (rhs) #`(stop-after-gen #,rhs (lambda x result))) (lambda (rhs) #`(stop-after #,rhs (lambda x result)))
(lambda (x) x)) (lambda (x) x))
(define-for-variants (first-for first-for-values first-for* first-for*-values) (define-for-variants (first-for first-for-values first-for* first-for*-values)
([val #f][stop? #f]) ([val #f][stop? #f])
(lambda (x) #`(let-values ([(val _) #,x]) val)) (lambda (x) #`(let-values ([(val _) #,x]) val))
(lambda (rhs) #`(stop-after-gen #,rhs (lambda x stop?))) (lambda (rhs) #`(stop-after #,rhs (lambda x stop?)))
(lambda (x) #`(values #,x #t))) (lambda (x) #`(values #,x #t)))
(define-for-variants (last-for last-for-values last-for* last-for*-values) (define-for-variants (last-for last-for-values last-for* last-for*-values)
@ -767,10 +767,10 @@
(lambda (x) x)) (lambda (x) x))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; specific generators ;; specific sequences
(define-generator-syntax *range (define-sequence-syntax *in-range
#'range #'in-range
(lambda (orig-stx stx) (lambda (orig-stx stx)
(let loop ([stx stx]) (let loop ([stx stx])
(syntax-case stx () (syntax-case stx ()
@ -779,11 +779,9 @@
;; outer bindings: ;; outer bindings:
([(start) a] [(end) b] [(inc) step]) ([(start) a] [(end) b] [(inc) step])
;; outer check: ;; outer check:
(void)
#;
(unless (and (real? a) (real? b) (real? inc)) (unless (and (real? a) (real? b) (real? inc))
;; let `range' report the error: ;; let `in-range' report the error:
(range start end inc)) (in-range start end inc))
;; loop bindings: ;; loop bindings:
([pos start]) ([pos start])
;; pos check ;; pos check
@ -806,8 +804,8 @@
[[(id) (_ b)] (loop #'[(id) (_ 0 b 1)])] [[(id) (_ b)] (loop #'[(id) (_ 0 b 1)])]
[_else #f])))) [_else #f]))))
(define-generator-syntax *nat-gen (define-sequence-syntax *in-nats
#'nat-gen #'in-nats
(lambda (orig-stx stx) (lambda (orig-stx stx)
(syntax-case stx () (syntax-case stx ()
[[(id) (_)] #`[(id) [[(id) (_)] #`[(id)
@ -830,8 +828,8 @@
((+ pos 1)))]] ((+ pos 1)))]]
[_else #f]))) [_else #f])))
(define-generator-syntax *list->gen (define-sequence-syntax *in-list
#'list->gen #'in-list
(lambda (orig-stx stx) (lambda (orig-stx stx)
(syntax-case stx () (syntax-case stx ()
[((id) (_ lst-expr)) [((id) (_ lst-expr))
@ -840,7 +838,7 @@
;;outer bindings ;;outer bindings
([(lst) lst-expr]) ([(lst) lst-expr])
;; outer check ;; outer check
(unless (list? lst) (list->gen lst)) (unless (list? lst) (in-list lst))
;; loop bindings ;; loop bindings
([lst lst]) ([lst lst])
;; pos check ;; pos check
@ -857,11 +855,11 @@
(define-for-syntax (vector-like-gen vector?-id (define-for-syntax (vector-like-gen vector?-id
vector-length-id vector-length-id
vector->gen-id in-vector-id
vector-ref-id) vector-ref-id)
(lambda (orig-stx stx) (lambda (orig-stx stx)
(with-syntax ([vector? vector?-id] (with-syntax ([vector? vector?-id]
[vector->gen vector->gen-id] [in-vector in-vector-id]
[vector-length vector-length-id] [vector-length vector-length-id]
[vector-ref vector-ref-id]) [vector-ref vector-ref-id])
(syntax-case stx () (syntax-case stx ()
@ -871,7 +869,7 @@
;;outer bindings ;;outer bindings
([(vec len) (let ([vec vec-expr]) ([(vec len) (let ([vec vec-expr])
(unless (vector? vec) (unless (vector? vec)
(vector->gen vec)) (in-vector vec))
(values vec (vector-length vec)))]) (values vec (vector-length vec)))])
;; outer check ;; outer check
#f #f
@ -889,30 +887,30 @@
((add1 pos)))]] ((add1 pos)))]]
[_else #f])))) [_else #f]))))
(define-generator-syntax *vector->gen (define-sequence-syntax *in-vector
#'vector->gen #'in-vector
(vector-like-gen #'vector? (vector-like-gen #'vector?
#'vector-length #'vector-length
#'vector->gen #'in-vector
#'vector-ref)) #'vector-ref))
(define-generator-syntax *string->gen (define-sequence-syntax *in-string
#'string->gen #'in-string
(vector-like-gen #'string? (vector-like-gen #'string?
#'string-length #'string-length
#'string->gen #'in-string
#'string-ref)) #'string-ref))
(define-generator-syntax *bytes->gen (define-sequence-syntax *in-bytes
#'bytes->gen #'in-bytes
(vector-like-gen #'bytes? (vector-like-gen #'bytes?
#'bytes-length #'bytes-length
#'bytes->gen #'in-bytes
#'bytes-ref)) #'bytes-ref))
(define-generator-syntax *index-gen (define-sequence-syntax *in-indexed
#'index-gen #'in-indexed
(lambda (orig-stx stx) (lambda (orig-stx stx)
(syntax-case stx () (syntax-case stx ()
[((id1 id2) (_ gen-expr)) [((id1 id2) (_ gen-expr))
#'[(id1 id2) (parallel-gen gen-expr (*nat-gen))]])))) #'[(id1 id2) (in-parallel gen-expr (*in-nats))]]))))