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

some conversion to syntax-parse

Browse Source 
svn: r17250
This commit is contained in:
Sam Tobin-Hochstadt 2009-12-09 22:51:09 +00:00
parent cd0a94d465
commit a9b36c93ae
4 changed files with 80 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

147
collects/scheme/match/define-forms.ss
View File

@ -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)])))))])))))

16
collects/scheme/match/gen-match.ss
View File

@ -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

2
collects/scheme/match/legacy-match.ss
View File

@ -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)

2
collects/scheme/match/match.ss
View File

@ -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)