From 93e1b634a381d4648bb1c2645aeefeeb623eb7ce Mon Sep 17 00:00:00 2001 From: James Ian Johnson Date: Tue, 30 Aug 2011 14:42:32 -0400 Subject: [PATCH] Added let and define forms that generalize let-values, let*-values and define-values --- collects/racket/match/define-forms.rkt | 79 +++++++++++++++++----- collects/racket/match/legacy-match.rkt | 3 +- collects/racket/match/match.rkt | 3 +- collects/scribblings/reference/match.scrbl | 24 ++++++- 4 files changed, 87 insertions(+), 22 deletions(-) diff --git a/collects/racket/match/define-forms.rkt b/collects/racket/match/define-forms.rkt index 608ba1c735..4671724b82 100644 --- a/collects/racket/match/define-forms.rkt +++ b/collects/racket/match/define-forms.rkt @@ -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)]) ...))))))]))))) diff --git a/collects/racket/match/legacy-match.rkt b/collects/racket/match/legacy-match.rkt index b9abbfd220..c30ee7c8fe 100644 --- a/collects/racket/match/legacy-match.rkt +++ b/collects/racket/match/legacy-match.rkt @@ -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) diff --git a/collects/racket/match/match.rkt b/collects/racket/match/match.rkt index edb5761519..5951422d0c 100644 --- a/collects/racket/match/match.rkt +++ b/collects/racket/match/match.rkt @@ -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) diff --git a/collects/scribblings/reference/match.scrbl b/collects/scribblings/reference/match.scrbl index b5e653f50b..99380f8d3b 100644 --- a/collects/scribblings/reference/match.scrbl +++ b/collects/scribblings/reference/match.scrbl @@ -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