From a9b36c93aefafef3d20116cac6d46336907d373a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 9 Dec 2009 22:51:09 +0000 Subject: [PATCH] some conversion to syntax-parse svn: r17250 --- collects/scheme/match/define-forms.ss | 147 ++++++++++++-------------- collects/scheme/match/gen-match.ss | 16 ++- collects/scheme/match/legacy-match.ss | 2 +- collects/scheme/match/match.ss | 2 +- 4 files changed, 80 insertions(+), 87 deletions(-) diff --git a/collects/scheme/match/define-forms.ss b/collects/scheme/match/define-forms.ss index e23f216341..67fb979896 100644 --- a/collects/scheme/match/define-forms.ss +++ b/collects/scheme/match/define-forms.ss @@ -1,6 +1,8 @@ #lang scheme/base (require (for-syntax scheme/base + unstable/syntax + syntax/parse "parse.ss" "parse-helper.ss" "patterns.ss" @@ -10,107 +12,90 @@ (define-syntax-rule (define-forms parse-id match match* match-lambda match-lambda* match-lambda** match-let - match-let* match-define match-letrec) + match-let* match-define 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-define match-letrec match/derived match*/derived) (define-syntax (match* stx) - (syntax-case stx () + (syntax-parse stx [(_ es . clauses) - (go parse-id stx #'es #'clauses (syntax-local-certifier))])) + (go parse-id stx #'es #'clauses)])) + + (define-syntax (match*/derived stx) + (syntax-parse stx + [(_ es orig-stx . clauses) + (go parse-id #'orig-stx #'es #'clauses)])) (define-syntax (match stx) - (syntax-case stx () - [(match arg cl ...) - (with-syntax ([clauses - (for/list ([c (syntax->list #'(cl ...))]) - (syntax-case c () - [[p . es] (syntax/loc c [(p) . es])]))]) - (syntax/loc stx (match* (arg) . clauses)))])) + (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 ...) + (go/one parse-id #'orig-stx #'arg #'(clauses ...))])) (define-syntax (match-lambda stx) - (syntax-case stx () - [(k . clauses) (syntax/loc stx (lambda (exp) (match exp . clauses)))])) - + (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-case stx () - [(k . clauses) (syntax/loc stx (lambda exp (match exp . clauses)))])) - + (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-case stx () - [(k [pats . rhs] ...) - (let* ([pss (syntax->list #'(pats ...))] - [ps1 (car pss)]) - (unless (syntax->list ps1) - (raise-syntax-error - #f "expected a sequence of patterns" stx ps1)) - (let ([len (length (syntax->list ps1))]) - (for/list ([ps pss]) - (unless (= (length (syntax->list ps)) len) - (raise-syntax-error - #f "unequal number of patterns in match clauses" - stx ps))) - (with-syntax ([(vars ...) (generate-temporaries (car pss))]) - (syntax/loc stx - (lambda (vars ...) (match* (vars ...) [pats . rhs] ...))))))])) + (syntax-parse stx + [(_ (~and clauses [(pats ...) . rhs]) ...) + (with-syntax* ([vars (generate-temporaries (car #'((pats ...) ...)))] + [body #`(match*/derived #'vars #,stx #'(clauses ...))]) + (syntax/loc stx (lambda vars 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) - (syntax-case stx () - ;; an empty body is an error - [(_ nm (clauses ...)) - (identifier? #'nm) - (match:syntax-err stx "bad syntax (empty body)")] - [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")] - ;; with no bindings, there's nothing to do - [(_ name () body ...) - (identifier? #'name) - (syntax/loc stx (let name () body ...))] - [(_ () body ...) (syntax/loc stx (let () body ...))] - ;; optimize the all-variable case - [(_ ([pat exp]...) body ...) - (andmap pattern-var? (syntax->list #'(pat ...))) - (syntax/loc stx (let name ([pat exp] ...) body ...))] - [(_ name ([pat exp]...) body ...) - (and (identifier? (syntax name)) - (andmap pattern-var? (syntax->list #'(pat ...)))) - (syntax/loc stx (let name ([pat exp] ...) body ...))] - ;; now the real cases - [(_ name ([pat exp] ...) . body) - (identifier? #'name) - (syntax/loc stx (letrec ([name (match-lambda** ((pat ...) . body))]) - (name exp ...)))] - [(_ ([pat exp] ...) . body) - (syntax/loc stx (match* (exp ...) [(pat ...) . body]))])) + (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 [(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-case stx () - [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")] - [(_ () body ...) - (syntax/loc stx (let* () body ...))] - [(_ ([pat exp] rest ...) body ...) - (syntax/loc stx (match exp [pat (match-let* (rest ...) body ...)]))])) + (syntax-parse stx + [(_ () body1 body ...) + #'(let () body1 body ...)] + [(_ ([pat exp] rest-pats ...) body1 body ...) + #`(match*/derived + #,stx + (exp) + [(pat) #,(syntax/loc stx (match-let* (rest-pats ...) body1 body ...))])])) (define-syntax (match-letrec stx) - (syntax-case stx () - [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")] - [(_ ([pat exp] ...) . body) - (andmap pattern-var? - (syntax->list #'(pat ...))) - (syntax/loc stx (letrec ([pat exp] ...) . body))] - [(_ ([pat exp] ...) . body) - (syntax/loc stx (let () (match-define pat exp) ... . body))])) + (syntax-parse stx + [(_ ((~and cl [pat exp]) ...) body1 body ...) + (syntax/loc stx (let () + #,@(for/list ([c (in-syntax #'(cl ...))] + [p (in-syntax #'(pat ...))] + [e (in-syntax #'(exp ...))]) + (syntax/loc c (match-define p e))) + body1 body ...))])) (define-syntax (match-define stx) - (syntax-case stx () - [(_ pat exp) - (pattern-var? #'pat) - (syntax/loc stx (define pat exp))] - [(_ pat rhs) + (syntax-parse stx + [(_ pat rhs:expr) ;; FIXME - calls parse twice (let ([p (parse-id #'pat (syntax-local-certifier))]) (with-syntax ([vars (bound-vars p)]) - (syntax/loc stx - (define-values vars (match rhs [pat (values . vars)])))))]))))) + (quasisyntax/loc stx + (define-values vars (match*/derived (rhs) #,stx [(pat) (values . vars)])))))]))))) diff --git a/collects/scheme/match/gen-match.ss b/collects/scheme/match/gen-match.ss index d511f208e0..36a0d267f1 100644 --- a/collects/scheme/match/gen-match.ss +++ b/collects/scheme/match/gen-match.ss @@ -1,14 +1,22 @@ #lang scheme/base (require "patterns.ss" "compiler.ss" - syntax/stx scheme/nest + syntax/stx scheme/nest syntax/parse (for-template scheme/base (only-in "runtime.ss" match:error))) -(provide go) +(provide go go/one) + +;; this transforms `match'-style clauses into ones acceptable to `go' +;; go : syntax syntax syntax [certifier] -> syntax +(define (go/one parse/cert stx expr clauses [cert (syntax-local-certifier)]) + (syntax-parse clauses + [([p . rhs] ...) + (go parse/cert stx (quasisyntax/loc expr (#,expr)) + #'([(p) . rhs] ...) cert)])) ;; this parses the clauses using parse/cert, then compiles them -;; go : syntax syntax syntax certifier -> syntax -(define (go parse/cert stx exprs clauses cert) +;; go : syntax syntax syntax [certifier] -> syntax +(define (go parse/cert stx exprs clauses [cert (syntax-local-certifier)]) (syntax-case clauses () [([pats . rhs] ...) (nest diff --git a/collects/scheme/match/legacy-match.ss b/collects/scheme/match/legacy-match.ss index e8e0bf2ef6..56910ed05e 100644 --- a/collects/scheme/match/legacy-match.ss +++ b/collects/scheme/match/legacy-match.ss @@ -17,4 +17,4 @@ (define-forms parse/legacy/cert match match* match-lambda match-lambda* match-lambda** match-let match-let* - match-define match-letrec) + match-define match-letrec match/derived match*/derived) diff --git a/collects/scheme/match/match.ss b/collects/scheme/match/match.ss index 08aad02f86..d066e23ab3 100644 --- a/collects/scheme/match/match.ss +++ b/collects/scheme/match/match.ss @@ -19,4 +19,4 @@ (define-forms parse/cert match match* match-lambda match-lambda* match-lambda** match-let match-let* - match-define match-letrec) + match-define match-letrec match/derived match*/derived)