blob: 06f52f58cda22010cbb7be90eb6d85eb51747b77 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
|
#!r6rs
(library (sweet-macros helper1)
(export local guarded-syntax-case)
(import (rnrs))
(define-syntax local
(lambda (x)
(syntax-case x (syntax-match)
((local expr)
#'expr)
((local (let-form name value) ... (syntax-match b0 b1 b2 ...))
#'(syntax-match (local (let-form name value) ...) b0 b1 b2 ...))
((local (let-form name value) (l n v) ... expr)
#'(let-form ((name value)) (local (l n v) ... expr))))
))
(define-syntax guarded-syntax-case
(let ((add-clause
(lambda (clause acc)
(syntax-case clause ()
((pattern skeleton . rest)
(syntax-case #'rest ()
((cond? else1 else2 ...)
(cons*
#'(pattern cond? skeleton)
#'(pattern (begin else1 else2 ...))
acc))
((cond?)
(cons #'(pattern cond? skeleton) acc))
(()
(cons #'(pattern skeleton) acc))
))))))
(lambda (x)
(syntax-case x ()
((guarded-syntax-case () (literal ...) clause ...)
#'(lambda (y) (guarded-syntax-case y (literal ...) clause ...)))
((guarded-syntax-case y (literal ...) clause ...)
(with-syntax
(((c ...) (fold-right add-clause '() #'(clause ...))))
#'(syntax-case y (literal ...) c ...)))
))))
)
|
