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

add #:when to match

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2013-10-22 12:21:05 -04:00
parent 1d7cd499c1
commit f9616959e9
2 changed files with 61 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
pkgs/racket-pkgs/racket-test/tests/match/examples.rkt
View File

@ -717,4 +717,15 @@
(failure-cont) (failure-cont)
0)] 0)]
[_ 1])) [_ 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]))
)) ))

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

@ -1,8 +1,8 @@
#lang racket/base #lang racket/base
(require "patterns.rkt" "compiler.rkt" (require "patterns.rkt" "compiler.rkt"
syntax/stx syntax/parse syntax/stx syntax/parse racket/syntax
(for-template racket/base (only-in "runtime.rkt" match:error))) (for-template racket/base (only-in "runtime.rkt" match:error fail)))
(provide go go/one) (provide go go/one)
@ -20,62 +20,53 @@
;; 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 exprs clauses) (define (go parse stx es clauses)
(syntax-case clauses () (syntax-parse clauses
[([pats . rhs] ...) [([pats . rhs] ...)
(parameterize ([orig-stx stx]) (parameterize ([orig-stx stx])
(unless (syntax->list exprs) (unless (syntax->list es)
(raise-syntax-error (raise-syntax-error 'match* "expected a sequence of expressions to match" es)))
'match* (define len (length (syntax->list es)))
"expected a sequence of expressions to match" (define srcloc-list (list #`(quote #,(syntax-source stx))
exprs))) #`(quote #,(syntax-line stx))
(let ([len (length (syntax->list exprs))] #`(quote #,(syntax-column stx))
[srcloc-list (list #`(quote #,(syntax-position stx))
#`(quote #,(syntax-source stx)) #`(quote #,(syntax-span stx))))
#`(quote #,(syntax-line stx)) (define/with-syntax (xs ...) (generate-temporaries es))
#`(quote #,(syntax-column stx)) (define/with-syntax (exprs ...) es)
#`(quote #,(syntax-position stx)) (define/with-syntax outer-fail (generate-temporary #'fail))
#`(quote #,(syntax-span stx)))]) (define/with-syntax orig-expr (if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...)))
(with-syntax ([(xs ...) (generate-temporaries exprs)] (define/with-syntax raise-error (quasisyntax/loc stx (match:error orig-expr (list (srcloc #,@srcloc-list)))))
[(exprs ...) exprs] (define parsed-clauses
[(fail) (generate-temporaries #'(fail))]) (for/list ([clause (syntax->list clauses)]
(with-syntax ([body [pats (syntax->list #'(pats ...))]
(compile* [rhs (syntax->list #'(rhs ...))])
(syntax->list #'(xs ...)) (unless (syntax->list pats)
(for/list ([clause (syntax->list clauses)] (raise-syntax-error 'match* "expected a sequence of patterns" pats))
[pats (syntax->list #'(pats ...))] (define lp (length (syntax->list pats)))
[rhs (syntax->list #'(rhs ...))]) (unless (= len lp)
(unless (syntax->list pats) (raise-syntax-error
(raise-syntax-error 'match (format "wrong number of match clauses, expected ~a and got ~a" len lp) pats))
'match* (define (mk unm rhs)
"expected a sequence of patterns" (make-Row (for/list ([p (syntax->list pats)]) (parse p))
pats)) #`(let () . #,rhs) unm null))
(let ([lp (length (syntax->list pats))]) (syntax-parse rhs
(when (null? (syntax->list rhs)) [()
(raise-syntax-error (raise-syntax-error
'match 'match
"expected at least one expression on the right-hand side" "expected at least one expression on the right-hand side"
clause)) clause)]
(unless (= len lp) [(#:when e)
(raise-syntax-error (raise-syntax-error
'match 'match
(format "expected at least one expression on the right-hand side after #:when clause"
"wrong number of match clauses, expected ~a and got ~a" clause)]
len lp) [(#:when e rest ...) (mk #f #'((if e (let () rest ...) (fail))))]
pats)) [(((~datum =>) unm) . rhs) (mk #'unm #'rhs)]
(let ([mk (lambda (unm rhs) [_ (mk #f rhs)])))
(make-Row (for/list ([p (syntax->list pats)]) (define/with-syntax body
(parse p)) (compile* (syntax->list #'(xs ...)) parsed-clauses #'outer-fail))
#`(let-values () . #,rhs) unm null))]) (quasisyntax/loc stx
(syntax-case* rhs (=>) (let ([xs exprs] ...)
(lambda (x y) (eq? (syntax-e x) (syntax-e y))) (define (outer-fail) raise-error)
[((=> unm) . rhs) (mk #'unm #'rhs)] body))]))
[_ (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))))))]))