diff --git a/collects/data/gvector.rkt b/collects/data/gvector.rkt index 140c68bdda..b51e988d03 100644 --- a/collects/data/gvector.rkt +++ b/collects/data/gvector.rkt @@ -1,7 +1,8 @@ #lang racket/base ;; written by ryanc (require (for-syntax racket/base - unstable/wrapc) + unstable/wrapc + syntax/for-body) racket/contract/base racket/dict racket/vector) @@ -158,22 +159,26 @@ (define-syntax (for/gvector stx) (syntax-case stx () [(_ (clause ...) . body) - (quasisyntax/loc stx - (let ([gv (make-gvector)]) - (for/fold/derived #,stx () (clause ...) - (call-with-values (lambda () . body) - (lambda args (apply gvector-add! gv args) (values)))) - gv))])) + (with-syntax ([((pre-body ...) post-body) (split-for-body stx #'body)]) + (quasisyntax/loc stx + (let ([gv (make-gvector)]) + (for/fold/derived #,stx () (clause ...) + pre-body ... + (call-with-values (lambda () . post-body) + (lambda args (apply gvector-add! gv args) (values)))) + gv)))])) (define-syntax (for*/gvector stx) (syntax-case stx () [(_ (clause ...) . body) - (quasisyntax/loc stx - (let ([gv (make-gvector)]) - (for*/fold/derived #,stx () (clause ...) - (call-with-values (lambda () . body) - (lambda args (apply gvector-add! gv args) (values)))) - gv))])) + (with-syntax ([((pre-body ...) post-body) (split-for-body stx #'body)]) + (quasisyntax/loc stx + (let ([gv (make-gvector)]) + (for*/fold/derived #,stx () (clause ...) + pre-body ... + (call-with-values (lambda () . post-body) + (lambda args (apply gvector-add! gv args) (values)))) + gv)))])) (struct gvector (vec n) #:mutable diff --git a/collects/racket/private/for.rkt b/collects/racket/private/for.rkt index 92afce863a..c6ec12afb1 100644 --- a/collects/racket/private/for.rkt +++ b/collects/racket/private/for.rkt @@ -29,6 +29,7 @@ for/hasheqv for*/hasheqv for/fold/derived for*/fold/derived + (for-syntax split-for-body) (rename *in-range in-range) (rename *in-naturals in-naturals) @@ -1280,19 +1281,127 @@ [(_ [orig-stx . _] . _) (raise-syntax-error #f "bad syntax" #'orig-stx)])) + (define-syntax (for/foldX/derived/break stx) + (syntax-case stx () + [(_ [orig-stx nested? emit? ()] ([id init] ...) (clause ...) body ...) + (ormap (lambda (form) + (or (eq? (syntax-e form) '#:break) + (eq? (syntax-e form) '#:final))) + (syntax->list #'(clause ... body ...))) + ;; Add an accumulator for short-circuiting + (with-syntax ([body + (let loop ([bodys (syntax->list #'(body ...))] [accum null]) + (cond + [(null? bodys) + (if (null? accum) + (raise-syntax-error #f "missing final body expression" #'orig-stx) + #`(let-values ([(id ...) (let () #,@(reverse accum))]) + (values stop-after? id ...)))] + [(or (eq? '#:break (syntax-e (car bodys))) + (eq? '#:final (syntax-e (car bodys)))) + (let ([break? (eq? '#:break (syntax-e (car bodys)))]) + (if (null? (cdr bodys)) + (raise-syntax-error #f + (format "missing expression after ~a" (syntax-e (car bodys))) + #'orig-stx (car bodys)) + #`(let () + #,@(reverse accum) + #,(if break? + #`(if #,(cadr bodys) + (values #t id ...) + (let () #,(loop (cddr bodys) null))) + #`(let ([stop-after? (or #,(cadr bodys) stop-after?)]) + #,(loop (cddr bodys) null))))))] + [else (loop (cdr bodys) (cons (car bodys) accum))]))] + [(limited-for-clause ...) + ;; If nested, wrap all binding clauses. Otherwise, wrap + ;; only the first and the first after each keyword clause: + (let loop ([fcs (syntax->list #'(clause ...))] [wrap? #t]) + (cond + [(null? fcs) null] + [(eq? '#:break (syntax-e (car fcs))) + (when (null? (cdr fcs)) + (raise-syntax-error #f "no expression after #:break" #'orig-stx (car fcs))) + (list* #'#:when #'#t + #`[stop? (*in-value #,(cadr fcs))] + #'#:when #'#t + #`[stop-after? (*in-value (or stop-after? stop?))] + #'#:unless #'stop? + (loop (cddr fcs) #t))] + [(eq? '#:final (syntax-e (car fcs))) + (when (null? (cdr fcs)) + (raise-syntax-error #f "no expression after #:break" #'orig-stx (car fcs))) + (list* #'#:when #'#t + #`[stop-after? (*in-value (or #,(cadr fcs) stop-after?))] + #'#:when #'#t + (loop (cddr fcs) #t))] + [(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 stop-after?))])] + [_ fc])) + (cons wrapped-fc + (loop (cdr fcs) (syntax-e #'nested?)))]))]) + #'(let-values ([(stop? id ...) + (for/foldX/derived [orig-stx nested? emit? ()] ([stop-after? #f] [id init] ...) + (limited-for-clause ...) + body)]) + (values id ...)))] + [(_ . rest) + #'(for/foldX/derived . rest)])) + (define-syntax for/fold/derived (syntax-rules () [(_ orig-stx . rest) - (for/foldX/derived [orig-stx #f #f ()] . rest)])) + (for/foldX/derived/break [orig-stx #f #f ()] . rest)])) (define-syntax for*/fold/derived (syntax-rules () [(_ orig-stx . rest) - (for/foldX/derived [orig-stx #t #f ()] . rest)])) + (for/foldX/derived/break [orig-stx #t #f ()] . rest)])) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; derived `for' syntax + (define-for-syntax (split-for-body stx body-stx) + (let ([lst (syntax->list body-stx)]) + (if lst + (let loop ([exprs lst] [pre-kw null] [post-kw null]) + (cond + [(null? exprs) + (if (null? post-kw) + (raise-syntax-error #f + (format "missing body form after ~a clause" (syntax-e (cadr pre-kw))) + stx + (cadr pre-kw)) + (list (reverse pre-kw) (reverse post-kw)))] + [(memq (syntax-e (car exprs)) '(#:break #:final)) + (if (pair? (cdr exprs)) + (loop (cddr exprs) + (append (list* (cadr exprs) (car exprs) post-kw) + pre-kw) + null) + (raise-syntax-error #f + (format "missing expression after ~a" (syntax-e (car exprs))) + stx + (car exprs)))] + [else + (loop (cdr exprs) pre-kw (cons (car exprs) post-kw))])) + (raise-syntax-error #f "bad syntax" stx)))) + (define-for-syntax (for-variant-stx stx derived-id-stx fold-bind-stx wrap rhs-wrap combine) (with-syntax ([derived-id derived-id-stx] [fold-bind fold-bind-stx]) @@ -1309,22 +1418,27 @@ (andmap identifier? (or (syntax->list #'ids) '(#f)))) (cons #`[ids #,(rhs-wrap #'rhs)] (loop (cdr bs)))] - [#:when (cons (car bs) - (if (null? (cdr bs)) - null - (cons (cadr bs) (loop (cddr bs)))))] + [kw + (memq (syntax-e #'kw) '(#:when #:unless #:break #:final)) + (cons (car bs) + (if (null? (cdr bs)) + null + (cons (cadr bs) (loop (cddr bs)))))] [_ ;; a syntax error; let the /derived form ;; handle it, and no need to wrap any more: - bs])))]) + bs])))] + [((middle-expr ...) (end-expr ...)) + (split-for-body stx #'(expr1 expr ...))]) (quasisyntax/loc stx #,(wrap (quasisyntax/loc stx (derived-id #,stx fold-bind (bind ...) - #,(combine (syntax/loc stx (let () expr1 expr ...))))))))] + middle-expr ... + #,(combine (syntax/loc stx (let () end-expr ...))))))))] ;; Let `derived-id' complain about the missing bindings and body expression: [(_ . rest) #`(derived-id #,stx fold-bind . rest)]))) - + (define-syntax define-syntax-via-derived (syntax-rules () [(_ id derived-id fold-bind wrap rhs-wrap combine) @@ -1372,7 +1486,8 @@ (syntax-case stx () [(_ (for-clause ...) body ...) (with-syntax ([orig-stx orig-stx] - [for_/fold/derived for_/fold/derived-stx]) + [for_/fold/derived for_/fold/derived-stx] + [((middle-body ...) (last-body ...)) (split-for-body stx #'(body ...))]) (syntax/loc stx (let-values ([(vec i) (for_/fold/derived @@ -1380,10 +1495,11 @@ ([vec (make-vector 16)] [i 0]) (for-clause ...) + middle-body ... (let ([new-vec (if (eq? i (unsafe-vector-length vec)) (grow-vector vec) vec)]) - (unsafe-vector-set! new-vec i (let () body ...)) + (unsafe-vector-set! new-vec i (let () last-body ...)) (values new-vec (unsafe-fx+ i 1))))]) (shrink-vector vec i))))] [(_ #:length length-expr #:fill fill-expr (for-clause ...) body ...) @@ -1415,21 +1531,23 @@ [_ fc])) (cons wrapped-fc (loop (cdr fcs) wrap-all?))]))] + [((middle-body ...) (last-body ...)) (split-for-body stx #'(body ...))] [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)) - (let ([v (make-vector len fill-expr)]) - (unless (zero? len) - (for_/fold/derived - orig-stx - ([i 0]) - (limited-for-clause ...) - (vector-set! v i (let () body ...)) - (add1 i))) - v))))] + (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 fill-expr)]) + (unless (zero? len) + (for_/fold/derived + orig-stx + ([i 0]) + (limited-for-clause ...) + middle-body ... + (vector-set! v i (let () last-body ...)) + (add1 i))) + v))))] [(_ #:length length-expr (for-clause ...) body ...) (for_/vector #'(fv #:length length-expr #:fill 0 (for-clause ...) body ...) orig-stx for_/vector-stx for_/fold/derived-stx wrap-all?)])) diff --git a/collects/racket/private/pre-base.rkt b/collects/racket/private/pre-base.rkt index 7255c22360..980b1633eb 100644 --- a/collects/racket/private/pre-base.rkt +++ b/collects/racket/private/pre-base.rkt @@ -167,7 +167,8 @@ define-:vector-like-gen make-in-vector-like stream? stream-ref stream-empty? stream-first stream-rest - prop:stream in-stream empty-stream make-do-stream) + prop:stream in-stream empty-stream make-do-stream + split-for-body) (all-from "kernstruct.rkt") #%top-interaction diff --git a/collects/racket/private/vector-wraps.rkt b/collects/racket/private/vector-wraps.rkt index 1baee63315..9315f1baca 100644 --- a/collects/racket/private/vector-wraps.rkt +++ b/collects/racket/private/vector-wraps.rkt @@ -54,7 +54,8 @@ (syntax-case stx () [(for*/fXvector (for-clause ...) body ...) (with-syntax ([orig-stx orig-stx] - [for_/fold/derived for_/fold/derived-stx]) + [for_/fold/derived for_/fold/derived-stx] + [((middle-body ...) (last-body ...)) (split-for-body stx #'(body ...))]) (syntax/loc stx (let-values ([(vec i) (for_/fold/derived @@ -62,10 +63,11 @@ ([vec (make-fXvector 16)] [i 0]) (for-clause ...) + middle-body ... (let ([new-vec (if (eq? i (unsafe-fXvector-length vec)) (grow-fXvector vec) vec)]) - (unsafe-fXvector-set! new-vec i (let () body ...)) + (unsafe-fXvector-set! new-vec i (let () last-body ...)) (values new-vec (unsafe-fx+ i 1))))]) (shrink-fXvector vec i))))] [(for*/fXvector #:length length-expr #:fill fill-expr (for-clause ...) body ...) @@ -93,10 +95,11 @@ (syntax/loc fc [ids (stop-after rhs (lambda x - (= i len)))])] + (unsafe-fx= i len)))])] [_ fc])) (cons wrapped-fc (loop (cdr fcs) wrap-all?))]))] + [((middle-body ...) (last-body ...)) (split-for-body stx #'(body ...))] [for_/fXvector for_/fXvector-stx] [for_/fold/derived for_/fold/derived-stx]) (syntax/loc stx @@ -110,7 +113,8 @@ orig-stx ([i 0]) (limited-for-clause ...) - (fXvector-set! v i (let () body ...)) + middle-body ... + (fXvector-set! v i (let () last-body ...)) (add1 i))) v)))))] [(_ #:length length-expr (for-clause ...) body ...) diff --git a/collects/racket/set.rkt b/collects/racket/set.rkt index c1b5b6ba88..68c6845ad7 100644 --- a/collects/racket/set.rkt +++ b/collects/racket/set.rkt @@ -1,5 +1,6 @@ #lang racket/base -(require (for-syntax racket/base) +(require (for-syntax racket/base + syntax/for-body) racket/serialize racket/pretty racket/contract/base @@ -332,10 +333,12 @@ (define-syntax-rule (define-for for/fold/derived for/set set) (define-syntax (for/set stx) - (syntax-case stx () - [(_ bindings . body) - (quasisyntax/loc stx - (for/fold/derived #,stx ([s (set)]) bindings (set-add s (let () . body))))]))) + (... + (syntax-case stx () + [(_ bindings . body) + (with-syntax ([((pre-body ...) post-body) (split-for-body stx #'body)]) + (quasisyntax/loc stx + (for/fold/derived #,stx ([s (set)]) bindings pre-body ... (set-add s (let () . post-body)))))])))) (define-for for/fold/derived for/set set) (define-for for*/fold/derived for*/set set) diff --git a/collects/scribblings/guide/for.scrbl b/collects/scribblings/guide/for.scrbl index 58421bedb6..5b23c3496b 100644 --- a/collects/scribblings/guide/for.scrbl +++ b/collects/scribblings/guide/for.scrbl @@ -413,6 +413,74 @@ list, and also works with multiple-valued sequences: ] +@section{Breaking an Iteration} + +An even more complete syntax of @racket[for] is + +@specform/subs[ +(for (clause ...) + body-or-break ... body) +([clause [id sequence-expr] + (code:line #:when boolean-expr) + (code:line #:unless boolean-expr) + break] + [body-or-break body break] + [break (code:line #:break boolean-expr) + (code:line #:final boolean-expr)]) +]{} + +That is, a @racket[#:break] or @racket[#:final] clause can +be included among the binding clauses and body of the iteration. Among +the binding clauses, @racket[#:break] is like @racket[#:unless] +but when its @racket[_boolean-expr] is true, all sequences within the +@racket[for] are stopped. Among the @racket[_body]s, +@racket[#:break] has the same effect on sequences when its +@racket[_boolean-expr] is true, and it also prevents later +@racket[_body]s from evaluation in the current iteration. + +For example, while using @racket[#:when] between clauses effectively +skips later sequences as well as the body, + +@interaction[ +(for ([book '("Guide" "Story" "Reference")] + #:unless (equal? book "Story") + [chapter '("Intro" "Details" "Conclusion")]) + (printf "~a ~a\n" book chapter)) +] + +using @racket[#:break] causes the entire @racket[for] iteration +to terminate: + +@interaction[ +(for ([book '("Guide" "Story" "Reference")] + #:break (equal? book "Story") + [chapter '("Intro" "Details" "Conclusion")]) + (printf "~a ~a\n" book chapter)) +(for* ([book '("Guide" "Story" "Reference")] + [chapter '("Intro" "Details" "Conclusion")]) + #:break (and (equal? book "Story") + (equal? chapter "Conclusion")) + (printf "~a ~a\n" book chapter)) +] + +A @racket[#:final] clause is similar to @racket[#:break], +but it does not immediately terminate the iteration. Instead, it +allows at most one more element to be drawn for each sequence and at +most one more evaluation of the @racket[_body]s. + + +@interaction[ +(for* ([book '("Guide" "Story" "Reference")] + [chapter '("Intro" "Details" "Conclusion")]) + #:final (and (equal? book "Story") + (equal? chapter "Conclusion")) + (printf "~a ~a\n" book chapter)) +(for ([book '("Guide" "Story" "Reference")] + #:final (equal? book "Story") + [chapter '("Intro" "Details" "Conclusion")]) + (printf "~a ~a\n" book chapter)) +] + @section[#:tag "for-performance"]{Iteration Performance} Ideally, a @racket[for] iteration should run as fast as a loop that diff --git a/collects/scribblings/reference/for.scrbl b/collects/scribblings/reference/for.scrbl index 5ffaba809f..c9dfd08728 100644 --- a/collects/scribblings/reference/for.scrbl +++ b/collects/scribblings/reference/for.scrbl @@ -13,16 +13,23 @@ The @racket[for] iteration forms are based on SRFI-42 @section{Iteration and Comprehension Forms} -@defform/subs[(for (for-clause ...) body ...+) +@defform/subs[(for (for-clause ...) body-or-break ... body) ([for-clause [id seq-expr] [(id ...) seq-expr] (code:line #:when guard-expr) - (code:line #:unless guard-expr)]) + (code:line #:unless guard-expr) + break-clause] + [break-clause (code:line #:break guard-expr) + (code:line #:final guard-expr)] + [body-or-break body + bleak-clause]) #:contracts ([seq-expr sequence?])]{ -Iteratively evaluates @racket[body]. The @racket[for-clause]s +Iteratively evaluates @racket[body]s. The @racket[for-clause]s introduce bindings whose scope includes @racket[body] and that determine the number of times that @racket[body] is evaluated. +A @racket[break-clause] either among the @racket[for-clause]s +of @racket[body]s stops further iteration. In the simple case, each @racket[for-clause] has one of its first two forms, where @racket[[id seq-expr]] is a shorthand for @racket[[(id) @@ -61,6 +68,19 @@ using the remaining @racket[for-clauses]. A @racket[for-clause] of the form @racket[#:unless guard-expr] corresponds to the same transformation with @racket[unless] in place of @racket[when]. +A @racket[#:break guard-expr] clause is similar to a +@racket[#:unless guard-expr] clause, but when @racket[#:break] +avoids evaluation of the @racket[body]s, it also effectively ends all +sequences within the @racket[for] form. A @racket[#:final +guard-expr] clause is similar to @racket[#:break guard-expr], but +instead of immediately ending sequences and skipping the +@racket[body]s, it allows at most one more element from each later +sequence and at most one more evaluation of the following +@racket[body]s. Among the @racket[body]s, besides stopping the +iteration and preventing later @racket[body] evaluations, a +@racket[#:break guard-expr] or @racket[#:final guard-expr] +clause starts a new internal-definition context. + @examples[ (for ([i '(1 2 3)] [j "abc"] @@ -69,13 +89,28 @@ with @racket[unless] in place of @racket[when]. (display (list i j k))) (for ([(i j) #hash(("a" . 1) ("b" . 20))]) (display (list i j))) +(for ([i '(1 2 3)] + [j "abc"] + #:break (not (odd? i)) + [k #2(#t #f)]) + (display (list i j k))) +(for ([i '(1 2 3)] + [j "abc"] + #:final (not (odd? i)) + [k #2(#t #f)]) + (display (list i j k))) +(for ([i '(1 2 3)] + [j "abc"] + [k #2(#t #f)]) + #:break (not (or (odd? i) k)) + (display (list i j k))) (for () (display "here")) (for ([i '()]) (error "doesn't get here")) ]} -@defform[(for/list (for-clause ...) body ...+)]{ Iterates like +@defform[(for/list (for-clause ...) body-or-break ... body)]{ Iterates like @racket[for], but that the last expression in the @racket[body]s must produce a single value, and the result of the @racket[for/list] expression is a list of the results in order. @@ -89,12 +124,17 @@ element. #:when (odd? i) [k #2(#t #f)]) (list i j k)) +(for/list ([i '(1 2 3)] + [j "abc"] + #:break (not (odd? i)) + [k #2(#t #f)]) + (list i j k)) (for/list () 'any) (for/list ([i '()]) (error "doesn't get here")) ]} -@defform/subs[(for/vector maybe-length (for-clause ...) body ...+) +@defform/subs[(for/vector maybe-length (for-clause ...) body-or-break ... body) ([maybe-length (code:line) (code:line #:length length-expr) (code:line #:length length-expr #:fill fill-expr)]) @@ -127,9 +167,9 @@ mutate a shared vector.} @deftogether[( -@defform[(for/hash (for-clause ...) body ...+)] -@defform[(for/hasheq (for-clause ...) body ...+)] -@defform[(for/hasheqv (for-clause ...) body ...+)] +@defform[(for/hash (for-clause ...) body-or-break ... body)] +@defform[(for/hasheq (for-clause ...) body-or-break ... body)] +@defform[(for/hasheqv (for-clause ...) body-or-break ... body)] )]{ Like @racket[for/list], but the result is an immutable @tech{hash @@ -146,7 +186,7 @@ the iteration. ]} -@defform[(for/and (for-clause ...) body ...+)]{ Iterates like +@defform[(for/and (for-clause ...) body-or-break ... body)]{ Iterates like @racket[for], but when last expression of @racket[body] produces @racket[#f], then iteration terminates, and the result of the @racket[for/and] expression is @racket[#f]. If the @racket[body] @@ -159,11 +199,14 @@ result from the last evaluation of @racket[body]. (i . < . 3)) (for/and ([i '(1 2 3 4)]) i) +(for/and ([i '(1 2 3 4)]) + #:break (= i 3) + i) (for/and ([i '()]) (error "doesn't get here")) ]} -@defform[(for/or (for-clause ...) body ...+)]{ Iterates like +@defform[(for/or (for-clause ...) body-or-break ... body)]{ Iterates like @racket[for], but when last expression of @racket[body] produces a value other than @racket[#f], then iteration terminates, and the result of the @racket[for/or] expression is the same @@ -181,7 +224,7 @@ result of the @racket[for/or] expression is ]} @deftogether[( -@defform[(for/sum (for-clause ...) body ...+)] +@defform[(for/sum (for-clause ...) body-or-break ... body)] )]{ Iterates like @racket[for], but each result of the last @racket[body] @@ -193,7 +236,7 @@ is accumulated into a result with @racket[+]. @deftogether[( -@defform[(for/product (for-clause ...) body ...+)] +@defform[(for/product (for-clause ...) body-or-break ... body)] )]{ Iterates like @racket[for], but each result of the last @racket[body] @@ -204,7 +247,7 @@ is accumulated into a result with @racket[*]. ]} -@defform[(for/lists (id ...) (for-clause ...) body ...+)]{ +@defform[(for/lists (id ...) (for-clause ...) body-or-break ... body)]{ Similar to @racket[for/list], but the last @racket[body] expression should produce as many values as given @racket[id]s, and the result is @@ -213,7 +256,7 @@ the lists accumulated so far in the @racket[for-clause]s and @racket[body]s.} -@defform[(for/first (for-clause ...) body ...+)]{ Iterates like +@defform[(for/first (for-clause ...) body-or-break ... body)]{ Iterates like @racket[for], but after @racket[body] is evaluated the first time, then the iteration terminates, and the @racket[for/first] result is the (single) result of @racket[body]. If the @@ -228,7 +271,7 @@ result is the (single) result of @racket[body]. If the (error "doesn't get here")) ]} -@defform[(for/last (for-clause ...) body ...+)]{ Iterates like +@defform[(for/last (for-clause ...) body-or-break ... body)]{ Iterates like @racket[for], but the @racket[for/last] result is the (single) result of the last evaluation of @racket[body]. If the @racket[body] is never evaluated, then the result of the @@ -242,7 +285,8 @@ result of the last evaluation of @racket[body]. If the (error "doesn't get here")) ]} -@defform[(for/fold ([accum-id init-expr] ...) (for-clause ...) . body)]{ +@defform[(for/fold ([accum-id init-expr] ...) (for-clause ...) + body-or-break ... body)]{ Iterates like @racket[for]. Before iteration starts, the @racket[init-expr]s are evaluated to produce initial accumulator @@ -261,7 +305,7 @@ accumulator values. (values (+ sum i) (cons (sqrt i) rev-roots))) ]} -@defform[(for* (for-clause ...) body ...+)]{ +@defform[(for* (for-clause ...) body-or-break ... body)]{ Like @racket[for], but with an implicit @racket[#:when #t] between each pair of @racket[for-clauses], so that all sequence iterations are nested. @@ -273,19 +317,20 @@ nested. ]} @deftogether[( -@defform[(for*/list (for-clause ...) body ...+)] -@defform[(for*/lists (id ...) (for-clause ...) body ...+)] -@defform[(for*/vector maybe-length (for-clause ...) body ...+)] -@defform[(for*/hash (for-clause ...) body ...+)] -@defform[(for*/hasheq (for-clause ...) body ...+)] -@defform[(for*/hasheqv (for-clause ...) body ...+)] -@defform[(for*/and (for-clause ...) body ...+)] -@defform[(for*/or (for-clause ...) body ...+)] -@defform[(for*/sum (for-clause ...) body ...+)] -@defform[(for*/product (for-clause ...) body ...+)] -@defform[(for*/first (for-clause ...) body ...+)] -@defform[(for*/last (for-clause ...) body ...+)] -@defform[(for*/fold ([accum-id init-expr] ...) (for-clause ...) body ...+)] +@defform[(for*/list (for-clause ...) body-or-break ... body)] +@defform[(for*/lists (id ...) (for-clause ...) body-or-break ... body)] +@defform[(for*/vector maybe-length (for-clause ...) body-or-break ... body)] +@defform[(for*/hash (for-clause ...) body-or-break ... body)] +@defform[(for*/hasheq (for-clause ...) body-or-break ... body)] +@defform[(for*/hasheqv (for-clause ...) body-or-break ... body)] +@defform[(for*/and (for-clause ...) body-or-break ... body)] +@defform[(for*/or (for-clause ...) body-or-break ... body)] +@defform[(for*/sum (for-clause ...) body-or-break ... body)] +@defform[(for*/product (for-clause ...) body-or-break ... body)] +@defform[(for*/first (for-clause ...) body-or-break ... body)] +@defform[(for*/last (for-clause ...) body-or-break ... body)] +@defform[(for*/fold ([accum-id init-expr] ...) (for-clause ...) + body-or-break ... body)] )]{ Like @racket[for/list], etc., but with the implicit nesting of @@ -301,7 +346,8 @@ Like @racket[for/list], etc., but with the implicit nesting of @section{Deriving New Iteration Forms} @defform[(for/fold/derived orig-datum - ([accum-id init-expr] ...) (for-clause ...) body ...+)]{ + ([accum-id init-expr] ...) (for-clause ...) + body-or-break ... body)]{ Like @racket[for/fold], but the extra @racket[orig-datum] is used as the source for all syntax errors. @@ -331,7 +377,8 @@ source for all syntax errors. } @defform[(for*/fold/derived orig-datum - ([accum-id init-expr] ...) (for-clause ...) body ...+)]{ + ([accum-id init-expr] ...) (for-clause ...) + body-or-break ... body)]{ Like @racket[for*/fold], but the extra @racket[orig-datum] is used as the source for all syntax errors. @mz-examples[#:eval for-eval diff --git a/collects/syntax/for-body.rkt b/collects/syntax/for-body.rkt new file mode 100644 index 0000000000..2c5d3179d8 --- /dev/null +++ b/collects/syntax/for-body.rkt @@ -0,0 +1,4 @@ +#lang racket/base + +(require (for-template racket/private/for)) +(provide split-for-body) diff --git a/collects/syntax/scribblings/for-body.scrbl b/collects/syntax/scribblings/for-body.scrbl new file mode 100644 index 0000000000..1483d7f44a --- /dev/null +++ b/collects/syntax/scribblings/for-body.scrbl @@ -0,0 +1,21 @@ +#lang scribble/manual +@(require (for-label racket/base + syntax/quote)) + +@title{Parsing @racket[for] Bodies} + +@defmodule[syntax/for-body]{The @racketmodname[syntax/for-body] module +provides a helper function for @racket[for]-like syntactic forms that +wrap the body of the form while expanding to another @racket[for]-like +form, and the wrapper should apply only after the last +@racket[#:break] or @racket[#:final] clause in the body.} + +@defproc[(split-for-body [stx syntax?] [body-stxes syntax?]) syntax?]{ + +The @racket[body-stxes] argument must have the form +@racket[(_pre-body ... _post-body ...)], and it is rewritten into +@racket[((_pre-body ...) (_post-body ...))] such that +@racket[(_post-body ...)] is as large as possible without containing a +@racket[#:break] or @racket[#:final] clause. + +The @racket[stx] argument is used only for reporting syntax errors.} diff --git a/collects/syntax/scribblings/syntax.scrbl b/collects/syntax/scribblings/syntax.scrbl index 9eb7e4cadc..21270a10e3 100644 --- a/collects/syntax/scribblings/syntax.scrbl +++ b/collects/syntax/scribblings/syntax.scrbl @@ -17,6 +17,8 @@ @include-section["reader-helpers.scrbl"] +@include-section["for-body.scrbl"] + @include-section["srcloc.scrbl"] @include-section["quote.scrbl"] diff --git a/collects/tests/racket/flonum.rktl b/collects/tests/racket/flonum.rktl index 236e265762..ae6b1a9cfe 100644 --- a/collects/tests/racket/flonum.rktl +++ b/collects/tests/racket/flonum.rktl @@ -31,6 +31,12 @@ (test (flvector 1.0 2.0 3.0 -10.0 -10.0) 'for/flvector-fill (for/flvector #:length 5 #:fill -10.0 ([i 3]) (+ i 1.0))) +(test (flvector 1.0 2.0 3.0 0.0 0.0) + 'for/flvector-fill + (for/flvector #:length 5 ([i 5]) #:break (= i 3) (+ i 1.0))) +(test (flvector 1.0 2.0 3.0 4.0 0.0) + 'for/flvector-fill + (for/flvector #:length 5 ([i 5]) #:final (= i 3) (+ i 1.0))) ;; for*/flvector test (let ((flv (flvector 0.0 0.0 0.0 0.0 1.0 2.0 0.0 2.0 4.0)) diff --git a/collects/tests/racket/for.rktl b/collects/tests/racket/for.rktl index 7ce36c080c..70b2270a8b 100644 --- a/collects/tests/racket/for.rktl +++ b/collects/tests/racket/for.rktl @@ -156,6 +156,37 @@ #f (lambda (pos val1 val2) (not (string=? val2 "4"))))) + +(test '(1 2 3) + 'three + (for/list ([i 10]) + #:break (= i 3) + (add1 i))) +(test '(1 2 3 4) + 'three + (for/list ([i 10]) + #:final (= i 3) + (add1 i))) + +;; Make sure that breaking a sequence stops before consuming another element: +(test '(("1" "2" "3" "4" "5" "6" "7" "8" "9") . 10) + 'producer + (let ([c 0]) + (cons + (for/list ([i (in-producer (lambda () (set! c (add1 c)) c) #f)]) + #:break (= i 10) + (number->string i)) + c))) +(test '(("1" "2" "3" "4" "5" "6" "7" "8" "9") . 10) + 'producer + (let ([c 0]) + (cons + (for*/list ([j '(0)] + [i (in-producer (lambda () (set! c (add1 c)) c) #f)]) + #:break (= i 10) + (number->string i)) + c))) + ;; Basic sanity checks. (test '#(1 2 3 4) 'for/vector (for/vector ((i (in-range 4))) (+ i 1))) (test '#(1 2 3 4) 'for/vector-fast (for/vector #:length 4 ((i (in-range 4))) (+ i 1))) diff --git a/collects/tests/racket/set.rktl b/collects/tests/racket/set.rktl index 09f6496d4b..ce107567fe 100644 --- a/collects/tests/racket/set.rktl +++ b/collects/tests/racket/set.rktl @@ -131,6 +131,13 @@ (test (set 1 2 3) 'for/set (for/set ([i '(0 1 2)]) (add1 i))) +(test (set 1 2 3) 'for/set (for/set ([i '(0 1 2 3 4)]) + #:break (= i 3) + (add1 i))) +(test (set 1 2 3) 'for/set (for/set ([i '(0 1 2 3 4)]) + #:final (= i 2) + (add1 i))) + ;; ---------------------------------------- (report-errs) diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index 8f9a1c44a0..0442a82a3f 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -1,6 +1,8 @@ Version 5.3.0.24 Added PLTCOMPILEDROOTS and --compiled/-R command-line flag -Added `reroot-path' +Added reroot-path +Added #:break and #:final clauses to for forms +syntax/for-body: added racket/set: added set-first and set-rest, sets are streams Version 5.3.0.23