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

Track disappeared uses of match expanders within match forms (#1349)

Browse Source
This commit is contained in:
Alexis King 2016-06-27 11:13:12 -07:00 committed by Sam Tobin-Hochstadt
parent b9445023c1
commit 517c3cfef9
2 changed files with 64 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

123
racket/collects/racket/match/gen-match.rkt
View File

@ -21,64 +21,65 @@
;; this parses the clauses using parse, then compiles them
;; go : syntax syntax syntax -> syntax
(define (go parse stx es clauses)
(syntax-parse clauses
[([pats . rhs] ...)
(parameterize ([orig-stx stx])
(unless (syntax->list es)
(raise-syntax-error 'match* "expected a sequence of expressions to match" es)))
(define/with-syntax form-name
(syntax-case stx ()
[(fname . _)
(identifier? #'fname)
(syntax-e #'fname)]
[_ 'match]))
(define len (length (syntax->list es)))
(define srcloc-stx (datum->syntax #f 'srcloc stx))
(define/with-syntax (xs ...) (generate-temporaries es))
(define/with-syntax (exprs ...) es)
(define/with-syntax outer-fail (generate-temporary #'fail))
(define/with-syntax orig-expr (if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...)))
(define/with-syntax raise-error
(quasisyntax/loc stx (match:error orig-expr (syntax-srclocs (quote-syntax #,srcloc-stx)) 'form-name)))
(define parsed-clauses
(for/list ([clause (syntax->list clauses)]
[pats (syntax->list #'(pats ...))]
[rhs (syntax->list #'(rhs ...))])
(unless (syntax->list pats)
(raise-syntax-error 'match* "expected a sequence of patterns" pats))
(define lp (length (syntax->list pats)))
(unless (= len lp)
(raise-syntax-error
'match (format "wrong number of match clauses, expected ~a and got ~a" len lp) pats))
(define (mk unm rhs)
(make-Row (for/list ([p (syntax->list pats)]) (parse p))
(syntax-property
(quasisyntax/loc stx
(let () . #,rhs))
'feature-profile:pattern-matching 'antimark)
unm null))
(syntax-parse rhs
[()
(raise-syntax-error
'match
"expected at least one expression on the right-hand side"
clause)]
[(#:when e)
(raise-syntax-error
'match
"expected at least one expression on the right-hand side after #:when clause"
clause)]
[(#:when e rest ...) (mk #f #'((if e (let () rest ...) (fail))))]
[(((~datum =>) unm) . rhs) (mk #'unm #'rhs)]
[_ (mk #f rhs)])))
(define/with-syntax body
(compile* (syntax->list #'(xs ...)) parsed-clauses #'outer-fail))
(define/with-syntax (exprs* ...)
(for/list ([e (in-list (syntax->list #'(exprs ...)))])
(syntax-property e 'feature-profile:pattern-matching 'antimark)))
(syntax-property
(quasisyntax/loc stx
(let ([xs exprs*] ...)
(define (outer-fail) raise-error)
body))
'feature-profile:pattern-matching #t)]))
(with-disappeared-uses
(syntax-parse clauses
[([pats . rhs] ...)
(parameterize ([orig-stx stx])
(unless (syntax->list es)
(raise-syntax-error 'match* "expected a sequence of expressions to match" es)))
(define/with-syntax form-name
(syntax-case stx ()
[(fname . _)
(identifier? #'fname)
(syntax-e #'fname)]
[_ 'match]))
(define len (length (syntax->list es)))
(define srcloc-stx (datum->syntax #f 'srcloc stx))
(define/with-syntax (xs ...) (generate-temporaries es))
(define/with-syntax (exprs ...) es)
(define/with-syntax outer-fail (generate-temporary #'fail))
(define/with-syntax orig-expr (if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...)))
(define/with-syntax raise-error
(quasisyntax/loc stx (match:error orig-expr (syntax-srclocs (quote-syntax #,srcloc-stx)) 'form-name)))
(define parsed-clauses
(for/list ([clause (syntax->list clauses)]
[pats (syntax->list #'(pats ...))]
[rhs (syntax->list #'(rhs ...))])
(unless (syntax->list pats)
(raise-syntax-error 'match* "expected a sequence of patterns" pats))
(define lp (length (syntax->list pats)))
(unless (= len lp)
(raise-syntax-error
'match (format "wrong number of match clauses, expected ~a and got ~a" len lp) pats))
(define (mk unm rhs)
(make-Row (for/list ([p (syntax->list pats)]) (parse p))
(syntax-property
(quasisyntax/loc stx
(let () . #,rhs))
'feature-profile:pattern-matching 'antimark)
unm null))
(syntax-parse rhs
[()
(raise-syntax-error
'match
"expected at least one expression on the right-hand side"
clause)]
[(#:when e)
(raise-syntax-error
'match
"expected at least one expression on the right-hand side after #:when clause"
clause)]
[(#:when e rest ...) (mk #f #'((if e (let () rest ...) (fail))))]
[(((~datum =>) unm) . rhs) (mk #'unm #'rhs)]
[_ (mk #f rhs)])))
(define/with-syntax body
(compile* (syntax->list #'(xs ...)) parsed-clauses #'outer-fail))
(define/with-syntax (exprs* ...)
(for/list ([e (in-list (syntax->list #'(exprs ...)))])
(syntax-property e 'feature-profile:pattern-matching 'antimark)))
(syntax-property
(quasisyntax/loc stx
(let ([xs exprs*] ...)
(define (outer-fail) raise-error)
body))
'feature-profile:pattern-matching #t)])))

4
racket/collects/racket/match/parse.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require racket/struct-info
racket/syntax
"patterns.rkt"
"parse-helper.rkt"
"parse-quasi.rkt"
@ -29,8 +30,7 @@
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
[(expander args ...)
(and (identifier? #'expander)
(match-expander? (syntax-local-value #'expander
(lambda () #f))))
(syntax-local-value/record #'expander match-expander?))
(match-expander-transform
rearm+parse #'expander disarmed-stx match-expander-proc
"This expander only works with the legacy match syntax")]