Refactor code for defining sequences on vector like data types. Expose useful building blocks for constructing user defined sequences on vector like types (e.g. flvector, f64vector, etc.)
This commit is contained in:
Noel Welsh
parent
2b799e2714
commit
bd9368d889
125
collects/racket/private/for-base.rkt
Normal file
125
collects/racket/private/for-base.rkt
Normal file
|
|
@ -0,0 +1,125 @@
|
|||
(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)))))
|
||||
|
||||
)
|
||||
|
||||
|
||||
207
collects/racket/private/for-vector.rkt
Normal file
207
collects/racket/private/for-vector.rkt
Normal file
|
|
@ -0,0 +1,207 @@
|
|||
;; 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,6 +4,8 @@
|
|||
"misc.rkt"
|
||||
"define.rkt"
|
||||
"letstx-scheme.rkt"
|
||||
"for-base.rkt"
|
||||
"for-vector.rkt"
|
||||
'#%unsafe
|
||||
(for-syntax '#%kernel
|
||||
"stx.rkt"
|
||||
|
|
@ -65,44 +67,9 @@
|
|||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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)
|
||||
|
|
@ -280,53 +247,10 @@
|
|||
(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
|
||||
|
||||
(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)))))
|
||||
;; Also see for-base.rkt
|
||||
|
||||
(define (make-sequence who v)
|
||||
(cond
|
||||
|
|
@ -392,85 +316,6 @@
|
|||
(define (:mlist-gen l)
|
||||
(values mcar mcdr l mpair? void 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 in-vector
|
||||
(case-lambda
|
||||
[(v) (in-vector v 0 #f 1)]
|
||||
[(v start) (in-vector v start #f 1)]
|
||||
[(v start stop) (in-vector v start stop 1)]
|
||||
[(v start stop step)
|
||||
(unless (vector? v) (raise-type-error 'in-vector "vector" v))
|
||||
(let ([stop (or stop (vector-length v))])
|
||||
(check-ranges 'in-vector start stop step)
|
||||
(make-do-sequence (lambda () (:vector-gen v start stop step))))]))
|
||||
|
||||
(define (:vector-gen v start stop step)
|
||||
(values
|
||||
;; pos->element
|
||||
(lambda (i) (unsafe-vector-ref 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 in-string
|
||||
(case-lambda
|
||||
[(l) (in-string l 0 #f 1)]
|
||||
[(l start) (in-string l start #f 1)]
|
||||
[(l start stop) (in-string l start stop 1)]
|
||||
[(l start stop step)
|
||||
(unless (string? l) (raise-type-error 'in-string "string" l))
|
||||
(let ([stop (or stop (string-length l))])
|
||||
(check-ranges 'in-string start stop step)
|
||||
(make-do-sequence (lambda () (:string-gen l start stop step))))]))
|
||||
|
||||
(define (:string-gen v start stop step)
|
||||
(values (lambda (i) (string-ref v i))
|
||||
(if (= step 1) add1 (lambda (x) (+ x step)))
|
||||
start
|
||||
(lambda (i) (< i stop))
|
||||
void
|
||||
void))
|
||||
|
||||
(define in-bytes
|
||||
(case-lambda
|
||||
[(l) (in-bytes l 0 #f 1)]
|
||||
[(l start) (in-bytes l start #f 1)]
|
||||
[(l start stop) (in-bytes l start stop 1)]
|
||||
[(l start stop step)
|
||||
(unless (bytes? l) (raise-type-error 'in-bytes "bytes" l))
|
||||
(let ([stop (or stop (bytes-length l))])
|
||||
(check-ranges 'in-bytes start stop step)
|
||||
(make-do-sequence (lambda () (:bytes-gen l start stop step))))]))
|
||||
|
||||
(define (:bytes-gen v start stop step)
|
||||
(values (lambda (i) (bytes-ref v i))
|
||||
(if (= step 1) add1 (lambda (x) (+ x step)))
|
||||
start
|
||||
(lambda (i) (< i stop))
|
||||
void
|
||||
void))
|
||||
|
||||
(define (in-input-port-bytes p)
|
||||
(unless (input-port? p)
|
||||
(raise-type-error 'in-input-port-bytes "input-port" p))
|
||||
|
|
@ -1147,113 +992,6 @@
|
|||
((mcdr lst)))]]
|
||||
[_ #f])))
|
||||
|
||||
(define-for-syntax (vector-like-gen 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-sequence-syntax *in-vector
|
||||
(lambda () #'in-vector)
|
||||
(vector-like-gen #'vector?
|
||||
#'unsafe-vector-length
|
||||
#'in-vector
|
||||
#'unsafe-vector-ref))
|
||||
|
||||
(define-sequence-syntax *in-string
|
||||
(lambda () #'in-string)
|
||||
(vector-like-gen #'string?
|
||||
#'string-length
|
||||
#'in-string
|
||||
#'string-ref))
|
||||
|
||||
(define-sequence-syntax *in-bytes
|
||||
(lambda () #'in-bytes)
|
||||
(vector-like-gen #'bytes?
|
||||
#'bytes-length
|
||||
#'in-bytes
|
||||
#'bytes-ref))
|
||||
|
||||
(define-sequence-syntax *in-indexed
|
||||
(lambda () #'in-indexed)
|
||||
(lambda (stx)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user