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

for/vector' and for*/vector' repairs

Browse Source 
Closes PR 13029, 13030
This commit is contained in:
Matthew Flatt 2012-08-15 07:37:05 -06:00
parent 02d2b4dd62
commit 7b811bed1b
4 changed files with 172 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

87
collects/racket/private/for.rkt
View File

@ -1357,44 +1357,15 @@
(lambda (x) x)
(lambda (x) `(,#'cons ,x ,#'fold-var)))
(define-syntax (for/vector stx)
(syntax-case stx ()
[(for/vector (for-clause ...) body ...)
(with-syntax ([orig-stx stx])
(syntax/loc stx
(list->vector
(reverse
(for/fold/derived
orig-stx
([l null])
(for-clause ...)
(cons (let () body ...) l))))))]
[(for/vector #:length length-expr (for-clause ...) body ...)
(with-syntax ([orig-stx stx])
(syntax/loc stx
(let ([len length-expr])
(unless (exact-nonnegative-integer? len)
(raise-argument-error 'for/vector "exact-nonnegative-integer?" len))
(let ([v (make-vector len)])
(unless (zero? len)
(let ([len-1 (sub1 len)])
(for/fold/derived
orig-stx
([vd (void)])
([i (stop-after (*in-naturals) (lambda (i) (= i len-1)))]
for-clause ...)
(vector-set! v i (let () body ...))
(void))))
v))))]))
(define-syntax (for*/vector stx)
(define-for-syntax (for_/vector stx for_/vector-stx for_/fold/derived-stx wrap-all?)
(syntax-case stx ()
[(for*/vector (for-clause ...) body ...)
(with-syntax ([orig-stx stx])
(with-syntax ([orig-stx stx]
[for_/fold/derived for_/fold/derived-stx])
(syntax/loc stx
(list->vector
(reverse
(for*/fold/derived
(for_/fold/derived
orig-stx
([l null])
(for-clause ...)
@ -1402,25 +1373,41 @@
[(for*/vector #:length length-expr (for-clause ...) body ...)
(with-syntax ([orig-stx stx]
[(limited-for-clause ...)
(map (lambda (fc)
(syntax-case fc ()
[[ids rhs]
(or (identifier? #'ids)
(let ([l (syntax->list #'ids)])
(and l (andmap identifier? l))))
(syntax/loc fc [ids (stop-after
rhs
(lambda x
(= i len)))])]
[_ fc]))
(syntax->list #'(for-clause ...)))])
;; If `wrap-all?', wrap all binding clauses. Otherwise, wrap
;; only the first and the first after each keyword clause:
(let loop ([fcs (syntax->list #'(for-clause ...))] [wrap? #t])
(cond
[(null? fcs) null]
[(keyword? (syntax-e (car fcs)))
(if (null? (cdr fcs))
fcs
(list* (car fcs) (cadr fcs) (loop (cddr fcs) #t)))]
[(not wrap?)
(cons (car fcs) (loop (cdr fcs) #f))]
[else
(define fc (car fcs))
(define wrapped-fc
(syntax-case fc ()
[[ids rhs]
(or (identifier? #'ids)
(let ([l (syntax->list #'ids)])
(and l (andmap identifier? l))))
(syntax/loc fc [ids (stop-after
rhs
(lambda x
(= i len)))])]
[_ fc]))
(cons wrapped-fc
(loop (cdr fcs) wrap-all?))]))]
[for_/vector for_/vector-stx]
[for_/fold/derived for_/fold/derived-stx])
(syntax/loc stx
(let ([len length-expr])
(unless (exact-nonnegative-integer? len)
(raise-argument-error 'for*/vector "exact-nonnegative-integer?" len))
(raise-argument-error 'for_/vector "exact-nonnegative-integer?" len))
(let ([v (make-vector len)])
(unless (zero? len)
(for*/fold/derived
(for_/fold/derived
orig-stx
([i 0])
(limited-for-clause ...)
@ -1428,6 +1415,12 @@
(add1 i)))
v))))]))
(define-syntax (for/vector stx)
(for_/vector stx #'for/vector #'for/fold/derived #f))
(define-syntax (for*/vector stx)
(for_/vector stx #'for*/vector #'for*/fold/derived #t))
(define-for-syntax (do-for/lists for/fold-id stx)
(syntax-case stx ()
[(_ (id ...) bindings expr1 expr ...)

87
collects/racket/private/vector-wraps.rkt
View File

@ -39,44 +39,15 @@
(fXvector-set! v i x))
v)))
(define-syntax (for/fXvector stx)
(syntax-case stx ()
[(for/fXvector (for-clause ...) body ...)
(with-syntax ([orig-stx stx])
(syntax/loc stx
(list->fXvector
(reverse
(for/fold/derived
orig-stx
([l null])
(for-clause ...)
(cons (let () body ...) l))))))]
[(for/fXvector #:length length-expr (for-clause ...) body ...)
(with-syntax ([orig-stx stx])
(syntax/loc stx
(let ([len length-expr])
(unless (exact-nonnegative-integer? len)
(raise-argument-error 'for/fXvector "exact-nonnegative-integer?" len))
(let ([v (make-fXvector len)])
(unless (zero? len)
(let ([len-1 (sub1 len)])
(for/fold/derived
orig-stx
([vd (void)])
([i (stop-after (in-naturals) (lambda (i) (= i len-1)))]
for-clause ...)
(fXvector-set! v i (let () body ...))
(void))))
v))))]))
(define-syntax (for*/fXvector stx)
(define-for-syntax (for_/fXvector stx for_/fXvector-stx for_/fold/derived-stx wrap-all?)
(syntax-case stx ()
[(for*/fXvector (for-clause ...) body ...)
(with-syntax ([orig-stx stx])
(with-syntax ([orig-stx stx]
[for_/fold/derived for_/fold/derived-stx])
(syntax/loc stx
(list->fXvector
(reverse
(for*/fold/derived
(for_/fold/derived
orig-stx
([l null])
(for-clause ...)
@ -84,25 +55,41 @@
[(for*/fXvector #:length length-expr (for-clause ...) body ...)
(with-syntax ([orig-stx stx]
[(limited-for-clause ...)
(map (lambda (fc)
(syntax-case fc ()
[[ids rhs]
(or (identifier? #'ids)
(let ([l (syntax->list #'ids)])
(and l (andmap identifier? l))))
(syntax/loc fc [ids (stop-after
rhs
(lambda x
(= i len)))])]
[_ fc]))
(syntax->list #'(for-clause ...)))])
;; If `wrap-all?', wrap all binding clauses. Otherwise, wrap
;; only the first and the first after each keyword clause:
(let loop ([fcs (syntax->list #'(for-clause ...))] [wrap? #t])
(cond
[(null? fcs) null]
[(keyword? (syntax-e (car fcs)))
(if (null? (cdr fcs))
fcs
(list* (car fcs) (cadr fcs) (loop (cddr fcs) #t)))]
[(not wrap?)
(cons (car fcs) (loop (cdr fcs) #f))]
[else
(define fc (car fcs))
(define wrapped-fc
(syntax-case fc ()
[[ids rhs]
(or (identifier? #'ids)
(let ([l (syntax->list #'ids)])
(and l (andmap identifier? l))))
(syntax/loc fc [ids (stop-after
rhs
(lambda x
(= i len)))])]
[_ fc]))
(cons wrapped-fc
(loop (cdr fcs) wrap-all?))]))]
[for_/fXvector for_/fXvector-stx]
[for_/fold/derived for_/fold/derived-stx])
(syntax/loc stx
(let ([len length-expr])
(unless (exact-nonnegative-integer? len)
(raise-argument-error 'for*/fXvector "exact-nonnegative-integer?" len))
(raise-argument-error 'for_/fXvector "exact-nonnegative-integer?" len))
(let ([v (make-fXvector len)])
(unless (zero? len)
(for*/fold/derived
(for_/fold/derived
orig-stx
([i 0])
(limited-for-clause ...)
@ -110,6 +97,12 @@
(add1 i)))
v))))]))
(define-syntax (for/fXvector stx)
(for_/fXvector stx #'for/fXvector #'for/fold/derived #f))
(define-syntax (for*/fXvector stx)
(for_/fXvector stx #'for*/fXvector #'for*/fold/derived #t))
(define (fXvector-copy flv [start 0] [end (and (fXvector? flv) (fXvector-length flv))])
(unless (fXvector? flv)
(raise-argument-error 'fXvector-copy (string-append fXvector-str "?") flv))

47
collects/tests/racket/flonum.rktl
View File

@ -87,6 +87,53 @@
(test '(2.0 3.0) 'flvector-copy (for/list ([i (in-flvector (flvector-copy v 2))]) i))
(test '(2.0) 'flvector-copy (for/list ([i (in-flvector (flvector-copy v 2 3))]) i))))
;; Check empty clauses
(let ()
(define vector-iters 0)
(test (flvector 3.4 0.0 0.0 0.0)
'no-clauses
(for/flvector #:length 4 ()
(set! vector-iters (+ 1 vector-iters))
3.4))
(test 1 values vector-iters)
(test (flvector 3.4 0.0 0.0 0.0)
'no-clauses
(for*/flvector #:length 4 ()
(set! vector-iters (+ 1 vector-iters))
3.4))
(test 2 values vector-iters))
;; Check #:when and #:unless:
(test (flvector 0.0 1.0 2.0 1.0 2.0)
'when-#t
(for/flvector #:length 5
([x (in-range 3)]
#:when #t
[y (in-range 3)])
(exact->inexact (+ x y))))
(test (flvector 0.0 1.0 2.0 2.0 3.0)
'when-...
(for/flvector #:length 5
([x (in-range 3)]
#:when (even? x)
[y (in-range 3)])
(exact->inexact (+ x y))))
(test (flvector 0.0 1.0 2.0 1.0 2.0)
'unless-#f
(for/flvector #:length 5
([x (in-range 3)]
#:unless #f
[y (in-range 3)])
(exact->inexact (+ x y))))
(test (flvector 1.0 2.0 3.0 0.0 0.0)
'unless-...
(for/flvector #:length 5
([x (in-range 3)]
#:unless (even? x)
[y (in-range 3)])
(exact->inexact (+ x y))))
;; in-flvector tests, copied from for.rktl
(test-sequence [(1.0 2.0 3.0)] (in-flvector (flvector 1.0 2.0 3.0)))

45
collects/tests/racket/for.rktl
View File

@ -232,6 +232,51 @@
(number->string i))
c)))
;; Check empty clauses
(let ()
(define vector-iters 0)
(test (vector 3.4 0 0 0)
'no-clauses
(for/vector #:length 4 ()
(set! vector-iters (+ 1 vector-iters))
3.4))
(test 1 values vector-iters)
(test (vector 3.4 0 0 0)
'no-clauses
(for*/vector #:length 4 ()
(set! vector-iters (+ 1 vector-iters))
3.4))
(test 2 values vector-iters))
;; Check #:when and #:unless:
(test (vector 0 1 2 1 2)
'when-#t
(for/vector #:length 5
([x (in-range 3)]
#:when #t
[y (in-range 3)])
(+ x y)))
(test (vector 0 1 2 2 3)
'when-...
(for/vector #:length 5
([x (in-range 3)]
#:when (even? x)
[y (in-range 3)])
(+ x y)))
(test (vector 0 1 2 1 2)
'unless-#f
(for/vector #:length 5
([x (in-range 3)]
#:unless #f
[y (in-range 3)])
(+ x y)))
(test (vector 1 2 3 0 0)
'unless-...
(for/vector #:length 5
([x (in-range 3)]
#:unless (even? x)
[y (in-range 3)])
(+ x y)))
(test #hash((a . 1) (b . 2) (c . 3)) 'mk-hash
(for/hash ([v (in-naturals)]