suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix for/or and for/and when one of the clauses binds multiple values

Browse Source 
svn: r10926
This commit is contained in:
Matthew Flatt 2008-07-26 21:38:39 +00:00
parent fb5240d145
commit 616ec71325
2 changed files with 21 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/scheme/private/for.ss
View File

@ -736,7 +736,7 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; derived `for' syntax ;; derived `for' syntax
(define-for-syntax (for-variant-stx stx derived-id-stx fold-bind-stx wrap rhs-wrap combine multi?) (define-for-syntax (for-variant-stx stx derived-id-stx fold-bind-stx wrap rhs-wrap combine)
(with-syntax ([derived-id derived-id-stx] (with-syntax ([derived-id derived-id-stx]
[fold-bind fold-bind-stx]) [fold-bind fold-bind-stx])
(syntax-case stx () (syntax-case stx ()
@ -747,9 +747,8 @@
null null
(syntax-case (car bs) () (syntax-case (car bs) ()
[[ids rhs] [[ids rhs]
(if multi? (or (identifier? #'ids)
(andmap identifier? (or (syntax->list #'ids) '(#f))) (andmap identifier? (or (syntax->list #'ids) '(#f))))
(identifier? #'ids))
(cons #`[ids #,(rhs-wrap #'rhs)] (cons #`[ids #,(rhs-wrap #'rhs)]
(loop (cdr bs)))] (loop (cdr bs)))]
[#:when (cons (car bs) [#:when (cons (car bs)
@ -757,7 +756,7 @@
null null
(cons (cadr bs) (loop (cddr bs)))))] (cons (cadr bs) (loop (cddr bs)))))]
[_ [_
;; a syntax error; les the /derived form handle it, and ;; a syntax error; let the /derived form handle it, and
;; no need to wrap any more: ;; no need to wrap any more:
bs])))]) bs])))])
(quasisyntax/loc stx (quasisyntax/loc stx
@ -769,15 +768,15 @@
(define-syntax define-syntax-via-derived (define-syntax define-syntax-via-derived
(syntax-rules () (syntax-rules ()
[(_ id derived-id fold-bind wrap rhs-wrap combine multi?) [(_ id derived-id fold-bind wrap rhs-wrap combine)
(define-syntax (id stx) (for-variant-stx stx #'derived-id #'fold-bind wrap rhs-wrap combine multi?))])) (define-syntax (id stx) (for-variant-stx stx #'derived-id #'fold-bind wrap rhs-wrap combine))]))
(define-syntax define-for-variants (define-syntax define-for-variants
(syntax-rules () (syntax-rules ()
[(_ (for for*) fold-bind wrap rhs-wrap combine) [(_ (for for*) fold-bind wrap rhs-wrap combine)
(begin (begin
(define-syntax-via-derived for for/fold/derived fold-bind wrap rhs-wrap combine #f) (define-syntax-via-derived for for/fold/derived fold-bind wrap rhs-wrap combine)
(define-syntax-via-derived for* for*/fold/derived fold-bind wrap rhs-wrap combine #f))])) (define-syntax-via-derived for* for*/fold/derived fold-bind wrap rhs-wrap combine))]))
(define-syntax (for/fold stx) (define-syntax (for/fold stx)
(syntax-case stx () (syntax-case stx ()

13
collects/tests/mzscheme/for.ss
View File

@ -145,5 +145,18 @@
(for/hash ([v (in-hash-values #hash((a . 1) (b . 2) (c . 3)))]) (for/hash ([v (in-hash-values #hash((a . 1) (b . 2) (c . 3)))])
(values v v))) (values v v)))
(test 1 'parallel-or-first
(for/or (((a b) (in-parallel '(1 #f) '(#t #f))))
a))
(test 1 'parallel-or-last
(for/or (((a b) (in-parallel '(#f 1) '(#t #f))))
a))
(test #f 'parallel-and-first
(for/and (((a b) (in-parallel '(1 #f) '(#t #f))))
a))
(test #f 'parallel-and-last
(for/and (((a b) (in-parallel '(#f 1) '(#t #f))))
a))
(report-errs) (report-errs)