Merge refactored code back into for.rkt, on Eli's advice
This commit is contained in:
Noel Welsh
parent
bd9368d889
commit
fba4d50289
|
|
@ -1,125 +0,0 @@
|
|||
(module for-base '#%kernel
|
||||
|
||||
(#%require "more-scheme.rkt"
|
||||
"misc.rkt"
|
||||
"define.rkt"
|
||||
"letstx-scheme.rkt"
|
||||
'#%unsafe
|
||||
(for-syntax '#%kernel
|
||||
"stx.rkt"
|
||||
"qqstx.rkt"
|
||||
"define.rkt"
|
||||
"small-scheme.rkt"
|
||||
"stxcase-scheme.rkt"))
|
||||
|
||||
(#%provide struct:do-sequence
|
||||
make-do-sequence
|
||||
do-sequence?
|
||||
do-sequence-ref
|
||||
do-sequence-set!
|
||||
|
||||
:do-in
|
||||
|
||||
prop:sequence
|
||||
|
||||
define-sequence-syntax
|
||||
|
||||
sequence?
|
||||
:sequence?
|
||||
:sequence-ref
|
||||
|
||||
(for-syntax struct:sequence-transformer
|
||||
make-sequence-transformer
|
||||
sequence-transformer?
|
||||
sequence-transformer-ref
|
||||
sequence-transformer-set!
|
||||
|
||||
create-sequence-transformer))
|
||||
|
||||
(begin-for-syntax
|
||||
(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-sequence-transformer proc1 proc2 cert)
|
||||
(unless (and (procedure? proc1)
|
||||
(or (procedure-arity-includes? proc1 1)
|
||||
(procedure-arity-includes? proc1 0)))
|
||||
(raise-type-error 'define-sequence-syntax
|
||||
"procedure (arity 0 or 1)"
|
||||
0
|
||||
proc1 proc2))
|
||||
(unless (and (procedure? proc2)
|
||||
(procedure-arity-includes? proc2 1))
|
||||
(raise-type-error 'define-sequence-syntax
|
||||
"procedure (arity 1)"
|
||||
1
|
||||
proc1 proc2))
|
||||
(make-sequence-transformer
|
||||
(if (procedure-arity-includes? proc1 0)
|
||||
(lambda (stx)
|
||||
(if (identifier? stx)
|
||||
(proc1)
|
||||
(datum->syntax stx
|
||||
#`(#,(proc1) . #,(cdr (syntax-e stx)))
|
||||
stx
|
||||
stx)))
|
||||
proc1)
|
||||
proc2
|
||||
cert))
|
||||
)
|
||||
|
||||
(define-syntax (:do-in stx)
|
||||
(raise-syntax-error #f
|
||||
"illegal outside of a loop or comprehension binding" stx))
|
||||
|
||||
(define-values (struct:do-sequence
|
||||
make-do-sequence
|
||||
do-sequence?
|
||||
do-sequence-ref
|
||||
do-sequence-set!)
|
||||
(make-struct-type 'sequence #f 1 0 #f))
|
||||
|
||||
(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 'sequence-property-guard "procedure (arity 1)" v))
|
||||
(lambda (self)
|
||||
(let ([s (v self)])
|
||||
(unless (sequence? s)
|
||||
(raise-mismatch-error
|
||||
'sequence-generate
|
||||
"procedure (value of prop:sequence) produced a non-sequence: "
|
||||
s))
|
||||
s)))))
|
||||
|
||||
(define-syntax define-sequence-syntax
|
||||
(syntax-rules ()
|
||||
[(_ id expr-transformer-expr clause-transformer-expr)
|
||||
(define-syntax id
|
||||
(create-sequence-transformer expr-transformer-expr
|
||||
clause-transformer-expr
|
||||
(syntax-local-certifier #f)))]))
|
||||
|
||||
(define (sequence? v)
|
||||
(or (do-sequence? v)
|
||||
(list? v)
|
||||
(mpair? v)
|
||||
(vector? v)
|
||||
(string? v)
|
||||
(bytes? v)
|
||||
(input-port? v)
|
||||
(hash? v)
|
||||
(and (:sequence? v) (not (struct-type? v)))))
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
|
@ -1,207 +0,0 @@
|
|||
;; Comprehensions for vector like data types
|
||||
(module for-vector '#%kernel
|
||||
|
||||
(#%require "more-scheme.rkt"
|
||||
"misc.rkt"
|
||||
"define.rkt"
|
||||
"letstx-scheme.rkt"
|
||||
"for-base.rkt"
|
||||
'#%unsafe
|
||||
(for-syntax '#%kernel
|
||||
"stx.rkt"
|
||||
"qqstx.rkt"
|
||||
"define.rkt"
|
||||
"small-scheme.rkt"
|
||||
"stxcase-scheme.rkt"))
|
||||
|
||||
(#%provide in-vector
|
||||
in-string
|
||||
in-bytes
|
||||
|
||||
:vector-gen
|
||||
:string-gen
|
||||
:bytes-gen
|
||||
|
||||
*in-vector
|
||||
*in-string
|
||||
*in-bytes
|
||||
|
||||
define-in-vector-like
|
||||
define-:vector-like-gen
|
||||
|
||||
(for-syntax make-in-vector-like))
|
||||
|
||||
;; (: check-ranges (Symbol Natural Natural Integer -> Void))
|
||||
(define (check-ranges who start stop step)
|
||||
(unless (exact-nonnegative-integer? start) (raise-type-error who "exact non-negative integer" start))
|
||||
(unless (exact-nonnegative-integer? stop) (raise-type-error who "exact non-negative integer or #f" stop))
|
||||
(unless (and (exact-integer? step) (not (zero? step)))
|
||||
(raise-type-error who "exact non-zero integer" step))
|
||||
(when (and (< start stop) (< step 0))
|
||||
(raise-mismatch-error who (format "start: ~a less than stop: ~a but given negative step: "
|
||||
start stop)
|
||||
step))
|
||||
(when (and (< stop start) (> step 0))
|
||||
(raise-mismatch-error who (format "start: ~a more than stop: ~a but given positive step: "
|
||||
start stop)
|
||||
step)))
|
||||
|
||||
(define-syntax define-in-vector-like
|
||||
(syntax-rules ()
|
||||
[(define-in-vector-like in-vector-name
|
||||
type-name-str vector?-id vector-length-id :vector-gen-id)
|
||||
(define in-vector-name
|
||||
(case-lambda
|
||||
[(v) (in-vector-name v 0 #f 1)]
|
||||
[(v start) (in-vector-name v start #f 1)]
|
||||
[(v start stop) (in-vector-name v start stop 1)]
|
||||
[(v start stop step)
|
||||
(unless (vector?-id v) (raise-type-error (quote in-vector-name) type-name-str v))
|
||||
(let ([stop (or stop (vector-length-id v))])
|
||||
(check-ranges (quote in-vector-name) start stop step)
|
||||
(make-do-sequence (lambda () (:vector-gen-id v start stop step))))]))]))
|
||||
|
||||
(define-syntax define-:vector-like-gen
|
||||
(syntax-rules ()
|
||||
[(define-:vector-like-gen :vector-like-name unsafe-vector-ref-id)
|
||||
(define (:vector-like-name v start stop step)
|
||||
(values
|
||||
;; pos->element
|
||||
(lambda (i) (unsafe-vector-ref-id v i))
|
||||
;; next-pos
|
||||
;; Minor optimisation. I assume add1 is faster than \x.x+1
|
||||
(if (= step 1) add1 (lambda (i) (+ i step)))
|
||||
;; initial pos
|
||||
start
|
||||
;; continue?
|
||||
(if (> step 0)
|
||||
(lambda (i) (< i stop))
|
||||
(lambda (i) (> i stop)))
|
||||
void
|
||||
void))]))
|
||||
|
||||
(define-for-syntax (make-in-vector-like vector?-id
|
||||
unsafe-vector-length-id
|
||||
in-vector-id
|
||||
unsafe-vector-ref-id)
|
||||
(define (in-vector-like stx)
|
||||
(with-syntax ([vector? vector?-id]
|
||||
[in-vector in-vector-id]
|
||||
[unsafe-vector-length unsafe-vector-length-id]
|
||||
[unsafe-vector-ref unsafe-vector-ref-id])
|
||||
(syntax-case stx ()
|
||||
;; Fast case
|
||||
[[(id) (_ vec-expr)]
|
||||
#'[(id)
|
||||
(:do-in
|
||||
;;outer bindings
|
||||
([(vec len) (let ([vec vec-expr])
|
||||
(unless (vector? vec)
|
||||
(in-vector vec))
|
||||
(values vec (unsafe-vector-length vec)))])
|
||||
;; outer check
|
||||
#f
|
||||
;; loop bindings
|
||||
([pos 0])
|
||||
;; pos check
|
||||
(pos . unsafe-fx< . len)
|
||||
;; inner bindings
|
||||
([(id) (unsafe-vector-ref vec pos)])
|
||||
;; pre guard
|
||||
#t
|
||||
;; post guard
|
||||
#t
|
||||
;; loop args
|
||||
((unsafe-fx+ 1 pos)))]]
|
||||
;; General case
|
||||
[((id) (_ vec-expr start))
|
||||
(in-vector-like (syntax ((id) (_ vec-expr start #f 1))))]
|
||||
[((id) (_ vec-expr start stop))
|
||||
(in-vector-like (syntax ((id) (_ vec-expr start stop 1))))]
|
||||
[((id) (_ vec-expr start stop step))
|
||||
(let ([all-fx? (memq (syntax-e #'step) '(1 -1))])
|
||||
#`[(id)
|
||||
(:do-in
|
||||
;; Outer bindings
|
||||
;; Prevent multiple evaluation
|
||||
([(v* stop*) (let ([vec vec-expr]
|
||||
[stop* stop])
|
||||
(if (and (not stop*) (vector? vec))
|
||||
(values vec (unsafe-vector-length vec))
|
||||
(values vec stop*)))]
|
||||
[(start*) start]
|
||||
[(step*) step])
|
||||
;; Outer check
|
||||
(when (or (not (vector? v*))
|
||||
(not (exact-integer? start*))
|
||||
(not (exact-integer? stop*))
|
||||
(not (exact-integer? step*))
|
||||
(zero? step*)
|
||||
(and (< start* stop*) (< step* 0))
|
||||
(and (> start* stop*) (> step* 0)))
|
||||
;; Let in-vector report the error
|
||||
(in-vector v* start* stop* step*))
|
||||
;; Loop bindings
|
||||
([idx start*])
|
||||
;; Pos guard
|
||||
#,(cond
|
||||
[(not (number? (syntax-e #'step)))
|
||||
#`(if (step* . >= . 0) (< idx stop*) (> idx stop*))]
|
||||
[((syntax-e #'step) . >= . 0)
|
||||
(if all-fx?
|
||||
#'(unsafe-fx< idx stop*)
|
||||
#'(< idx stop*))]
|
||||
[else
|
||||
(if all-fx?
|
||||
#'(unsafe-fx> idx stop*)
|
||||
#'(> idx stop*))])
|
||||
;; Inner bindings
|
||||
([(id) (unsafe-vector-ref v* idx)])
|
||||
;; Pre guard
|
||||
#t
|
||||
;; Post guard
|
||||
#t
|
||||
;; Loop args
|
||||
((#,(if all-fx? #'unsafe-fx+ #'+) idx step)))])]
|
||||
[_ #f])))
|
||||
in-vector-like)
|
||||
|
||||
(define-:vector-like-gen :vector-gen unsafe-vector-ref)
|
||||
|
||||
(define-in-vector-like in-vector
|
||||
"vector" vector? vector-length :vector-gen)
|
||||
|
||||
|
||||
(define-:vector-like-gen :string-gen unsafe-string-ref)
|
||||
|
||||
(define-in-vector-like in-string
|
||||
"string" string? string-length :string-gen)
|
||||
|
||||
|
||||
(define-:vector-like-gen :bytes-gen unsafe-bytes-ref)
|
||||
|
||||
(define-in-vector-like in-bytes
|
||||
"bytes" bytes? bytes-length :bytes-gen)
|
||||
|
||||
(define-sequence-syntax *in-vector
|
||||
(lambda () #'in-vector)
|
||||
(make-in-vector-like #'vector?
|
||||
#'unsafe-vector-length
|
||||
#'in-vector
|
||||
#'unsafe-vector-ref))
|
||||
|
||||
(define-sequence-syntax *in-string
|
||||
(lambda () #'in-string)
|
||||
(make-in-vector-like #'string?
|
||||
#'string-length
|
||||
#'in-string
|
||||
#'string-ref))
|
||||
|
||||
(define-sequence-syntax *in-bytes
|
||||
(lambda () #'in-bytes)
|
||||
(make-in-vector-like #'bytes?
|
||||
#'bytes-length
|
||||
#'in-bytes
|
||||
#'bytes-ref))
|
||||
|
||||
)
|
||||
|
|
@ -4,8 +4,6 @@
|
|||
"misc.rkt"
|
||||
"define.rkt"
|
||||
"letstx-scheme.rkt"
|
||||
"for-base.rkt"
|
||||
"for-vector.rkt"
|
||||
'#%unsafe
|
||||
(for-syntax '#%kernel
|
||||
"stx.rkt"
|
||||
|
|
@ -67,9 +65,44 @@
|
|||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; sequence transformers:
|
||||
|
||||
;; Mostly defined in for-base.rkt
|
||||
|
||||
(begin-for-syntax
|
||||
(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-sequence-transformer proc1 proc2 cert)
|
||||
(unless (and (procedure? proc1)
|
||||
(or (procedure-arity-includes? proc1 1)
|
||||
(procedure-arity-includes? proc1 0)))
|
||||
(raise-type-error 'define-sequence-syntax
|
||||
"procedure (arity 0 or 1)"
|
||||
0
|
||||
proc1 proc2))
|
||||
(unless (and (procedure? proc2)
|
||||
(procedure-arity-includes? proc2 1))
|
||||
(raise-type-error 'define-sequence-syntax
|
||||
"procedure (arity 1)"
|
||||
1
|
||||
proc1 proc2))
|
||||
(make-sequence-transformer
|
||||
(if (procedure-arity-includes? proc1 0)
|
||||
(lambda (stx)
|
||||
(if (identifier? stx)
|
||||
(proc1)
|
||||
(datum->syntax stx
|
||||
#`(#,(proc1) . #,(cdr (syntax-e stx)))
|
||||
stx
|
||||
stx)))
|
||||
proc1)
|
||||
proc2
|
||||
cert))
|
||||
|
||||
(define cert-key (gensym 'for-cert))
|
||||
|
||||
(define (certify-clause src-stx clause certifier introducer)
|
||||
|
|
@ -115,142 +148,186 @@
|
|||
;; ill-formed clause...
|
||||
clause]))
|
||||
|
||||
(define (expand-clause orig-stx clause)
|
||||
(let eloop ([use-transformer? #t])
|
||||
(syntax-case clause (values in-parallel stop-before stop-after :do-in)
|
||||
[[(id ...) rhs]
|
||||
(let ([ids (syntax->list #'(id ...))])
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier to bind"
|
||||
orig-stx
|
||||
id)))
|
||||
ids)
|
||||
(let ([dup (check-duplicate-identifier (syntax->list #'(id ...)))])
|
||||
(when dup
|
||||
(raise-syntax-error #f
|
||||
"duplicate identifier as sequence binding" orig-stx dup)))
|
||||
#f)
|
||||
'just-checking]
|
||||
[[(id ...) (form . rest)]
|
||||
(and use-transformer?
|
||||
(identifier? #'form)
|
||||
(sequence-transformer? (syntax-local-value #'form (lambda () #f))))
|
||||
(let ([m (syntax-local-value #'form)])
|
||||
(let ([xformer (sequence-transformer-ref m 1)]
|
||||
[introducer (make-syntax-introducer)]
|
||||
[certifier (sequence-transformer-ref m 2)])
|
||||
(let ([xformed (xformer (introducer (syntax-local-introduce clause)))])
|
||||
(if xformed
|
||||
(let ([r (expand-clause orig-stx
|
||||
(certify-clause (syntax-case clause ()
|
||||
[(_ rhs) #'rhs])
|
||||
(syntax-local-introduce (introducer xformed))
|
||||
certifier
|
||||
introducer))])
|
||||
(syntax-property r
|
||||
'disappeared-use
|
||||
(cons (syntax-local-introduce #'form)
|
||||
(or (syntax-property r 'disappeared-use)
|
||||
null))))
|
||||
(eloop #f)))))]
|
||||
[[(id ...) (:do-in . body)]
|
||||
(syntax-case #'body ()
|
||||
[(([(outer-id ...) outer-rhs] ...)
|
||||
(define (expand-clause orig-stx clause)
|
||||
(let eloop ([use-transformer? #t])
|
||||
(syntax-case clause (values in-parallel stop-before stop-after :do-in)
|
||||
[[(id ...) rhs]
|
||||
(let ([ids (syntax->list #'(id ...))])
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier to bind"
|
||||
orig-stx
|
||||
id)))
|
||||
ids)
|
||||
(let ([dup (check-duplicate-identifier (syntax->list #'(id ...)))])
|
||||
(when dup
|
||||
(raise-syntax-error #f
|
||||
"duplicate identifier as sequence binding" orig-stx dup)))
|
||||
#f)
|
||||
'just-checking]
|
||||
[[(id ...) (form . rest)]
|
||||
(and use-transformer?
|
||||
(identifier? #'form)
|
||||
(sequence-transformer? (syntax-local-value #'form (lambda () #f))))
|
||||
(let ([m (syntax-local-value #'form)])
|
||||
(let ([xformer (sequence-transformer-ref m 1)]
|
||||
[introducer (make-syntax-introducer)]
|
||||
[certifier (sequence-transformer-ref m 2)])
|
||||
(let ([xformed (xformer (introducer (syntax-local-introduce clause)))])
|
||||
(if xformed
|
||||
(let ([r (expand-clause orig-stx
|
||||
(certify-clause (syntax-case clause ()
|
||||
[(_ rhs) #'rhs])
|
||||
(syntax-local-introduce (introducer xformed))
|
||||
certifier
|
||||
introducer))])
|
||||
(syntax-property r
|
||||
'disappeared-use
|
||||
(cons (syntax-local-introduce #'form)
|
||||
(or (syntax-property r 'disappeared-use)
|
||||
null))))
|
||||
(eloop #f)))))]
|
||||
[[(id ...) (:do-in . body)]
|
||||
(syntax-case #'body ()
|
||||
[(([(outer-id ...) outer-rhs] ...)
|
||||
outer-check
|
||||
([loop-id loop-expr] ...)
|
||||
pos-guard
|
||||
([(inner-id ...) inner-rhs] ...)
|
||||
pre-guard
|
||||
post-guard
|
||||
(loop-arg ...)) #'body]
|
||||
[else (raise-syntax-error #f "bad :do-in clause" orig-stx clause)])]
|
||||
[[(id) (values rhs)]
|
||||
(expand-clause orig-stx #'[(id) rhs])]
|
||||
[[(id ...) (in-parallel rhs ...)]
|
||||
(and (= (length (syntax->list #'(id ...)))
|
||||
(length (syntax->list #'(rhs ...)))))
|
||||
;; flatten in-parallel iterations:
|
||||
(with-syntax ([(((outer-binding ...)
|
||||
outer-check
|
||||
(loop-binding ...)
|
||||
pos-guard
|
||||
(inner-binding ...)
|
||||
pre-guard
|
||||
post-guard
|
||||
(loop-arg ...)) ...)
|
||||
(map (lambda (id rhs)
|
||||
(expand-clause orig-stx #`[(#,id) #,rhs]))
|
||||
(syntax->list #'(id ...))
|
||||
(syntax->list #'(rhs ...)))])
|
||||
#`((outer-binding ... ...)
|
||||
(and outer-check ...)
|
||||
(loop-binding ... ...)
|
||||
(and pos-guard ...)
|
||||
(inner-binding ... ...)
|
||||
(and pre-guard ...)
|
||||
(and post-guard ...)
|
||||
(loop-arg ... ...)))]
|
||||
[[(id ...) (stop-before gen-expr pred)]
|
||||
(with-syntax ([((outer-binding ...)
|
||||
outer-check
|
||||
(loop-binding ...)
|
||||
pos-guard
|
||||
(inner-binding ...)
|
||||
pre-guard
|
||||
post-guard
|
||||
(loop-arg ...))
|
||||
(expand-clause orig-stx #`[(id ...) gen-expr])])
|
||||
#`((outer-binding ...)
|
||||
outer-check
|
||||
([loop-id loop-expr] ...)
|
||||
(loop-binding ...)
|
||||
pos-guard
|
||||
([(inner-id ...) inner-rhs] ...)
|
||||
pre-guard
|
||||
(inner-binding ...)
|
||||
(and pre-guard (not (pred id ...)))
|
||||
post-guard
|
||||
(loop-arg ...)) #'body]
|
||||
[else (raise-syntax-error #f "bad :do-in clause" orig-stx clause)])]
|
||||
[[(id) (values rhs)]
|
||||
(expand-clause orig-stx #'[(id) rhs])]
|
||||
[[(id ...) (in-parallel rhs ...)]
|
||||
(and (= (length (syntax->list #'(id ...)))
|
||||
(length (syntax->list #'(rhs ...)))))
|
||||
;; flatten in-parallel iterations:
|
||||
(with-syntax ([(((outer-binding ...)
|
||||
outer-check
|
||||
(loop-binding ...)
|
||||
pos-guard
|
||||
(inner-binding ...)
|
||||
pre-guard
|
||||
post-guard
|
||||
(loop-arg ...)) ...)
|
||||
(map (lambda (id rhs)
|
||||
(expand-clause orig-stx #`[(#,id) #,rhs]))
|
||||
(syntax->list #'(id ...))
|
||||
(syntax->list #'(rhs ...)))])
|
||||
#`((outer-binding ... ...)
|
||||
(and outer-check ...)
|
||||
(loop-binding ... ...)
|
||||
(and pos-guard ...)
|
||||
(inner-binding ... ...)
|
||||
(and pre-guard ...)
|
||||
(and post-guard ...)
|
||||
(loop-arg ... ...)))]
|
||||
[[(id ...) (stop-before gen-expr pred)]
|
||||
(with-syntax ([((outer-binding ...)
|
||||
outer-check
|
||||
(loop-binding ...)
|
||||
pos-guard
|
||||
(inner-binding ...)
|
||||
pre-guard
|
||||
post-guard
|
||||
(loop-arg ...))
|
||||
(expand-clause orig-stx #`[(id ...) gen-expr])])
|
||||
#`((outer-binding ...)
|
||||
outer-check
|
||||
(loop-binding ...)
|
||||
pos-guard
|
||||
(inner-binding ...)
|
||||
(and pre-guard (not (pred id ...)))
|
||||
post-guard
|
||||
(loop-arg ...)))]
|
||||
[[(id ...) (stop-after gen-expr pred)]
|
||||
(with-syntax ([((outer-binding ...)
|
||||
outer-check
|
||||
(loop-binding ...)
|
||||
pos-guard
|
||||
(inner-binding ...)
|
||||
pre-guard
|
||||
post-guard
|
||||
(loop-arg ...))
|
||||
(expand-clause orig-stx #`[(id ...) gen-expr])])
|
||||
#`((outer-binding ...)
|
||||
outer-check
|
||||
(loop-binding ...)
|
||||
pos-guard
|
||||
(inner-binding ...)
|
||||
pre-guard
|
||||
(and post-guard (not (pred id ...)))
|
||||
(loop-arg ...)))]
|
||||
[[(id ...) rhs]
|
||||
(let ([introducer (make-syntax-introducer)])
|
||||
(with-syntax ([[(id ...) rhs] (introducer (syntax-local-introduce clause))])
|
||||
(syntax-local-introduce
|
||||
(introducer
|
||||
#`(([(pos->vals pos-next init pos-cont? val-cont? all-cont?)
|
||||
(#,((syntax-local-certifier #f) #'make-sequence) '(id ...) rhs)])
|
||||
(void)
|
||||
([pos init])
|
||||
(pos-cont? pos)
|
||||
([(id ...) (pos->vals pos)])
|
||||
(val-cont? id ...)
|
||||
(all-cont? pos id ...)
|
||||
((pos-next pos)))))))]
|
||||
[_
|
||||
(raise-syntax-error #f
|
||||
"bad sequence binding clause" orig-stx clause)]))))
|
||||
(loop-arg ...)))]
|
||||
[[(id ...) (stop-after gen-expr pred)]
|
||||
(with-syntax ([((outer-binding ...)
|
||||
outer-check
|
||||
(loop-binding ...)
|
||||
pos-guard
|
||||
(inner-binding ...)
|
||||
pre-guard
|
||||
post-guard
|
||||
(loop-arg ...))
|
||||
(expand-clause orig-stx #`[(id ...) gen-expr])])
|
||||
#`((outer-binding ...)
|
||||
outer-check
|
||||
(loop-binding ...)
|
||||
pos-guard
|
||||
(inner-binding ...)
|
||||
pre-guard
|
||||
(and post-guard (not (pred id ...)))
|
||||
(loop-arg ...)))]
|
||||
[[(id ...) rhs]
|
||||
(let ([introducer (make-syntax-introducer)])
|
||||
(with-syntax ([[(id ...) rhs] (introducer (syntax-local-introduce clause))])
|
||||
(syntax-local-introduce
|
||||
(introducer
|
||||
#`(([(pos->vals pos-next init pos-cont? val-cont? all-cont?)
|
||||
(#,((syntax-local-certifier #f) #'make-sequence) '(id ...) rhs)])
|
||||
(void)
|
||||
([pos init])
|
||||
(pos-cont? pos)
|
||||
([(id ...) (pos->vals pos)])
|
||||
(val-cont? id ...)
|
||||
(all-cont? pos id ...)
|
||||
((pos-next pos)))))))]
|
||||
[_
|
||||
(raise-syntax-error #f
|
||||
"bad sequence binding clause" orig-stx clause)]))))
|
||||
|
||||
(define-syntax (:do-in stx)
|
||||
(raise-syntax-error #f
|
||||
"illegal outside of a loop or comprehension binding" stx))
|
||||
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; sequences
|
||||
|
||||
;; Also see for-base.rkt
|
||||
(define-values (struct:do-sequence
|
||||
make-do-sequence
|
||||
do-sequence?
|
||||
do-sequence-ref
|
||||
do-sequence-set!)
|
||||
(make-struct-type 'sequence #f 1 0 #f))
|
||||
|
||||
(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 'sequence-property-guard "procedure (arity 1)" v))
|
||||
(lambda (self)
|
||||
(let ([s (v self)])
|
||||
(unless (sequence? s)
|
||||
(raise-mismatch-error
|
||||
'sequence-generate
|
||||
"procedure (value of prop:sequence) produced a non-sequence: "
|
||||
s))
|
||||
s)))))
|
||||
|
||||
(define-syntax define-sequence-syntax
|
||||
(syntax-rules ()
|
||||
[(_ id expr-transformer-expr clause-transformer-expr)
|
||||
(define-syntax id
|
||||
(create-sequence-transformer expr-transformer-expr
|
||||
clause-transformer-expr
|
||||
(syntax-local-certifier #f)))]))
|
||||
|
||||
(define (sequence? v)
|
||||
(or (do-sequence? v)
|
||||
(list? v)
|
||||
(mpair? v)
|
||||
(vector? v)
|
||||
(string? v)
|
||||
(bytes? v)
|
||||
(input-port? v)
|
||||
(hash? v)
|
||||
(and (:sequence? v) (not (struct-type? v)))))
|
||||
|
||||
(define (make-sequence who v)
|
||||
(cond
|
||||
|
|
@ -397,6 +474,186 @@
|
|||
void
|
||||
void))
|
||||
|
||||
;; Vector-like sequences --------------------------------------------------
|
||||
|
||||
;; (: check-ranges (Symbol Natural Natural Integer -> Void))
|
||||
(define (check-ranges who start stop step)
|
||||
(unless (exact-nonnegative-integer? start) (raise-type-error who "exact non-negative integer" start))
|
||||
(unless (exact-nonnegative-integer? stop) (raise-type-error who "exact non-negative integer or #f" stop))
|
||||
(unless (and (exact-integer? step) (not (zero? step)))
|
||||
(raise-type-error who "exact non-zero integer" step))
|
||||
(when (and (< start stop) (< step 0))
|
||||
(raise-mismatch-error who (format "start: ~a less than stop: ~a but given negative step: "
|
||||
start stop)
|
||||
step))
|
||||
(when (and (< stop start) (> step 0))
|
||||
(raise-mismatch-error who (format "start: ~a more than stop: ~a but given positive step: "
|
||||
start stop)
|
||||
step)))
|
||||
|
||||
(define-syntax define-in-vector-like
|
||||
(syntax-rules ()
|
||||
[(define-in-vector-like in-vector-name
|
||||
type-name-str vector?-id vector-length-id :vector-gen-id)
|
||||
(define in-vector-name
|
||||
(case-lambda
|
||||
[(v) (in-vector-name v 0 #f 1)]
|
||||
[(v start) (in-vector-name v start #f 1)]
|
||||
[(v start stop) (in-vector-name v start stop 1)]
|
||||
[(v start stop step)
|
||||
(unless (vector?-id v) (raise-type-error (quote in-vector-name) type-name-str v))
|
||||
(let ([stop (or stop (vector-length-id v))])
|
||||
(check-ranges (quote in-vector-name) start stop step)
|
||||
(make-do-sequence (lambda () (:vector-gen-id v start stop step))))]))]))
|
||||
|
||||
(define-syntax define-:vector-like-gen
|
||||
(syntax-rules ()
|
||||
[(define-:vector-like-gen :vector-like-name unsafe-vector-ref-id)
|
||||
(define (:vector-like-name v start stop step)
|
||||
(values
|
||||
;; pos->element
|
||||
(lambda (i) (unsafe-vector-ref-id v i))
|
||||
;; next-pos
|
||||
;; Minor optimisation. I assume add1 is faster than \x.x+1
|
||||
(if (= step 1) add1 (lambda (i) (+ i step)))
|
||||
;; initial pos
|
||||
start
|
||||
;; continue?
|
||||
(if (> step 0)
|
||||
(lambda (i) (< i stop))
|
||||
(lambda (i) (> i stop)))
|
||||
void
|
||||
void))]))
|
||||
|
||||
(define-for-syntax (make-in-vector-like vector?-id
|
||||
unsafe-vector-length-id
|
||||
in-vector-id
|
||||
unsafe-vector-ref-id)
|
||||
(define (in-vector-like stx)
|
||||
(with-syntax ([vector? vector?-id]
|
||||
[in-vector in-vector-id]
|
||||
[unsafe-vector-length unsafe-vector-length-id]
|
||||
[unsafe-vector-ref unsafe-vector-ref-id])
|
||||
(syntax-case stx ()
|
||||
;; Fast case
|
||||
[[(id) (_ vec-expr)]
|
||||
#'[(id)
|
||||
(:do-in
|
||||
;;outer bindings
|
||||
([(vec len) (let ([vec vec-expr])
|
||||
(unless (vector? vec)
|
||||
(in-vector vec))
|
||||
(values vec (unsafe-vector-length vec)))])
|
||||
;; outer check
|
||||
#f
|
||||
;; loop bindings
|
||||
([pos 0])
|
||||
;; pos check
|
||||
(pos . unsafe-fx< . len)
|
||||
;; inner bindings
|
||||
([(id) (unsafe-vector-ref vec pos)])
|
||||
;; pre guard
|
||||
#t
|
||||
;; post guard
|
||||
#t
|
||||
;; loop args
|
||||
((unsafe-fx+ 1 pos)))]]
|
||||
;; General case
|
||||
[((id) (_ vec-expr start))
|
||||
(in-vector-like (syntax ((id) (_ vec-expr start #f 1))))]
|
||||
[((id) (_ vec-expr start stop))
|
||||
(in-vector-like (syntax ((id) (_ vec-expr start stop 1))))]
|
||||
[((id) (_ vec-expr start stop step))
|
||||
(let ([all-fx? (memq (syntax-e #'step) '(1 -1))])
|
||||
#`[(id)
|
||||
(:do-in
|
||||
;; Outer bindings
|
||||
;; Prevent multiple evaluation
|
||||
([(v* stop*) (let ([vec vec-expr]
|
||||
[stop* stop])
|
||||
(if (and (not stop*) (vector? vec))
|
||||
(values vec (unsafe-vector-length vec))
|
||||
(values vec stop*)))]
|
||||
[(start*) start]
|
||||
[(step*) step])
|
||||
;; Outer check
|
||||
(when (or (not (vector? v*))
|
||||
(not (exact-integer? start*))
|
||||
(not (exact-integer? stop*))
|
||||
(not (exact-integer? step*))
|
||||
(zero? step*)
|
||||
(and (< start* stop*) (< step* 0))
|
||||
(and (> start* stop*) (> step* 0)))
|
||||
;; Let in-vector report the error
|
||||
(in-vector v* start* stop* step*))
|
||||
;; Loop bindings
|
||||
([idx start*])
|
||||
;; Pos guard
|
||||
#,(cond
|
||||
[(not (number? (syntax-e #'step)))
|
||||
#`(if (step* . >= . 0) (< idx stop*) (> idx stop*))]
|
||||
[((syntax-e #'step) . >= . 0)
|
||||
(if all-fx?
|
||||
#'(unsafe-fx< idx stop*)
|
||||
#'(< idx stop*))]
|
||||
[else
|
||||
(if all-fx?
|
||||
#'(unsafe-fx> idx stop*)
|
||||
#'(> idx stop*))])
|
||||
;; Inner bindings
|
||||
([(id) (unsafe-vector-ref v* idx)])
|
||||
;; Pre guard
|
||||
#t
|
||||
;; Post guard
|
||||
#t
|
||||
;; Loop args
|
||||
((#,(if all-fx? #'unsafe-fx+ #'+) idx step)))])]
|
||||
[_ #f])))
|
||||
in-vector-like)
|
||||
|
||||
|
||||
(define-:vector-like-gen :vector-gen unsafe-vector-ref)
|
||||
|
||||
(define-in-vector-like in-vector
|
||||
"vector" vector? vector-length :vector-gen)
|
||||
|
||||
(define-sequence-syntax *in-vector
|
||||
(lambda () #'in-vector)
|
||||
(make-in-vector-like #'vector?
|
||||
#'unsafe-vector-length
|
||||
#'in-vector
|
||||
#'unsafe-vector-ref))
|
||||
|
||||
|
||||
(define-:vector-like-gen :string-gen unsafe-string-ref)
|
||||
|
||||
(define-in-vector-like in-string
|
||||
"string" string? string-length :string-gen)
|
||||
|
||||
(define-sequence-syntax *in-string
|
||||
(lambda () #'in-string)
|
||||
(make-in-vector-like #'string?
|
||||
#'string-length
|
||||
#'in-string
|
||||
#'string-ref))
|
||||
|
||||
|
||||
(define-:vector-like-gen :bytes-gen unsafe-bytes-ref)
|
||||
|
||||
(define-in-vector-like in-bytes
|
||||
"bytes" bytes? bytes-length :bytes-gen)
|
||||
|
||||
(define-sequence-syntax *in-bytes
|
||||
(lambda () #'in-bytes)
|
||||
(make-in-vector-like #'bytes?
|
||||
#'bytes-length
|
||||
#'in-bytes
|
||||
#'bytes-ref))
|
||||
|
||||
|
||||
;; ------------------------------------------------------------------------
|
||||
|
||||
|
||||
(define (stop-before g pred)
|
||||
(unless (sequence? g) (raise-type-error 'stop-before "sequence" g))
|
||||
(unless (and (procedure? pred)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user