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