From 517c3cfef9869030ab8aa058b62e57bd8614572c Mon Sep 17 00:00:00 2001 From: Alexis King Date: Mon, 27 Jun 2016 11:13:12 -0700 Subject: [PATCH] Track disappeared uses of match expanders within match forms (#1349) --- racket/collects/racket/match/gen-match.rkt | 123 +++++++++++---------- racket/collects/racket/match/parse.rkt | 4 +- 2 files changed, 64 insertions(+), 63 deletions(-) diff --git a/racket/collects/racket/match/gen-match.rkt b/racket/collects/racket/match/gen-match.rkt index c395db09b4..38cc5f0e99 100644 --- a/racket/collects/racket/match/gen-match.rkt +++ b/racket/collects/racket/match/gen-match.rkt @@ -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)]))) diff --git a/racket/collects/racket/match/parse.rkt b/racket/collects/racket/match/parse.rkt index 116b2df974..74ec2463dd 100644 --- a/racket/collects/racket/match/parse.rkt +++ b/racket/collects/racket/match/parse.rkt @@ -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")]