Index: for.ss =================================================================== --- for.ss (revision 15592) +++ for.ss (working copy) @@ -12,6 +12,7 @@ "stxcase-scheme.ss")) (#%provide for/fold for*/fold + for/fold/first for*/fold/first for for* for/list for*/list for/lists for*/lists @@ -23,7 +24,8 @@ for/hasheq for*/hasheq for/fold/derived for*/fold/derived - + for/fold/first/derived for*/fold/first/derived + (rename *in-range in-range) (rename *in-naturals in-naturals) (rename *in-list in-list) @@ -721,15 +723,19 @@ (define-syntax (for/foldX/derived stx) (syntax-case stx () ;; Done case (no more clauses, and no generated clauses to emit): - [(_ [orig-stx nested? emit? ()] ([fold-var fold-init] ...) () + [(_ [orig-stx nested? emit? first? ()] ([fold-var fold-init] ...) () expr1 expr ...) #`(let ([fold-var fold-init] ...) (let () expr1 expr ...))] ;; Switch-to-emit case (no more clauses to generate): - [(_ [orig-stx nested? #f binds] ([fold-var fold-init] ...) () . body) - #`(for/foldX/derived [orig-stx nested? #t binds] + [(_ [orig-stx nested? #f first? binds] ([fold-var fold-init] ...) () . body) + #`(for/foldX/derived [orig-stx nested? #t first? binds] ([fold-var fold-init] ...) () . body)] + ;; Emit case, wants the first result, but there is none: + [(_ [orig-stx nested? #t #t binds] () rest expr1 . body) + (raise-syntax-error #f "missing at least one binding" #'orig-stx)] ;; Emit case: - [(_ [orig-stx nested? #t binds] ([fold-var fold-init] ...) rest expr1 . body) + [(_ [orig-stx nested? #t first? binds] + ([fold-var fold-init] ...) rest expr1 . body) (with-syntax ([(([outer-binding ...] outer-check [loop-binding ...] @@ -737,21 +743,28 @@ [inner-binding ...] pre-guard post-guard - [loop-arg ...]) ...) (reverse (syntax->list #'binds))]) + [loop-arg ...]) ...) + (reverse (syntax->list #'binds))] + [return (if (syntax-e #'first?) + (car (syntax-e #'(fold-var ...))) + #'(values* fold-var ...))]) #'(let-values (outer-binding ... ...) outer-check ... (let for-loop ([fold-var fold-init] ... loop-binding ... ...) (if (and pos-guard ...) - (let-values (inner-binding ... ...) - (if (and pre-guard ...) - (let-values ([(fold-var ...) - (for/foldX/derived [orig-stx nested? #f ()] ([fold-var fold-var] ...) rest expr1 . body)]) - (if (and post-guard ...) - (for-loop fold-var ... loop-arg ... ...) - (values* fold-var ...))) - (values* fold-var ...))) - (values* fold-var ...)))))] + (let-values (inner-binding ... ...) + (if (and pre-guard ...) + (let-values ([(fold-var ...) + (for/foldX/derived + [orig-stx nested? #f first? ()] + ([fold-var fold-var] ...) + rest expr1 . body)]) + (if (and post-guard ...) + (for-loop fold-var ... loop-arg ... ...) + return)) + return)) + return))))] ;; Bad body cases: [(_ [orig-stx . _] fold-bind ()) (raise-syntax-error @@ -759,32 +772,40 @@ [(_ [orig-stx . _] fold-bind () . rest) (raise-syntax-error #f "bad syntax (illegal use of `.') after sequence bindings" #'orig-stx)] + ;; Guard case, no pending emits, wants the first result, but there is none: + [(_ [orig-stx nested? #f first? ()] () (#:when expr . rest) . body) + (raise-syntax-error #f "missing at least one binding" #'orig-stx)] ;; Guard case, no pending emits: - [(_ [orig-stx nested? #f ()] ([fold-var fold-init] ...) (#:when expr . rest) . body) - #'(let ([fold-var fold-init] ...) - (if expr - (for/foldX/derived [orig-stx nested? #f ()] - ([fold-var fold-var] ...) rest . body) - (values* fold-var ...)))] + [(_ [orig-stx nested? #f first? ()] + ([fold-var fold-init] ...) (#:when expr . rest) . body) + (with-syntax ([return (if (syntax-e #'first?) + (car (syntax-e #'(fold-var ...))) + #'(values* fold-var ...))]) + #'(let ([fold-var fold-init] ...) + (if expr + (for/foldX/derived [orig-stx nested? #f first? ()] + ([fold-var fold-var] ...) rest . body) + return)))] ;; Guard case, pending emits need to be flushed first - [(frm [orig-stx nested? #f binds] ([fold-var fold-init] ...) + [(frm [orig-stx nested? #f first? binds] ([fold-var fold-init] ...) (#:when expr . rest) . body) - #'(frm [orig-stx nested? #t binds] ([fold-var fold-init] ...) + #'(frm [orig-stx nested? #t first? binds] ([fold-var fold-init] ...) (#:when expr . rest) . body)] ;; Convert single-value form to multi-value form: - [(_ [orig-stx nested? #f binds] fold-bind ([id rhs] . rest) . body) + [(_ [orig-stx nested? #f first? binds] fold-bind ([id rhs] . rest) . body) (identifier? #'id) - #'(for/foldX/derived [orig-stx nested? #f binds] fold-bind + #'(for/foldX/derived [orig-stx nested? #f first? binds] fold-bind ([(id) rhs] . rest) . body)] ;; 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 #f #f nested? #f first? binds] fold-bind + (clause . rest) . body) (raise-syntax-error #f "bad sequence binding clause" #'orig-stx #'clause)] ;; 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 nested? #f first? binds] ([fold-var fold-init] ...) (clause . rest) . body) (with-syntax ([bind (expand-clause #'orig-stx #'clause)]) - #`(frm [orig-stx nested? nested? (bind . binds)] + #`(frm [orig-stx nested? nested? first? (bind . binds)] ([fold-var fold-init] ...) rest . body))] [(_ [orig-stx . _] . _) (raise-syntax-error #f "bad syntax" #'orig-stx)])) @@ -792,13 +813,23 @@ (define-syntax for/fold/derived (syntax-rules () [(_ orig-stx . rest) - (for/foldX/derived [orig-stx #f #f ()] . rest)])) + (for/foldX/derived [orig-stx #f #f #f ()] . rest)])) (define-syntax for*/fold/derived (syntax-rules () [(_ orig-stx . rest) - (for/foldX/derived [orig-stx #t #f ()] . rest)])) + (for/foldX/derived [orig-stx #t #f #f ()] . rest)])) + (define-syntax for/fold/first/derived + (syntax-rules () + [(_ orig-stx . rest) + (for/foldX/derived [orig-stx #f #f #t ()] . rest)])) + + (define-syntax for*/fold/first/derived + (syntax-rules () + [(_ orig-stx . rest) + (for/foldX/derived [orig-stx #t #f #t ()] . rest)])) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; derived `for' syntax @@ -851,6 +882,13 @@ (syntax-case stx () [(_ . rest) (quasisyntax/loc stx (for*/fold/derived #,stx . rest))])) + (define-syntax (for/fold/first stx) + (syntax-case stx () + [(_ . rest) (quasisyntax/loc stx (for/fold/first/derived #,stx . rest))])) + (define-syntax (for*/fold/first stx) + (syntax-case stx () + [(_ . rest) (quasisyntax/loc stx (for*/fold/first/derived #,stx . rest))])) + (define-for-variants (for for*) ([fold-var (void)]) (lambda (x) x)