From f9616959e9f7d03eebc88c8b5964ef4d5242adf2 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 22 Oct 2013 12:21:05 -0400 Subject: [PATCH] add #:when to match --- .../racket-test/tests/match/examples.rkt | 11 ++ racket/collects/racket/match/gen-match.rkt | 109 ++++++++---------- 2 files changed, 61 insertions(+), 59 deletions(-) diff --git a/pkgs/racket-pkgs/racket-test/tests/match/examples.rkt b/pkgs/racket-pkgs/racket-test/tests/match/examples.rkt index b1723ad7ce..662170eb69 100644 --- a/pkgs/racket-pkgs/racket-test/tests/match/examples.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/match/examples.rkt @@ -717,4 +717,15 @@ (failure-cont) 0)] [_ 1])) + + (comp 0 + (match (cons 1 2) + [(cons a b) #:when (= a b) 1] + [_ 0])) + + (comp 1 + (match (cons 1 1) + [(cons a b) #:when (= a b) 1] + [_ 0])) + )) diff --git a/racket/collects/racket/match/gen-match.rkt b/racket/collects/racket/match/gen-match.rkt index 6c1ab8bb5b..ecf86c4e44 100644 --- a/racket/collects/racket/match/gen-match.rkt +++ b/racket/collects/racket/match/gen-match.rkt @@ -1,8 +1,8 @@ #lang racket/base (require "patterns.rkt" "compiler.rkt" - syntax/stx syntax/parse - (for-template racket/base (only-in "runtime.rkt" match:error))) + syntax/stx syntax/parse racket/syntax + (for-template racket/base (only-in "runtime.rkt" match:error fail))) (provide go go/one) @@ -20,62 +20,53 @@ ;; this parses the clauses using parse, then compiles them ;; go : syntax syntax syntax -> syntax -(define (go parse stx exprs clauses) - (syntax-case clauses () +(define (go parse stx es clauses) + (syntax-parse clauses [([pats . rhs] ...) (parameterize ([orig-stx stx]) - (unless (syntax->list exprs) - (raise-syntax-error - 'match* - "expected a sequence of expressions to match" - exprs))) - (let ([len (length (syntax->list exprs))] - [srcloc-list (list - #`(quote #,(syntax-source stx)) - #`(quote #,(syntax-line stx)) - #`(quote #,(syntax-column stx)) - #`(quote #,(syntax-position stx)) - #`(quote #,(syntax-span stx)))]) - (with-syntax ([(xs ...) (generate-temporaries exprs)] - [(exprs ...) exprs] - [(fail) (generate-temporaries #'(fail))]) - (with-syntax ([body - (compile* - (syntax->list #'(xs ...)) - (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)) - (let ([lp (length (syntax->list pats))]) - (when (null? (syntax->list rhs)) - (raise-syntax-error - 'match - "expected at least one expression on the right-hand side" - clause)) - (unless (= len lp) - (raise-syntax-error - 'match - (format - "wrong number of match clauses, expected ~a and got ~a" - len lp) - pats)) - (let ([mk (lambda (unm rhs) - (make-Row (for/list ([p (syntax->list pats)]) - (parse p)) - #`(let-values () . #,rhs) unm null))]) - (syntax-case* rhs (=>) - (lambda (x y) (eq? (syntax-e x) (syntax-e y))) - [((=> unm) . rhs) (mk #'unm #'rhs)] - [_ (mk #f rhs)])))) - #'fail)] - [orig-expr - (if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...))]) - (quasisyntax/loc stx - (let ([xs exprs] ...) - (let ([fail (lambda () - #,(quasisyntax/loc stx (match:error orig-expr (list (srcloc #,@srcloc-list)))))]) - body))))))])) + (unless (syntax->list es) + (raise-syntax-error 'match* "expected a sequence of expressions to match" es))) + (define len (length (syntax->list es))) + (define srcloc-list (list #`(quote #,(syntax-source stx)) + #`(quote #,(syntax-line stx)) + #`(quote #,(syntax-column stx)) + #`(quote #,(syntax-position stx)) + #`(quote #,(syntax-span 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 (list (srcloc #,@srcloc-list))))) + (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)) + #`(let () . #,rhs) 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)) + (quasisyntax/loc stx + (let ([xs exprs] ...) + (define (outer-fail) raise-error) + body))]))