compile simple for/list
to avoid reverse
Compile a `for[*]/list` form to behave more like `map` by `cons`ing onto a recursive call, instead of accumulating a list to reverse. This style of compilation requires a different strategy than before. A form like (for*/fold ([v 0]) ([i (in-range M)] [j (in-range N)]) j) compiles as nested loops, like (let i-loop ([v 0] [i 0]) (if (unsafe-fx< i M) (i-loop (let j-loop ([v v] [j 0]) (if (unsafe-fx< j N) (j-loop (SEL v j) (unsafe-fx+ j 1)) v)) (unsafe-fx+ i 1)) v)) instead of mutually recursive loops, like (let i-loop ([v 0] [i 0]) (if (unsafe-fx< i M) (let j-loop ([v v] [j 0]) (if (unsafe-fx< j N) (j-loop (SEL v j) (unsafe-fx+ j 1)) (i-loop v (unsafe-fx+ i 1)))) v)) The former runs slightly faster. It's difficult to say why, for certain, but the reason may be that the JIT can generate more direct jumps for self-recursion than mutual recursion. (In the case of mutual recursion, the JIT has to generate one function or the other to get a known address to jump to.) Nested loops con't work for `for/list`, though, since each `cons` needs to be wrapped around the whole continuation of the computation. So, the `for` compiler adapts, depending on the initial form. (With a base, CPS-like approach to support `for/list`, it's easy to use the nested mode when it works by just not fully CPSing.) Forms that use `#:break` or `#:final` use the mutual-recursion approach, because `#:break` and #:final` are easier and faster that way. Internallt, that simplies the imoplementation. Externally, a `for` loop with `#:break` or `#:final` can be slightly faster than before.
This commit is contained in:
parent
8de6f581f3
commit
5e94a906cd
|
@ -32,21 +32,39 @@
|
||||||
(car (member (list id ...) `((v2 ...) ...)))))
|
(car (member (list id ...) `((v2 ...) ...)))))
|
||||||
(void)))]))
|
(void)))]))
|
||||||
|
|
||||||
|
;; Tests use `for/list`, but plain `for` may compile differently:
|
||||||
|
(define-syntax-rule (for/list~ binds expr)
|
||||||
|
(let ([l null])
|
||||||
|
(for binds (set! l (cons expr l)))
|
||||||
|
(reverse l)))
|
||||||
|
(define-syntax-rule (for*/list~ binds expr)
|
||||||
|
(let ([l null])
|
||||||
|
(for* binds (set! l (cons expr l)))
|
||||||
|
(reverse l)))
|
||||||
|
|
||||||
(define-syntax test-sequence
|
(define-syntax test-sequence
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
[(_ [seq] gen) ; we assume that seq has at least 2 elements, and all are unique
|
[(_ [seq] gen) ; we assume that seq has at least 2 elements, and all are unique
|
||||||
(begin
|
(begin
|
||||||
;; Some tests specific to single-values:
|
;; Some tests specific to single-values:
|
||||||
(test `seq 'gen (for/list ([i gen]) i))
|
(test `seq 'gen (for/list ([i gen]) i))
|
||||||
|
(test `seq 'gen (for/list~ ([i gen]) i))
|
||||||
(test `seq 'gen (for/list ([i gen][b gen]) i))
|
(test `seq 'gen (for/list ([i gen][b gen]) i))
|
||||||
|
(test `seq 'gen (for/list~ ([i gen][b gen]) i))
|
||||||
(test `seq 'gen (for/list ([i gen][b gen]) b))
|
(test `seq 'gen (for/list ([i gen][b gen]) b))
|
||||||
|
(test `seq 'gen (for/list~ ([i gen][b gen]) b))
|
||||||
(test `seq 'gen (for*/list ([i gen][b '(#t)]) i))
|
(test `seq 'gen (for*/list ([i gen][b '(#t)]) i))
|
||||||
(test (map (lambda (x) #t) `seq) 'gen (for*/list ([i gen][b '(#t)]) b))
|
(test (map (lambda (x) #t) `seq) 'gen (for*/list ([i gen][b '(#t)]) b))
|
||||||
(test (append `seq `seq) 'gen (for*/list ([b '(#f #t)][i gen]) i))
|
(test (append `seq `seq) 'gen (for*/list ([b '(#f #t)][i gen]) i))
|
||||||
|
(test (append `seq `seq) 'gen (for*/list~ ([b '(#f #t)][i gen]) i))
|
||||||
(test (append `seq `seq) 'gen (for/list ([b '(#f #t)] #:when #t [i gen]) i))
|
(test (append `seq `seq) 'gen (for/list ([b '(#f #t)] #:when #t [i gen]) i))
|
||||||
|
(test (append `seq `seq) 'gen (for/list~ ([b '(#f #t)] #:when #t [i gen]) i))
|
||||||
(test (append `seq `seq) 'gen (for/list ([b '(#t #t #f)] #:when b [i gen]) i))
|
(test (append `seq `seq) 'gen (for/list ([b '(#t #t #f)] #:when b [i gen]) i))
|
||||||
|
(test (append `seq `seq) 'gen (for/list~ ([b '(#t #t #f)] #:when b [i gen]) i))
|
||||||
(test (append `seq `seq) 'gen (for/list ([b '(#f #t)] #:unless #f [i gen]) i))
|
(test (append `seq `seq) 'gen (for/list ([b '(#f #t)] #:unless #f [i gen]) i))
|
||||||
|
(test (append `seq `seq) 'gen (for/list~ ([b '(#f #t)] #:unless #f [i gen]) i))
|
||||||
(test (append `seq `seq) 'gen (for/list ([b '(#f #f #t)] #:unless b [i gen]) i))
|
(test (append `seq `seq) 'gen (for/list ([b '(#f #f #t)] #:unless b [i gen]) i))
|
||||||
|
(test (append `seq `seq) 'gen (for/list~ ([b '(#f #f #t)] #:unless b [i gen]) i))
|
||||||
(test `seq 'gen (let ([g gen]) (for/list ([i g]) i)))
|
(test `seq 'gen (let ([g gen]) (for/list ([i g]) i)))
|
||||||
(test `seq 'gen (let ([r null])
|
(test `seq 'gen (let ([r null])
|
||||||
(for ([i gen]) (set! r (cons i r)))
|
(for ([i gen]) (set! r (cons i r)))
|
||||||
|
|
|
@ -1336,21 +1336,57 @@
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
[(_ x) x]
|
[(_ x) x]
|
||||||
[(_ x ...) (values x ...)]))
|
[(_ x ...) (values x ...)]))
|
||||||
|
|
||||||
|
(define-syntax-rule (inner-recur/fold (fold-var ...) (let () expr ...) next-k)
|
||||||
|
(let-values ([(fold-var ...) (let () expr ...)])
|
||||||
|
next-k))
|
||||||
|
|
||||||
|
(define-syntax-rule (inner-recur/list (fold-var ...) (let () expr ...) next-k)
|
||||||
|
(let-values ([(fold-var ... elem) (let () expr ...)])
|
||||||
|
(let-values ([(fold-var ... result) next-k])
|
||||||
|
(values* fold-var ... (cons elem result)))))
|
||||||
|
|
||||||
|
(define-syntax (push-under-break stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ inner-recur fold-vars [expr ...] next-k break-k final?-id)
|
||||||
|
(let loop ([l (syntax->list #'(expr ...))] [pre-accum null])
|
||||||
|
(cond
|
||||||
|
[(null? l)
|
||||||
|
;; No #:break form
|
||||||
|
#'(inner-recur fold-vars (let-values () expr ...) (if final?-id break-k next-k))]
|
||||||
|
[(eq? '#:break (syntax-e (car l)))
|
||||||
|
;; Found a #:break form
|
||||||
|
#`(let-values ()
|
||||||
|
#,@(reverse pre-accum)
|
||||||
|
(if #,(cadr l)
|
||||||
|
break-k
|
||||||
|
(push-under-break inner-recur fold-vars #,(cddr l) next-k break-k final?-id)))]
|
||||||
|
[(eq? '#:final (syntax-e (car l)))
|
||||||
|
;; Found a #:final form
|
||||||
|
#`(let-values ()
|
||||||
|
#,@(reverse pre-accum)
|
||||||
|
(let ([final? (or #,(cadr l) final?-id)])
|
||||||
|
(push-under-break inner-recur fold-vars #,(cddr l) next-k break-k final?)))]
|
||||||
|
[else (loop (cdr l) (cons (car l) pre-accum))]))]))
|
||||||
|
|
||||||
(define-syntax (for/foldX/derived stx)
|
(define-syntax (for/foldX/derived stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
;; Done case (no more clauses, and no generated clauses to emit):
|
;; Done case (no more clauses, and no generated clauses to emit):
|
||||||
[(_ [orig-stx nested? emit? ()] ([fold-var fold-init] ...) ()
|
[(_ [orig-stx inner-recur nested? emit? ()] ([fold-var fold-init] ...) next-k break-k final?-id ()
|
||||||
expr1 expr ...)
|
expr1 expr ...)
|
||||||
#`(let ([fold-var fold-init] ...)
|
(if (syntax-e #'inner-recur)
|
||||||
(let-values ([(fold-var ...) (let () expr1 expr ...)])
|
;; General, non-nested-loop approach:
|
||||||
(values fold-var ...)))]
|
#`(let ([fold-var fold-init] ...)
|
||||||
|
(push-under-break inner-recur (fold-var ...) [expr1 expr ...] next-k break-k final?-id))
|
||||||
|
;; Nested-loop approach (which is slightly faster when it works):
|
||||||
|
#`(let ([fold-var fold-init] ...)
|
||||||
|
(let-values ([(fold-var ...) (let () expr1 expr ...)])
|
||||||
|
(values fold-var ...))))]
|
||||||
;; Switch-to-emit case (no more clauses to generate):
|
;; Switch-to-emit case (no more clauses to generate):
|
||||||
[(_ [orig-stx nested? #f binds] ([fold-var fold-init] ...) () . body)
|
[(_ [orig-stx inner-recur nested? #f binds] fold-bind next-k break-k final?-id () . body)
|
||||||
#`(for/foldX/derived [orig-stx nested? #t binds]
|
#`(for/foldX/derived [orig-stx inner-recur nested? #t binds] fold-bind next-k break-k final?-id () . body)]
|
||||||
([fold-var fold-init] ...) () . body)]
|
|
||||||
;; Emit case:
|
;; Emit case:
|
||||||
[(_ [orig-stx nested? #t binds] ([fold-var fold-init] ...) rest expr1 . body)
|
[(_ [orig-stx inner-recur nested? #t binds] ([fold-var fold-init] ...) next-k break-k final?-id rest expr1 . body)
|
||||||
(with-syntax ([(([outer-binding ...]
|
(with-syntax ([(([outer-binding ...]
|
||||||
outer-check
|
outer-check
|
||||||
[loop-binding ...]
|
[loop-binding ...]
|
||||||
|
@ -1362,168 +1398,130 @@
|
||||||
(quasisyntax/loc #'orig-stx
|
(quasisyntax/loc #'orig-stx
|
||||||
(let-values (outer-binding ... ...)
|
(let-values (outer-binding ... ...)
|
||||||
outer-check ...
|
outer-check ...
|
||||||
#,(syntax/loc #'orig-stx
|
#,(quasisyntax/loc #'orig-stx
|
||||||
(let for-loop ([fold-var fold-init] ...
|
(let for-loop ([fold-var fold-init] ...
|
||||||
loop-binding ... ...)
|
loop-binding ... ...)
|
||||||
(if (and pos-guard ...)
|
(if (and pos-guard ...)
|
||||||
(let-values (inner-binding ... ...)
|
(let-values (inner-binding ... ...)
|
||||||
(if (and pre-guard ...)
|
(if (and pre-guard ...)
|
||||||
(let-values ([(fold-var ...)
|
#,(if (syntax-e #'inner-recur)
|
||||||
(for/foldX/derived [orig-stx nested? #f ()]
|
;; The general non-nested-loop approach:
|
||||||
([fold-var fold-var] ...)
|
#'(let ([post-guard-var (lambda (fold-var ...) (and post-guard ...))])
|
||||||
rest expr1 . body)])
|
(for/foldX/derived [orig-stx inner-recur nested? #f ()]
|
||||||
(if (and post-guard ...)
|
([fold-var fold-var] ...)
|
||||||
(for-loop fold-var ... loop-arg ... ...)
|
(if (post-guard-var fold-var ...)
|
||||||
(values* fold-var ...)))
|
(for-loop fold-var ... loop-arg ... ...)
|
||||||
(values* fold-var ...)))
|
next-k)
|
||||||
(values* fold-var ...)))))))]
|
break-k final?-id
|
||||||
|
rest expr1 . body))
|
||||||
|
;; The specialized nested-loop approach, which is
|
||||||
|
;; slightly faster when it works:
|
||||||
|
#'(let-values ([(fold-var ...)
|
||||||
|
(for/foldX/derived [orig-stx inner-recur nested? #f ()]
|
||||||
|
([fold-var fold-var] ...)
|
||||||
|
next-k break-k final?-id
|
||||||
|
rest expr1 . body)])
|
||||||
|
(if (and post-guard ... (not final?-id))
|
||||||
|
(for-loop fold-var ... loop-arg ... ...)
|
||||||
|
next-k)))
|
||||||
|
next-k))
|
||||||
|
next-k))))))]
|
||||||
;; Bad body cases:
|
;; Bad body cases:
|
||||||
[(_ [orig-stx . _] fold-bind ())
|
[(_ [orig-stx . _] fold-bind next-k break-k final?-id ())
|
||||||
(raise-syntax-error
|
(raise-syntax-error
|
||||||
#f "missing body expression after sequence bindings" #'orig-stx)]
|
#f "missing body expression after sequence bindings" #'orig-stx)]
|
||||||
[(_ [orig-stx . _] fold-bind () . rest)
|
[(_ [orig-stx . _] fold-bind next-k break-k final?-id () . rest)
|
||||||
(raise-syntax-error
|
(raise-syntax-error
|
||||||
#f "bad syntax (illegal use of `.') after sequence bindings" #'orig-stx)]
|
#f "bad syntax (illegal use of `.') after sequence bindings" #'orig-stx)]
|
||||||
;; Guard case, no pending emits:
|
;; Guard case, no pending emits:
|
||||||
[(_ [orig-stx nested? #f ()] ([fold-var fold-init] ...) (#:when expr . rest) . body)
|
[(_ [orig-stx inner-recur nested? #f ()] ([fold-var fold-init] ...) next-k break-k final?-id (#:when expr . rest) . body)
|
||||||
#'(let ([fold-var fold-init] ...)
|
#'(let ([fold-var fold-init] ...)
|
||||||
(if expr
|
(if expr
|
||||||
(for/foldX/derived [orig-stx nested? #f ()]
|
(for/foldX/derived [orig-stx inner-recur nested? #f ()]
|
||||||
([fold-var fold-var] ...) rest . body)
|
([fold-var fold-var] ...) next-k break-k final?-id rest . body)
|
||||||
(values* fold-var ...)))]
|
next-k))]
|
||||||
;; Guard case, pending emits need to be flushed first
|
|
||||||
[(frm [orig-stx nested? #f binds] ([fold-var fold-init] ...)
|
|
||||||
(#:when expr . rest) . body)
|
|
||||||
#'(frm [orig-stx nested? #t binds] ([fold-var fold-init] ...)
|
|
||||||
(#:when expr . rest) . body)]
|
|
||||||
;; Negative guard case, no pending emits:
|
;; Negative guard case, no pending emits:
|
||||||
[(_ [orig-stx nested? #f ()] ([fold-var fold-init] ...) (#:unless expr . rest) . body)
|
[(_ [orig-stx inner-recur nested? #f ()] ([fold-var fold-init] ...) next-k break-k final?-id (#:unless expr . rest) . body)
|
||||||
#'(let ([fold-var fold-init] ...)
|
#'(let ([fold-var fold-init] ...)
|
||||||
(if expr
|
(if expr
|
||||||
(values* fold-var ...)
|
(if final?-id break-k next-k)
|
||||||
(for/foldX/derived [orig-stx nested? #f ()]
|
(for/foldX/derived [orig-stx inner-recur nested? #f ()]
|
||||||
([fold-var fold-var] ...) rest . body)))]
|
([fold-var fold-var] ...) next-k break-k final?-id rest . body)))]
|
||||||
;; Negative guard case, pending emits need to be flushed first
|
;; Break case, no pending emits:
|
||||||
[(frm [orig-stx nested? #f binds] ([fold-var fold-init] ...)
|
[(_ [orig-stx inner-recur nested? #f ()] ([fold-var fold-init] ...) next-k break-k final?-id (#:break expr . rest) . body)
|
||||||
(#:unless expr . rest) . body)
|
#'(let ([fold-var fold-init] ...)
|
||||||
#'(frm [orig-stx nested? #t binds] ([fold-var fold-init] ...)
|
(if expr
|
||||||
(#:unless expr . rest) . body)]
|
break-k
|
||||||
|
(for/foldX/derived [orig-stx inner-recur nested? #f ()]
|
||||||
|
([fold-var fold-var] ...) next-k break-k final?-id rest . body)))]
|
||||||
|
;; Final case, no pending emits:
|
||||||
|
[(_ [orig-stx inner-recur nested? #f ()] ([fold-var fold-init] ...) next-k break-k final?-id (#:final expr . rest) . body)
|
||||||
|
#'(let ([fold-var fold-init] ...)
|
||||||
|
(let ([final? (or expr final?-id)])
|
||||||
|
(for/foldX/derived [orig-stx inner-recur nested? #f ()]
|
||||||
|
([fold-var fold-var] ...) next-k break-k final? rest . body)))]
|
||||||
|
;; Keyword case, pending emits need to be flushed first
|
||||||
|
[(frm [orig-stx inner-recur nested? #f binds] ([fold-var fold-init] ...) next-k break-k final?-id (kw expr . rest) . body)
|
||||||
|
(or (eq? (syntax-e #'kw) '#:when)
|
||||||
|
(eq? (syntax-e #'kw) '#:unless)
|
||||||
|
(eq? (syntax-e #'kw) '#:break)
|
||||||
|
(eq? (syntax-e #'kw) '#:final))
|
||||||
|
#'(frm [orig-stx inner-recur nested? #t binds] ([fold-var fold-init] ...) next-k break-k final?-id (kw expr . rest) . body)]
|
||||||
;; Convert single-value form to multi-value form:
|
;; Convert single-value form to multi-value form:
|
||||||
[(_ [orig-stx nested? #f binds] fold-bind ([id rhs] . rest) . body)
|
[(_ [orig-stx inner-recur nested? #f binds] fold-bind next-k break-k final?-id ([id rhs] . rest) . body)
|
||||||
(identifier? #'id)
|
(identifier? #'id)
|
||||||
#'(for/foldX/derived [orig-stx nested? #f binds] fold-bind
|
#'(for/foldX/derived [orig-stx inner-recur nested? #f binds] fold-bind next-k break-k final?-id
|
||||||
([(id) rhs] . rest) . body)]
|
([(id) rhs] . rest) . body)]
|
||||||
;; If we get here in single-value mode, then it's a bad clause:
|
;; If we get here in single-value mode, then it's a bad clause:
|
||||||
[(_ [orig-stx #f #f nested? #f binds] fold-bind (clause . rest) . body)
|
[(_ [orig-stx inner-recur #f #f nested? #f binds] fold-bind next-k break-k final?-id (clause . rest) . body)
|
||||||
(raise-syntax-error
|
(raise-syntax-error
|
||||||
#f "bad sequence binding clause" #'orig-stx #'clause)]
|
#f "bad sequence binding clause" #'orig-stx #'clause)]
|
||||||
;; Expand one multi-value clause, and push it into the results to emit:
|
;; Expand one multi-value clause, and push it into the results to emit:
|
||||||
[(frm [orig-stx nested? #f binds] ([fold-var fold-init] ...)
|
[(frm [orig-stx inner-recur nested? #f binds] ([fold-var fold-init] ...) next-k break-k final?-id (clause . rest) . body)
|
||||||
(clause . rest) . body)
|
|
||||||
(with-syntax ([bind (expand-clause #'orig-stx #'clause)])
|
(with-syntax ([bind (expand-clause #'orig-stx #'clause)])
|
||||||
(let ([r #`(frm [orig-stx nested? nested? (bind . binds)]
|
(let ([r #`(frm [orig-stx inner-recur nested? nested? (bind . binds)]
|
||||||
([fold-var fold-init] ...) rest . body)]
|
([fold-var fold-init] ...) next-k break-k final?-id rest . body)]
|
||||||
[d (syntax-property #'bind 'disappeared-use)])
|
[d (syntax-property #'bind 'disappeared-use)])
|
||||||
(if d
|
(if d
|
||||||
(syntax-property r 'disappeared-use d)
|
(syntax-property r 'disappeared-use d)
|
||||||
r)))]
|
r)))]
|
||||||
[(_ [orig-stx . _] for-bind clauses . _)
|
[(_ [orig-stx . _] for-bind next-k break-k final?-id clauses . _)
|
||||||
(not (syntax->list #'clauses))
|
(not (syntax->list #'clauses))
|
||||||
(raise-syntax-error #f "bad sequence binding clauses" #'orig-stx #'clauses)]
|
(raise-syntax-error #f "bad sequence binding clauses" #'orig-stx #'clauses)]
|
||||||
[(_ [orig-stx . _] . _)
|
[(_ [orig-stx . _] . _)
|
||||||
(raise-syntax-error #f "bad syntax" #'orig-stx)]))
|
(raise-syntax-error #f "bad syntax" #'orig-stx)]))
|
||||||
|
|
||||||
(define-syntax (for/foldX/derived/break stx)
|
(define-syntax (for/foldX/derived/final stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ [orig-stx nested? emit? ()] ([id init] ...) (clause ...) body ...)
|
[(_ [orig-stx nested?] fold-bind done-k (clause ...) expr ...)
|
||||||
(ormap (lambda (form)
|
;; If there's a `#:break` or `#:final`, then we need to use the
|
||||||
(or (eq? (syntax-e form) '#:break)
|
;; non-nested loop approach to implement them:
|
||||||
(eq? (syntax-e form) '#:final)))
|
(ormap (lambda (s) (or (eq? '#:break (syntax-e s)) (eq? '#:final (syntax-e s))))
|
||||||
(syntax->list #'(clause ... body ...)))
|
(syntax->list #'(clause ... expr ...)))
|
||||||
;; Add an accumulator for short-circuiting
|
#'(for/foldX/derived [orig-stx inner-recur/fold nested? #f ()] fold-bind done-k done-k #f (clause ...) expr ...)]
|
||||||
(with-syntax ([body
|
[(_ [orig-stx nested?] fold-bind done-k . rest)
|
||||||
(let loop ([bodys (syntax->list #'(body ...))] [accum null])
|
;; Otherwise, allow compilation as nested loops, which can be slightly faster:
|
||||||
(cond
|
#'(for/foldX/derived [orig-stx #f nested? #f ()] fold-bind done-k done-k #f . rest)]))
|
||||||
[(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
|
(define-syntax for/fold/derived
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
[(_ orig-stx . rest)
|
[(_ orig-stx ([fold-var finid-init] ...) . rest)
|
||||||
(for/foldX/derived/break [orig-stx #f #f ()] . rest)]))
|
(for/foldX/derived/final [orig-stx #f] ([fold-var finid-init] ...) (values* fold-var ...) . rest)]))
|
||||||
|
|
||||||
(define-syntax for*/fold/derived
|
(define-syntax for*/fold/derived
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
[(_ orig-stx . rest)
|
[(_ orig-stx ([fold-var finid-init] ...) . rest)
|
||||||
(for/foldX/derived/break [orig-stx #t #f ()] . rest)]))
|
(for/foldX/derived/final [orig-stx #t] ([fold-var finid-init] ...) (values* fold-var ...) . rest)]))
|
||||||
|
|
||||||
|
(define-syntax for/list/derived
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ orig-stx () . rest)
|
||||||
|
(for/foldX/derived [orig-stx inner-recur/list #f #f ()] () null null #f . rest)]))
|
||||||
|
|
||||||
|
(define-syntax for*/list/derived
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ orig-stx () . rest)
|
||||||
|
(for/foldX/derived [orig-stx inner-recur/list #t #f ()] () null null #f . rest)]))
|
||||||
|
|
||||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; derived `for' syntax
|
;; derived `for' syntax
|
||||||
|
@ -1621,11 +1619,8 @@
|
||||||
(lambda (x) x)
|
(lambda (x) x)
|
||||||
(lambda (x) `(,#'begin ,x ,#'(void))))
|
(lambda (x) `(,#'begin ,x ,#'(void))))
|
||||||
|
|
||||||
(define-for-variants (for/list for*/list)
|
(define-syntax-via-derived for/list for/list/derived () (lambda (x) x) (lambda (x) x) (lambda (x) x))
|
||||||
([fold-var null])
|
(define-syntax-via-derived for*/list for*/list/derived () (lambda (x) x) (lambda (x) x) (lambda (x) x))
|
||||||
(lambda (x) `(,#'alt-reverse ,x))
|
|
||||||
(lambda (x) x)
|
|
||||||
(lambda (x) `(,#'cons ,x ,#'fold-var)))
|
|
||||||
|
|
||||||
(define (grow-vector vec)
|
(define (grow-vector vec)
|
||||||
(define n (vector-length vec))
|
(define n (vector-length vec))
|
||||||
|
|
Loading…
Reference in New Issue
Block a user