From f4316e9808aa1074fd64d9c5ff0973d899805be1 Mon Sep 17 00:00:00 2001 From: Wing Hei Chan Date: Tue, 16 Jan 2024 10:00:12 +0800 Subject: fix `for/fold` binding in the presence of `#:result` This bug was introduced in 3b5b0a7. The `fold-var`s incorrectly scoped over the whole `for/fold` expansion, while the "remaining weirdness" behavior was that outermost iteration clauses should not see the `fold-var`s. Also revert the `for/foldr` change that appears to be incorrect. Unlike `for/fold`, `for/foldr` does not need to use this approach, because `fold-var`s are only visible to the body. Related to #4898. (cherry picked from commit a220d4da4d846a50f4da93a9771e277241cdaac9) --- pkgs/racket-test-core/tests/racket/for.rktl | 109 +++++++++++++++++++++++++++- racket/collects/racket/private/for.rkt | 90 +++++++++++------------ 2 files changed, 151 insertions(+), 48 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/for.rktl b/pkgs/racket-test-core/tests/racket/for.rktl index 3640d28c2d..1fafa28b4a 100644 --- a/pkgs/racket-test-core/tests/racket/for.rktl +++ b/pkgs/racket-test-core/tests/racket/for.rktl @@ -304,12 +304,12 @@ (test 0 'break-0 (for*/fold ([x 0]) ([x '(1)] #:break #true [y '(3)]) (add1 x))) (test 2 'break-2 (for*/fold ([x 0]) ([x '(1)]) #:break #false (add1 x))) -(test 2 'break-2 (for*/fold ([x 0]) ([x '(1)] [y '(3)]) #:break false (add1 x))) +(test 2 'break-2 (for*/fold ([x 0]) ([x '(1)] [y '(3)]) #:break #false (add1 x))) (test 2 'break-2 (for*/fold ([x 0]) ([x '(1)] #:break #false) (add1 x))) (test 2 'break-2 (for*/fold ([x 0]) ([x '(1)] [y '(3)] #:break #false) (add1 x))) (test 2 'break-2 (for*/fold ([x 0]) ([x '(1)] #:break #false [y '(3)]) (add1 x))) -(test 2 'break-v2 (for*/fold ([x 0]) ([x '(1)] [y (in-value 3)]) #:break false (add1 x))) +(test 2 'break-v2 (for*/fold ([x 0]) ([x '(1)] [y (in-value 3)]) #:break #false (add1 x))) (test 2 'break-v2 (for*/fold ([x 0]) ([x '(1)] [y (in-value 3)] #:break #false) (add1 x))) (test 2 'break-v2 (for*/fold ([x 0]) ([x '(1)] #:break #false [y (in-value 3)]) (add1 x))) @@ -1520,6 +1520,111 @@ (for ([i (in-digits 12)]) i)) +;; ---------------------------------------- +;; Check more fold variables in outermost iteration clauses + +(test '(3 2 1) + 'for/fold-var-in-outermost + (let ([a '(1 2 3)]) + (for/fold ([a '()]) + ([x (in-list a)]) + (cons x a)))) + +(test '(1 2 3) + 'for/fold-var-in-outermost/result + (let ([a '(1 2 3)]) + (for/fold ([a '()] + #:result (reverse a)) + ([x (in-list a)]) + (cons x a)))) + +(test '(1 2 3) + 'for/foldr-var-in-outermost + (let ([a '(1 2 3)]) + (for/foldr ([a '()]) + ([x (in-list a)]) + (cons x a)))) + +(test '(3 2 1) + 'for/foldr-var-in-outermost/result + (let ([a '(1 2 3)]) + (for/foldr ([a '()] + #:result (reverse a)) + ([x (in-list a)]) + (cons x a)))) + +(test '(1 2 3) + 'for/foldr-var-in-outermost/delay + (let ([a '(1 2 3)]) + (force + (for/foldr ([a '()] + #:delay) + ([x (in-list a)]) + (cons x (force a)))))) + +(test '(3 2 1) + 'for/foldr-var-in-outermost/delay/result + (let ([a '(1 2 3)]) + (for/foldr ([a '()] + #:delay + #:result (reverse (force a))) + ([x (in-list a)]) + (cons x (force a))))) + +(test '() + 'for/fold-var-not-in-outermost + (let ([a '(1 2 3)]) + (for/fold ([a '()]) + (#:when #t + [x (in-list a)]) + (cons x a)))) + +(test '() + 'for/fold-var-not-in-outermost/result + (let ([a '(1 2 3)]) + (for/fold ([a '()] + #:result (reverse a)) + (#:when #t + [x (in-list a)]) + (cons x a)))) + +(test '(1 2 3) + 'for/foldr-var-not-in-outermost + (let ([a '(1 2 3)]) + (for/foldr ([a '()]) + (#:when #t + [x (in-list a)]) + (cons x a)))) + +(test '(3 2 1) + 'for/foldr-var-not-in-outermost/result + (let ([a '(1 2 3)]) + (for/foldr ([a '()] + #:result (reverse a)) + (#:when #t + [x (in-list a)]) + (cons x a)))) + +(test '(1 2 3) + 'for/foldr-var-not-in-outermost/delay + (let ([a '(1 2 3)]) + (force + (for/foldr ([a '()] + #:delay) + (#:when #t + [x (in-list a)]) + (cons x (force a)))))) + +(test '(3 2 1) + 'for/foldr-var-not-in-outermost/delay/result + (let ([a '(1 2 3)]) + (for/foldr ([a '()] + #:delay + #:result (reverse (force a))) + (#:when #t + [x (in-list a)]) + (cons x (force a))))) + ;; ---------------------------------------- (report-errs) diff --git a/racket/collects/racket/private/for.rkt b/racket/collects/racket/private/for.rkt index 10cb8d98ef..78ad2f36e9 100644 --- a/racket/collects/racket/private/for.rkt +++ b/racket/collects/racket/private/for.rkt @@ -1546,26 +1546,26 @@ ...) next-k))) - (define-for-syntax ((make-inner-recur/foldr/strict int-vars) stx) + (define-for-syntax ((make-inner-recur/foldr/strict fold-vars) stx) (syntax-case stx () [(_ () [expr ...] next-k) - #`(let-values ([#,(map syntax-local-introduce int-vars) next-k]) + #`(let-values ([#,(map syntax-local-introduce fold-vars) next-k]) expr ...)])) - (define-for-syntax ((make-inner-recur/foldr/lazy int-vars delayed-id delayer-id) stx) + (define-for-syntax ((make-inner-recur/foldr/lazy fold-vars delayed-id delayer-id) stx) (syntax-case stx () [(_ () [expr ...] next-k) - (with-syntax ([(int-var ...) (map syntax-local-introduce int-vars)] + (with-syntax ([(fold-var ...) (map syntax-local-introduce fold-vars)] [delayed-id (syntax-local-introduce delayed-id)] [delayer-id delayer-id]) #`(let*-values ([(delayed-id) (delayer-id next-k)] #,@(cond - [(= (length int-vars) 1) - #`([(int-var ...) delayed-id])] + [(= (length fold-vars) 1) + #`([(fold-var ...) delayed-id])] [(delayer? (syntax-local-value #'delayer-id (lambda () #f))) - #`([(int-var) (delayer-id (let-values ([(int-var ...) (force delayed-id)]) - int-var))] + #`([(fold-var) (delayer-id (let-values ([(fold-var ...) (force delayed-id)]) + fold-var))] ...)] [else #'()])) expr ...))])) @@ -1854,41 +1854,40 @@ [delayed-id delayed-id] [delayer-id delayer-id]) (check-identifier-bindings #'orig-stx #`(fold-var ... delayed-id) "accumulator" (void)) - (with-syntax ([(int-var ...) - (map (lambda (fold-var) - (datum->syntax fold-var - (string->uninterned-symbol - (symbol->string (syntax-e fold-var))) - fold-var - fold-var)) - (syntax->list #'(fold-var ...)))]) - (cond - [right? - (define loop-stx - (quasisyntax/loc #'orig-stx - (for/foldX/derived [orig-stx inner-recur/foldr #,for*? #f ()] - () ([fold-var (make-fold-var 'int-var)] ...) - (done-k-proc) - (done-k-proc) - #f - . rest))) + (cond + [right? + (define loop-stx (quasisyntax/loc #'orig-stx - (let ([done-k-proc (lambda () (#%expression (values* fold-init ...)))]) - (define-syntax inner-recur/foldr - #,(if delay? - #'(make-inner-recur/foldr/lazy - (list (quote-syntax int-var) ...) - (quote-syntax delayed-id) - (quote-syntax delayer-id)) - #'(make-inner-recur/foldr/strict - (list (quote-syntax int-var) ...)))) - #,(if result-expr - ;; Make sure `fold-var`s in `result-expr` are also delayed, if relevant - (let ([result-expr #`(letrec-syntax ([fold-var (make-fold-var 'int-var)] ...) - #,result-expr)]) - #`(inner-recur/foldr () [#,result-expr] #,loop-stx)) - loop-stx)))] - [else + (for/foldX/derived [orig-stx inner-recur/foldr #,for*? #f ()] + () + () + (done-k-proc) + (done-k-proc) + #f + . rest))) + (quasisyntax/loc #'orig-stx + (let ([done-k-proc (lambda () (values* fold-init ...))]) + (define-syntax inner-recur/foldr + #,(if delay? + #'(make-inner-recur/foldr/lazy + (list (quote-syntax fold-var) ...) + (quote-syntax delayed-id) + (quote-syntax delayer-id)) + #'(make-inner-recur/foldr/strict + (list (quote-syntax fold-var) ...)))) + #,(if result-expr + ;; Make sure `fold-var`s in `result-expr` are also delayed, if relevant + #`(inner-recur/foldr () [#,result-expr] #,loop-stx) + loop-stx)))] + [else + (with-syntax ([(int-var ...) + (map (lambda (fold-var) + (datum->syntax fold-var + (string->uninterned-symbol + (symbol->string (syntax-e fold-var))) + fold-var + fold-var)) + (syntax->list #'(fold-var ...)))]) (quasisyntax/loc #'orig-stx (let ([int-var (let ([fold-var fold-init]) fold-var)] @@ -1902,10 +1901,9 @@ . rest))]) (if result-expr (quasisyntax/loc #'orig-stx - (letrec-syntax ([fold-var (make-fold-var 'int-var)] ...) - (let-values ([(fold-var ...) #,loop-stx]) - #,result-expr))) - loop-stx))))]))))] + (let-values ([(fold-var ...) #,loop-stx]) + #,result-expr)) + loop-stx)))))])))] [(_ orig-stx . rst) (raise-syntax-error #f "bad syntax" #'orig-stx)])) -- cgit v1.2.3