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]))
)) ))

79
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)))
(let ([len (length (syntax->list exprs))]
[srcloc-list (list
#`(quote #,(syntax-source stx))
#`(quote #,(syntax-line stx)) #`(quote #,(syntax-line stx))
#`(quote #,(syntax-column stx)) #`(quote #,(syntax-column stx))
#`(quote #,(syntax-position stx)) #`(quote #,(syntax-position stx))
#`(quote #,(syntax-span stx)))]) #`(quote #,(syntax-span stx))))
(with-syntax ([(xs ...) (generate-temporaries exprs)] (define/with-syntax (xs ...) (generate-temporaries es))
[(exprs ...) exprs] (define/with-syntax (exprs ...) es)
[(fail) (generate-temporaries #'(fail))]) (define/with-syntax outer-fail (generate-temporary #'fail))
(with-syntax ([body (define/with-syntax orig-expr (if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...)))
(compile* (define/with-syntax raise-error (quasisyntax/loc stx (match:error orig-expr (list (srcloc #,@srcloc-list)))))
(syntax->list #'(xs ...)) (define parsed-clauses
(for/list ([clause (syntax->list clauses)] (for/list ([clause (syntax->list clauses)]
[pats (syntax->list #'(pats ...))] [pats (syntax->list #'(pats ...))]
[rhs (syntax->list #'(rhs ...))]) [rhs (syntax->list #'(rhs ...))])
(unless (syntax->list pats) (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 (raise-syntax-error
'match* 'match (format "wrong number of match clauses, expected ~a and got ~a" len lp) pats))
"expected a sequence of patterns" (define (mk unm rhs)
pats)) (make-Row (for/list ([p (syntax->list pats)]) (parse p))
(let ([lp (length (syntax->list pats))]) #`(let () . #,rhs) unm null))
(when (null? (syntax->list rhs)) (syntax-parse 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))])
(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 (quasisyntax/loc stx
(let ([xs exprs] ...) (let ([xs exprs] ...)
(let ([fail (lambda () (define (outer-fail) raise-error)
#,(quasisyntax/loc stx (match:error orig-expr (list (srcloc #,@srcloc-list)))))]) body))]))
body))))))]))