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

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

@ -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))
(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)))])
(with-syntax ([(xs ...) (generate-temporaries exprs)]
[(exprs ...) exprs]
[(fail) (generate-temporaries #'(fail))])
(with-syntax ([body
(compile*
(syntax->list #'(xs ...))
#`(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*
"expected a sequence of patterns"
pats))
(let ([lp (length (syntax->list pats))])
(when (null? (syntax->list rhs))
'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))
(unless (= len lp)
clause)]
[(#:when e)
(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 ...))])
"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] ...)
(let ([fail (lambda ()
#,(quasisyntax/loc stx (match:error orig-expr (list (srcloc #,@srcloc-list)))))])
body))))))]))
(define (outer-fail) raise-error)
body))]))