From 7b811bed1ba56d7d59543fbce5969eadab030d1c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 15 Aug 2012 07:37:05 -0600 Subject: [PATCH] `for/vector' and `for*/vector' repairs Closes PR 13029, 13030 --- collects/racket/private/for.rkt | 87 +++++++++++------------- collects/racket/private/vector-wraps.rkt | 87 +++++++++++------------- collects/tests/racket/flonum.rktl | 47 +++++++++++++ collects/tests/racket/for.rktl | 45 ++++++++++++ 4 files changed, 172 insertions(+), 94 deletions(-) diff --git a/collects/racket/private/for.rkt b/collects/racket/private/for.rkt index cd12576c58..db940c6173 100644 --- a/collects/racket/private/for.rkt +++ b/collects/racket/private/for.rkt @@ -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 ...) diff --git a/collects/racket/private/vector-wraps.rkt b/collects/racket/private/vector-wraps.rkt index 295f7177d6..2f1363b02b 100644 --- a/collects/racket/private/vector-wraps.rkt +++ b/collects/racket/private/vector-wraps.rkt @@ -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)) diff --git a/collects/tests/racket/flonum.rktl b/collects/tests/racket/flonum.rktl index 407b57b83d..50ca3d89de 100644 --- a/collects/tests/racket/flonum.rktl +++ b/collects/tests/racket/flonum.rktl @@ -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))) diff --git a/collects/tests/racket/for.rktl b/collects/tests/racket/for.rktl index be0ab8f294..6b036df324 100644 --- a/collects/tests/racket/for.rktl +++ b/collects/tests/racket/for.rktl @@ -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)]