some conversion to syntax-parse

svn: r17250

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 ()
+       (syntax-parse stx
-	   [(match arg cl ...)
+         [(_ arg:expr clauses ...)
-	    (with-syntax ([clauses
+          (go/one parse-id stx #'arg #'(clauses ...))]))
-			   (for/list ([c (syntax->list #'(cl ...))])
+     
-			     (syntax-case c ()
+     (define-syntax (match/derived stx)
-			       [[p . es] (syntax/loc c [(p) . es])]))])			 
+       (syntax-parse stx
-	      (syntax/loc stx (match* (arg) . clauses)))]))
+         [(_ arg:expr orig-stx clauses ...)
+          (go/one parse-id #'orig-stx #'arg #'(clauses ...))]))
 
      (define-syntax (match-lambda stx)
-       (syntax-case stx ()
+       (syntax-parse stx
-         [(k . clauses) (syntax/loc stx (lambda (exp) (match exp . clauses)))]))
+         [(_ . 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 ()
+       (syntax-parse stx
-         [(k . clauses) (syntax/loc stx (lambda exp (match exp . clauses)))]))
+         [(_ . 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 ()
+       (syntax-parse stx
-         [(k [pats . rhs] ...)
+         [(_ (~and clauses [(pats ...) . rhs]) ...)
-          (let* ([pss (syntax->list #'(pats ...))]
+          (with-syntax* ([vars (generate-temporaries (car #'((pats ...) ...)))]
-                 [ps1 (car pss)])
+                         [body #`(match*/derived #'vars #,stx #'(clauses ...))])
-            (unless (syntax->list ps1)
+            (syntax/loc stx (lambda vars body)))]))
-              (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] ...))))))]))
 
      ;; 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-case stx ()
+       (syntax-parse stx
-         ;; an empty body is an error
+         [(_ nm:id (~and clauses ([pat init-exp:expr] ...)) body1 body ...)
-         [(_ nm (clauses ...))
+          (with-syntax*
-          (identifier? #'nm)
+           ([vars (generate-temporaries #'(pat ...))]
-          (match:syntax-err stx "bad syntax (empty body)")]
+            [loop-body #`(match*/derived vars #,stx [(pat ...) (let () body1 body ...)])])
-         [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
+           #'(letrec ([nm (lambda vars loop-body)])
-         ;; with no bindings, there's nothing to do
+               (nm init-exp ...)))]
-         [(_ name () body ...)
+         [(_ (~and clauses ([pat init-exp:expr] ...)) body1 body ...)
-          (identifier? #'name)
+          #`(match*/derived (init-exp ...) #,stx [(pat ...) (let () body1 body ...)])]))
-          (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-case stx ()
+       (syntax-parse stx
-         [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
+         [(_ () body1 body ...)
-         [(_ () body ...)
+          #'(let () body1 body ...)]
-          (syntax/loc stx (let* () body ...))]
+         [(_ ([pat exp] rest-pats ...) body1 body ...)
-         [(_ ([pat exp] rest ...) body ...)
+          #`(match*/derived 
-          (syntax/loc stx (match exp [pat (match-let* (rest ...) body ...)]))]))
+             #,stx
+             (exp)
+             [(pat) #,(syntax/loc stx (match-let* (rest-pats ...) body1 body ...))])]))
 
      (define-syntax (match-letrec stx)
-       (syntax-case stx ()
+       (syntax-parse stx
-         [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
+         [(_ ((~and cl [pat exp]) ...) body1 body ...)
-         [(_ ([pat exp] ...) . body)
+          (syntax/loc stx (let () 
-          (andmap pattern-var?
+                            #,@(for/list ([c (in-syntax #'(cl ...))]
-                  (syntax->list #'(pat ...)))
+                                          [p (in-syntax #'(pat ...))]
-          (syntax/loc stx (letrec ([pat exp] ...) . body))]
+                                          [e (in-syntax #'(exp ...))])
-         [(_ ([pat exp] ...) . body)
+                                 (syntax/loc c (match-define p e)))
-          (syntax/loc stx (let () (match-define pat exp) ... . body))]))
+                            body1 body ...))]))
 
      (define-syntax (match-define stx)
-       (syntax-case stx ()
+       (syntax-parse stx        
-         [(_ pat exp)
+         [(_ pat rhs:expr)
-          (pattern-var? #'pat)
-          (syntax/loc stx (define pat exp))]
-         [(_ pat rhs)
           ;; FIXME - calls parse twice
           (let ([p (parse-id #'pat (syntax-local-certifier))])
             (with-syntax ([vars (bound-vars p)])
-              (syntax/loc stx
+              (quasisyntax/loc stx
-                (define-values vars (match rhs [pat (values . vars)])))))])))))
+                (define-values vars (match*/derived (rhs) #,stx [(pat) (values . vars)])))))])))))

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
+;; go : syntax syntax syntax [certifier] -> syntax
-(define (go parse/cert stx exprs clauses cert)
+(define (go parse/cert stx exprs clauses [cert (syntax-local-certifier)])
   (syntax-case clauses ()
     [([pats . rhs] ...)
      (nest

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)

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)