Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
121 lines (102 sloc) 2.27 KB
#lang racket/base
(require (for-syntax racket/base
syntax/parse))
(module+ test
(require rackunit/chk))
(define-syntax (condd stx)
(syntax-parse stx
#:literals (define else)
[(_)
#'(error 'condd "Missing else case")]
[(_ [else . d])
#'(let () . d)]
[(_ (define . d) ...+ . more)
#'(let ()
(define . d) ...
(condd . more))]
[(_ [test . b] . more)
#'(if test
(let () . b)
(condd . more))]))
(module+ test
(chk
(condd
[else (void)])
(void)
(condd
[else 1])
1
(condd
(define first 1)
[else (void)])
(void)
(condd
[#t 1])
1
(condd
(define first 1)
[(= first 2)
"2\n"]
(define first 2)
[(= first 2)
"2 again\n"]
[else
"Nope\n"])
"2 again\n"
#:exn
(condd
[#f 1]
[#f 2])
"Missing else"))
(begin-for-syntax
(define-splicing-syntax-class switch-clause
#:attributes (code-gen)
(pattern (~seq #:cond [t:expr e:expr ...+])
#:attr code-gen
(λ (k)
(quasisyntax/loc #'t
(if t (let () e ...) #,k))))))
(define-syntax (switch stx)
(syntax-parse stx
[(_)
(quasisyntax/loc stx
(error 'switch "Fell through without else clause"))]
[(_ #:else e:expr ...+)
(syntax/loc stx
(begin e ...))]
[(_ (~and x (~not y:keyword)) ...
sc:switch-clause . tail)
(quasisyntax/loc stx
(let ()
x ...
#,((attribute sc.code-gen)
(syntax/loc stx
(switch . tail)))))]))
(module+ test
(chk #:exn (switch)
"Fell through"
(switch #:else 1)
1
(switch #:else 1 2)
2
(switch #:cond [1 2])
2
(switch #:cond [#f 1] #:else 2)
2
(switch #:cond [1 (define x 2) x])
2
(switch #:cond [#f 1] #:cond [2 3] #:else 4)
3
(switch (define one 1)
#:cond [#f 1]
(define two 2)
#:cond [two (+ one one one)]
#:else 4)
3
(switch (define-syntax-rule (one) 1)
#:cond [#f 1]
(define two 2)
(set! two 3)
#:cond [two (+ (one) two)]
#:else 4)
4))