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

Added let and define forms that generalize let-values, let*-values and define-values

Browse Source
This commit is contained in:
James Ian Johnson 2011-08-30 14:42:32 -04:00 committed by Sam Tobin-Hochstadt
parent fd5019ddea
commit 93e1b634a3
4 changed files with 87 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,6 +2,7 @@
(require (for-syntax scheme/base
racket/syntax
(only-in racket/list append* append-map)
unstable/sequence
syntax/parse
"parse.rkt"
@ -12,20 +13,22 @@
(provide define-forms)
(define-syntax-rule (define-forms parse-id
match match* match-lambda match-lambda*
match-lambda** match-let match-let*
match-define match-letrec
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)
(...
(begin
(provide match match* match-lambda match-lambda* match-lambda**
match-let match-let* match-define match-letrec
match/derived match*/derived)
match-let match-let* match-let-values match-let*-values
match-define match-define-values match-letrec
match/derived match*/derived match-define-values)
(define-syntax (match* stx)
(syntax-parse stx
[(_ es . clauses)
(go parse-id stx #'es #'clauses)]))
(define-syntax (match*/derived stx)
(syntax-parse stx
[(_ es orig-stx . clauses)
@ -35,7 +38,7 @@
(syntax-parse stx
[(_ arg:expr clauses ...)
(go/one parse-id stx #'arg #'(clauses ...))]))
(define-syntax (match/derived stx)
(syntax-parse stx
[(_ arg:expr orig-stx clauses ...)
@ -47,14 +50,14 @@
(with-syntax* ([arg (generate-temporary)]
[body #`(match/derived arg #,stx . clauses)])
(syntax/loc stx (lambda (arg) body)))]))
(define-syntax (match-lambda* stx)
(syntax-parse stx
[(_ . clauses)
(with-syntax* ([arg (generate-temporary)]
[body #`(match/derived arg #,stx . clauses)])
(syntax/loc stx (lambda arg body)))]))
(define-syntax (match-lambda** stx)
(syntax-parse stx
[(_ (~and clauses [(pats ...) . rhs]) ...)
@ -64,17 +67,17 @@
;; there's lots of duplication here to handle named let
;; some factoring out would do a lot of good
(define-syntax (match-let stx)
(define-syntax (match-let stx)
(syntax-parse stx
[(_ nm:id (~and clauses ([pat init-exp:expr] ...)) body1 body ...)
(with-syntax*
([vars (generate-temporaries #'(pat ...))]
[loop-body #`(match*/derived vars #,stx
[loop-body #`(match*/derived vars #,stx
[(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
#`(match*/derived (init-exp ...) #,stx
[(pat ...) (let () body1 body ...)])]))
(define-syntax (match-let* stx)
@ -82,17 +85,43 @@
[(_ () body1 body ...)
#'(let () body1 body ...)]
[(_ ([pat exp] rest-pats ...) body1 body ...)
#`(match*/derived
#`(match*/derived
(exp)
#,stx
[(pat) #,(syntax/loc stx (match-let* (rest-pats ...)
[(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 ...)))]))
(define-syntax (match-letrec stx)
(syntax-parse stx
[(_ ((~and cl [pat exp]) ...) body1 body ...)
(quasisyntax/loc stx
(let ()
(let ()
#,@(for/list ([c (in-syntax #'(cl ...))]
[p (in-syntax #'(pat ...))]
[e (in-syntax #'(exp ...))])
@ -100,10 +129,26 @@
body1 body ...))]))
(define-syntax (match-define stx)
(syntax-parse stx
(syntax-parse stx
[(_ pat rhs:expr)
(let ([p (parse-id #'pat)])
(with-syntax ([vars (bound-vars p)])
(quasisyntax/loc stx
(define-values vars (match*/derived (rhs) #,stx
[(pat) (values . vars)])))))])))))
[(pat) (values . vars)])))))]))
(define-syntax (match-define-values stx)
(syntax-parse stx
[(_ (pats ...) rhs:expr)
(define ppats (map parse-id (syntax->list #'(pats ...))))
(define bound-vars-list (map bound-vars ppats))
(with-syntax ([(ids ...) (generate-temporaries #'(pats ...))]
[(pat-vars ...) bound-vars-list]
[vars (append* bound-vars-list)])
(quasisyntax/loc stx
(define-values vars
(let-values ([(ids ...) rhs])
(apply values
(append
(match*/derived (ids) #,stx
[(pats) (list . pat-vars)]) ...))))))])))))

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

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

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

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

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

@ -339,7 +339,7 @@ In more detail, patterns match as follows:
@racket[quasiquote] expression form, @racketidfont{unquote}
and @racketidfont{unquote-splicing} escape back to normal
patterns.
@examples[
#:eval match-eval
(match '(1 2 3)
@ -360,7 +360,7 @@ In more detail, patterns match as follows:
[(pat ...+) (=> id) body ...+]])]{
Matches a sequence of values against each clause in order, matching
only when all patterns in a clause match. Each clause must have the
same number of patterns as the number of @racket[val-expr]s.
same number of patterns as the number of @racket[val-expr]s.
@examples[#:eval match-eval
(match* (1 2 3)
@ -413,6 +413,14 @@ bindings of each @racket[pat] are available in each subsequent
x)
]}
@defform[(match-let-values ([(pat ...) expr] ...) body ...+)]{
Like @racket[match-let], but generalizes @racket[let-values].}
@defform[(match-let*-values ([(pat ...) expr] ...) body ...+)]{
Like @racket[match-let*], but generalizes @racket[let*-values].}
@defform[(match-letrec ([pat expr] ...) body ...+)]{
Like @racket[match-let], but generalizes @racket[letrec].}
@ -429,6 +437,16 @@ matching against the result of @racket[expr].
b
]}
@defform[(match-define-values (pat ...) expr)]{
Like @racket[match-define] but for when expr produces multiple values.
@examples[
#:eval match-eval
(match-define-values (a b) (values 1 2))
b
]}
@; ----------------------------------------
@defproc[(exn:misc:match? [v any/c]) boolean?]{
@ -465,7 +483,7 @@ whether multiple uses of an identifier match the ``same'' value. The
default is @racket[equal?].}
@deftogether[[@defform[(match/derived val-expr original-datum clause ...)]
@defform[(match*/derived (val-expr ...) original-datum clause* ...)]]]{
@defform[(match*/derived (val-expr ...) original-datum clause* ...)]]]{
Like @racket[match] and @racket[match*] respectively, but includes a
sub-expression to be used as the source for all syntax errors within the form.
For example, @racket[match-lambda] expands to @racket[match/derived] so that