From 2ce9b40a5486392683172df816a90747536a30a8 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 11 Mar 2015 18:25:12 -0400 Subject: [PATCH] Add `match-letrec-values`. Implemented by J. Ian Johnson. Closes #762. --- .../scribblings/reference/match.scrbl | 4 +++ racket/collects/racket/match/define-forms.rkt | 34 ++++++++++++------- racket/collects/racket/match/legacy-match.rkt | 2 +- racket/collects/racket/match/match.rkt | 2 +- racket/collects/racket/match/patterns.rkt | 7 +++- 5 files changed, 33 insertions(+), 16 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/match.scrbl b/pkgs/racket-doc/scribblings/reference/match.scrbl index 8dc610df97..ad0443b3db 100644 --- a/pkgs/racket-doc/scribblings/reference/match.scrbl +++ b/pkgs/racket-doc/scribblings/reference/match.scrbl @@ -509,6 +509,10 @@ Like @racket[match-let*], but generalizes @racket[let*-values].} Like @racket[match-let], but generalizes @racket[letrec].} +@defform[(match-letrec-values ([(pat ...) expr] ...) body ...+)]{ + +Like @racket[match-let], but generalizes @racket[letrec-values].} + @defform[(match-define pat expr)]{ Defines the names bound by @racket[pat] to the values produced by diff --git a/racket/collects/racket/match/define-forms.rkt b/racket/collects/racket/match/define-forms.rkt index d5d8cbd85d..be0e115916 100644 --- a/racket/collects/racket/match/define-forms.rkt +++ b/racket/collects/racket/match/define-forms.rkt @@ -10,7 +10,7 @@ syntax/parse/lib/function-header)) (begin-for-syntax - (lazy-require [racket/match/patterns (bound-vars)] + (lazy-require [racket/match/patterns (bound-vars pats->bound-vars)] [racket/match/gen-match (go go/one)])) (provide define-forms) @@ -19,14 +19,16 @@ 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-define match-define-values + match-letrec match-letrec-values match/values match/derived match*/derived define/match) (... (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-define match-define-values + match-letrec match-letrec-values match/values match/derived match*/derived match-define-values define/match) (define-syntax (match* stx) @@ -130,6 +132,17 @@ (quasisyntax/loc c (match-define #,p #,e))) body1 body ...))])) + (define-syntax (match-letrec-values stx) + (syntax-parse stx + [(_ ((~and cl [(pat ...) exp]) ...) body1 body ...) + (quasisyntax/loc stx + (let () + #,@(for/list ([c (in-syntax #'(cl ...))] + [p (in-syntax #'((pat ...) ...))] + [e (in-syntax #'(exp ...))]) + (quasisyntax/loc c (match-define-values #,p #,e))) + body1 body ...))])) + (define-syntax (match-define stx) (syntax-parse stx [(_ pat rhs:expr) @@ -137,21 +150,16 @@ (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 bound-vars-list (remove-duplicates - (foldr (λ (pat vars) - (append (bound-vars (parse-id pat)) vars)) - '() (syntax->list #'(pats ...))) - bound-identifier=?)) - (with-syntax ([(ids ...) (generate-temporaries #'(pats ...))]) - (quasisyntax/loc stx - (define-values #,bound-vars-list + (with-syntax ([(ids ...) (pats->bound-vars parse-id (syntax->list #'(pats ...)))]) + (syntax/loc stx + (define-values (ids ...) (match/values rhs - [(pats ...) (values . #,bound-vars-list)]))))])) + [(pats ...) (values ids ...)]))))])) (define-syntax (define/match stx) (syntax-parse stx diff --git a/racket/collects/racket/match/legacy-match.rkt b/racket/collects/racket/match/legacy-match.rkt index e82a4d96ec..5be44bef5d 100644 --- a/racket/collects/racket/match/legacy-match.rkt +++ b/racket/collects/racket/match/legacy-match.rkt @@ -17,5 +17,5 @@ (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/values match/derived match*/derived + match-define match-define-values match-letrec match-letrec-values match/values match/derived match*/derived define/match) diff --git a/racket/collects/racket/match/match.rkt b/racket/collects/racket/match/match.rkt index 9720b69ef2..b6514d7295 100644 --- a/racket/collects/racket/match/match.rkt +++ b/racket/collects/racket/match/match.rkt @@ -30,6 +30,6 @@ (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/values + match-define match-define-values match-letrec match-letrec-values match/values match/derived match*/derived define/match) diff --git a/racket/collects/racket/match/patterns.rkt b/racket/collects/racket/match/patterns.rkt index 0206d670c2..0cbc9c446b 100644 --- a/racket/collects/racket/match/patterns.rkt +++ b/racket/collects/racket/match/patterns.rkt @@ -1,7 +1,7 @@ #lang racket/base (require syntax/boundmap - racket/contract + racket/contract racket/list "stxtime.rkt" (for-syntax racket/base)) @@ -180,6 +180,11 @@ [(Exact? p) null] [else (error 'match "bad pattern: ~a" p)])) +(define (pats->bound-vars parse-id pats) + (remove-duplicates + (foldr (λ (pat vars) (append (bound-vars (parse-id pat)) vars)) '() pats) + bound-identifier=?)) + (define current-renaming (make-parameter (make-free-identifier-mapping))) (define (copy-mapping ht)