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

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

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