55 lines
1.2 KiB
Racket
55 lines
1.2 KiB
Racket
(module case mzscheme
|
|
|
|
(provide (rename my-case srfi:case))
|
|
|
|
(define-syntax case-test
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ x (k))
|
|
(if (symbol? (syntax-e #'k))
|
|
(syntax (eq? x 'k))
|
|
(syntax (eqv? x 'k)))]
|
|
[(_ x (k ...))
|
|
(syntax (memv x '(k ...)))])))
|
|
|
|
(define-syntax my-case
|
|
(lambda (x)
|
|
(syntax-case x (else =>)
|
|
((_ v)
|
|
(syntax (begin v (cond))))
|
|
((_ v (else => e))
|
|
(syntax/loc x (e v)))
|
|
((_ v (else e1 e2 ...))
|
|
(syntax/loc x (begin v e1 e2 ...)))
|
|
((_ v ((k ...) => e) c ...)
|
|
(syntax/loc x (let ((x v))
|
|
(if (case-test x (k ...))
|
|
(e x)
|
|
(my-case x c ...)))))
|
|
((_ v ((k ...) e1 e2 ...))
|
|
(syntax/loc x (if (case-test v (k ...)) (begin e1 e2 ...))))
|
|
((_ v ((k ...) e1 e2 ...) c1 c2 ...)
|
|
(syntax/loc x (let ((x v))
|
|
(if (case-test x (k ...))
|
|
(begin e1 e2 ...)
|
|
(my-case x c1 c2 ...)))))
|
|
((_ v (bad e1 e2 ...) . rest)
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax (not a datum sequence)"
|
|
x
|
|
(syntax bad)))
|
|
((_ v clause . rest)
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax (missing expression after datum sequence)"
|
|
x
|
|
(syntax clause)))
|
|
((_ . v)
|
|
(not (null? (syntax-e (syntax v))))
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax (illegal use of `.')"
|
|
x)))))
|
|
)
|