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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
|
(library (sweet-macros)
;;; Version: 0.5
;;; Author: Michele Simionato
;;; Email: michele.simionato@gmail.com
;;; Date: 07-Feb-2009
;;; Licence: BSD
(export syntax-match def-syntax syntax-expand local)
(import (rnrs))
;; helper macro 1
(define-syntax local
(lambda (x)
(syntax-case x (syntax-match)
((local expr)
#'expr)
((local (let-form name value) ... (syntax-match rest ...))
#'(syntax-match (local (let-form name value) ...) rest ...))
((local (let-form name value) (l n v) ... expr)
#'(let-form ((name value)) (local (l n v) ... expr))))
))
;; helper macro 2
(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 ...)))
))))
(define-syntax syntax-match
(guarded-syntax-case () (sub local)
((self (local (let-form name value) ...) (literal ...)
(sub patt skel . rest) ...)
#'(local (let-form name value) ...
(guarded-syntax-case ()
(<literals> <patterns> <source> <transformer> literal ...)
((ctx <literals>)
#''((... (... literal)) ...))
((ctx <patterns>)
#''((... (... patt)) ...))
((ctx <source>)
#''(self (local (let-form name value) ...) ((... (... literal)) ...)
(... (... (sub patt skel . rest))) ...))
((ctx <transformer>)
#'(self (local (let-form name value) ...) ((... (... literal)) ...)
(... (... (sub patt skel . rest))) ...))
(patt skel . rest) ...))
(for-all identifier? #'(literal ...))
(syntax-violation 'syntax-match "Found non identifier" #'(literal ...)
(remp identifier? #'(literal ...))))
((self (literal ...) (sub patt skel . rest) ...)
#'(self (local)(literal ...) (sub patt skel . rest) ...))
((self x (literal ...) (sub patt skel . rest) ...)
#'(guarded-syntax-case x (literal ...) (patt skel . rest) ...))
))
(define-syntax def-syntax
(syntax-match (extends local)
(sub (def-syntax name (extends parent)
(local loc ...) (literal ...)
clause ...)
#'(define-syntax name
(syntax-match (local loc ...) (literal ...)
clause ...
(sub x ((parent <transformer>) #'x)))))
(sub (def-syntax (name . args) skel . rest)
#'(define-syntax name (syntax-match () (sub (name . args) skel . rest))))
(sub (def-syntax name transformer)
#'(define-syntax name transformer))
))
(def-syntax (syntax-expand (macro . args))
#'(syntax->datum ((macro <transformer>) #'(... (... (macro . args))))))
)
;;; LEGALESE
;; Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;; Redistributions in bytecode form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in
;; the documentation and/or other materials provided with the
;; distribution.
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
;; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
;; OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
;; TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
;; DAMAGE.
|
