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

Implemented Sam's suggested changes for new forms, and added a new match/values form.

Browse Source
This commit is contained in:
James Ian Johnson 2011-08-30 19:23:36 -04:00 committed by Sam Tobin-Hochstadt
parent 93e1b634a3
commit dc61372f3c
5 changed files with 228 additions and 179 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
collects/racket/match/define-forms.rkt
View File

@ -12,18 +12,42 @@
(provide define-forms)
;; each pat matches a value in a multi-valued expression
(define-for-syntax (match-values-clause->let-clause pats rhs)
(with-syntax ([(pats ...) pats]
[(ids ...) (generate-temporaries pats)])
;; rhs evaluates to number of ids values.
;; patterns should match against each id.
(values #'(ids ...)
#`[(ids ...) #,rhs])))
(define-for-syntax (match-values-clauses->let-clauses patses rhses)
(for/lists (idses let-clauses)
([pats (syntax->list patses)]
[rhs (syntax->list rhses)])
(match-values-clause->let-clause pats rhs)))
(define-for-syntax (all-same-length stx-listses)
(let loop ([listses (syntax->list stx-listses)]
[the-length #f])
(cond [(null? listses) #t]
[the-length
(and (= the-length (length (syntax->list (car listses))))
(loop (cdr listses) the-length))]
[else (loop (cdr listses) (length (syntax->list (car listses))))])))
(define-syntax-rule (define-forms parse-id
match match* match-lambda match-lambda*
match-lambda** match-let match-let*
match-let-values match-let*-values
match-define match-define-values match-letrec
match/derived match*/derived)
match/values match/derived match*/derived)
(...
(begin
(provide match match* match-lambda match-lambda* match-lambda**
match-let match-let* match-let-values match-let*-values
match-define match-define-values match-letrec
match/derived match*/derived match-define-values)
match/values match/derived match*/derived match-define-values)
(define-syntax (match* stx)
(syntax-parse stx
[(_ es . clauses)
@ -44,6 +68,16 @@
[(_ arg:expr orig-stx clauses ...)
(go/one parse-id #'orig-stx #'arg #'(clauses ...))]))
(define-syntax (match/values stx)
(syntax-parse stx
[(_ arg:expr [(pats ...) rhs:expr] [(patses ...) rhses:expr] ...)
#:fail-unless (all-same-length #'((pats ...) (patses ...) ...))
"All clauses must have the same number of patterns"
(define-values (ids let-clause)
(match-values-clause->let-clause #'(pats ...) #'rhs))
#`(let-values ([#,ids arg])
(match*/derived #,ids #,stx [(pats ...) rhs] [(patses ...) rhses] ...))]))
(define-syntax (match-lambda stx)
(syntax-parse stx
[(_ . clauses)
@ -65,6 +99,29 @@
[body #`(match*/derived vars #,stx clauses ...)])
(syntax/loc stx (lambda vars body)))]))
(define-syntax (match-let-values stx)
(syntax-parse stx
[(_ (~and clauses ([(patses ...) rhses:expr] ...)) body1 body ...)
(define-values (idses let-clauses)
(match-values-clauses->let-clauses #'((patses ...) ...) #'(rhses ...)))
#`(let-values #,let-clauses
(match*/derived #,(append-map syntax->list idses) #,stx
[(patses ... ...)
(let () body1 body ...)]))]))
(define-syntax (match-let*-values stx)
(syntax-parse stx
[(_ () body1 body ...)
#'(let () body1 body ...)]
[(_ ([(pats ...) rhs] rest-pats ...) body1 body ...)
(define-values (ids let-clause)
(match-values-clause->let-clause #'(pats ...) #'rhs))
#`(let-values (#,let-clause)
(match*/derived #,ids #,stx
[(pats ...) #,(syntax/loc stx (match-let*-values (rest-pats ...)
body1 body ...))]))]))
;; there's lots of duplication here to handle named let
;; some factoring out would do a lot of good
(define-syntax (match-let stx)
@ -76,46 +133,11 @@
[(pat ...) (let () body1 body ...)])])
#'(letrec ([nm (lambda vars loop-body)])
(nm init-exp ...)))]
[(_ (~and clauses ([pat init-exp:expr] ...)) body1 body ...)
#`(match*/derived (init-exp ...) #,stx
[(pat ...) (let () body1 body ...)])]))
(define-syntax (match-let* stx)
(syntax-parse stx
[(_ () body1 body ...)
#'(let () body1 body ...)]
[(_ ([pat exp] rest-pats ...) body1 body ...)
#`(match*/derived
(exp)
#,stx
[(pat) #,(syntax/loc stx (match-let* (rest-pats ...)
body1 body ...))])]))
(define-syntax (match-let-values stx)
(syntax-parse stx
[(_ (~and clauses ([(patses ...) rhses:expr] ...)) body1 body ...)
(define-values (let-clauses match-clauses)
(for/lists (let-clauses match-clauses)
([pats (syntax->list #'((patses ...) ...))]
[rhs (syntax->list #'(rhses ...))])
(with-syntax ([(pats ...) pats]
[(ids ...) (generate-temporaries pats)])
(values #`[(ids ...) #,rhs]
#`([pats ids] ...)))))
#`(let-values #,let-clauses
#,(quasisyntax/loc stx
(match-let #,(append-map syntax->list match-clauses)
(let () body1 body ...))))]))
(define-syntax (match-let*-values stx)
(syntax-parse stx
[(_ () body1 body ...)
#'(let () body1 body ...)]
[(_ ([pats rhs] rest-pats ...) body1 body ...)
#`(match-let-values ([pats rhs])
#,(syntax/loc stx (match-let*-values (rest-pats ...)
body1 body ...)))]))
[(_ ([pat init-exp:expr] ...) body1 body ...)
#`(match-let-values ([(pat) init-exp] ...) body1 body ...)]))
(define-syntax-rule (match-let* ([pat exp] ...) body1 body ...)
(match-let*-values ([(pat) exp] ...) body1 body ...))
(define-syntax (match-letrec stx)
(syntax-parse stx

2
collects/racket/match/legacy-match.rkt
View File

@ -18,4 +18,4 @@
(define-forms parse/legacy
match match* match-lambda match-lambda* match-lambda** match-let match-let*
match-let-values match-let*-values
match-define match-define-values match-letrec match/derived match*/derived)
match-define match-define-values match-letrec match/values match/derived match*/derived)

2
collects/racket/match/match.rkt
View File

@ -20,4 +20,4 @@
(define-forms parse
match match* match-lambda match-lambda* match-lambda** match-let match-let*
match-let-values match-let*-values
match-define match-define-values match-letrec match/derived match*/derived)
match-define match-define-values match-letrec match/values match/derived match*/derived)

7
collects/scribblings/reference/match.scrbl
View File

@ -368,6 +368,13 @@ same number of patterns as the number of @racket[val-expr]s.
]
}
@defform[(match/values expr clause clause ...)]{
If @racket[expr] evaluates to @racket[n] values, then match all @racket[n]
values against the patterns in @racket[clause ...]. Each clause must contain
exactly @racket[n] patterns. At least one clause is required to determine how
many values to expect from @racket[expr].
}
@defform[(match-lambda clause ...)]{
Equivalent to @racket[(lambda (id) (match id clause ...))].

20
collects/tests/match/examples.rkt
View File

@ -672,4 +672,24 @@
[(foo) 0]
[_ 1])))
(comp '(1 2 4)
(call-with-values
(λ () (match-let-values ([(x y) (values 1 2)] [(3 w) (values 3 4)])
(list x y w)))
list))
(comp '(1 3 4)
(call-with-values
(λ () (match-let*-values ([(x y) (values 1 2)] [(y w) (values 3 4)])
(list x y w)))
list))
(comp '(1 2 3)
(match/values (values 1 2 3)
[(x y z) (list x y z)]))
(comp '(1 2)
(let () (match-define-values (x y 3) (values 1 2 3))
(list x y)))
))