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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
(define-syntax rule
(sc-macro-transformer
(lambda (form env)
(if (syntax-match? '(DATUM EXPRESSION DATUM) (cdr form))
(compile-rule (cadr form) (caddr form) (cadddr form) env)
(ill-formed-syntax form)))))
(define (compile-rule pattern restriction template env)
(let ((names (pattern-names pattern)))
`(rule:make ,(compile-pattern pattern env)
,(compile-restriction restriction env names)
,(compile-instantiator template env names))))
;;; These could be generic, but I am lazy today... GJS
(define (pattern-names pattern)
(let loop ((pattern pattern) (names '()))
(cond ((or (match:element? pattern)
(match:segment? pattern))
(let ((name (match:variable-name pattern)))
(if (memq name names)
names
(cons name names))))
((list? pattern)
(let elt-loop ((elts pattern) (names names))
(if (pair? elts)
(elt-loop (cdr elts) (loop (car elts) names))
names)))
(else names))))
(define (compile-pattern pattern env)
(let loop ((pattern pattern))
(cond ((match:element? pattern)
(if (match:restricted? pattern)
`(match:element ',(match:variable-name pattern)
,(match:restriction pattern))
`(match:element ',(match:variable-name pattern))))
((match:segment? pattern)
`(match:segment ',(match:variable-name pattern)))
((null? pattern)
`(match:eqv '()))
((list? pattern)
`(match:list ,@(map loop pattern)))
(else
`(match:eqv ',pattern)))))
;;; These are repeated from match.scm
(define (match:element? pattern)
(and (pair? pattern)
(eq? (car pattern) '?)))
(define (match:segment? pattern)
(and (pair? pattern)
(eq? (car pattern) '??)))
(define (match:variable-name pattern)
(cadr pattern))
(define (match:restricted? pattern)
(not (null? (cddr pattern))))
(define (match:restriction pattern)
(caddr pattern))
;;; The restriction is a predicate that must be true for the rule to
;;; be applicable. This is not the same as a variable element
;;; restriction.
(define (compile-restriction expr env names)
(if (eq? expr 'none)
`#f
(make-lambda names env
(lambda (env)
(close-syntax expr env)))))
(define (compile-instantiator skel env names)
(make-lambda names env
(lambda (env)
(list 'quasiquote
(let ((wrap (lambda (expr) (close-syntax expr env))))
(let loop ((skel skel))
(cond ((skel:element? skel)
(list 'unquote
(wrap (skel:element-expression skel))))
((skel:segment? skel)
(list 'unquote-splicing
(wrap (skel:segment-expression skel))))
((list? skel) (map loop skel))
(else skel))))))))
(define (skel:constant? skeleton)
(not (pair? skeleton)))
(define (skel:element? skeleton)
(and (pair? skeleton)
(eq? (car skeleton) '?)))
(define (skel:element-expression skeleton)
(cadr skeleton))
(define (skel:segment? skeleton)
(and (pair? skeleton)
(eq? (car skeleton) '??)))
(define (skel:segment-expression skeleton)
(cadr skeleton))
;; Magic!
(define (make-lambda bvl use-env generate-body)
(capture-syntactic-environment
(lambda (transform-env)
(close-syntax `(,(close-syntax 'lambda transform-env)
,bvl
,(capture-syntactic-environment
(lambda (use-env*)
(close-syntax (generate-body use-env*)
transform-env))))
use-env))))
#|
;;; For example
(pp (syntax '(rule (+ (? a) (+ (? b) (? c)))
none
(+ (+ (? a) (? b)) (? c)) )
(the-environment)))
(rule:make
(match:list
(match:eqv (quote +))
(match:element (quote a))
(match:list (match:eqv (quote +))
(match:element (quote b))
(match:element (quote c))))
#f
(lambda (c b a)
(list (quote +) (list (quote +) a b) c)))
(pp (syntax '(rule (+ (? a) (+ (? b) (? c)))
(> a 3)
(+ (+ (? a) (? b)) (? c)) )
(the-environment)))
(rule:make
(match:list
(match:eqv (quote +))
(match:element (quote a))
(match:list (match:eqv (quote +))
(match:element (quote b))
(match:element (quote c))))
(lambda (c b a)
(> a 3))
(lambda (c b a)
(list (quote +) (list (quote +) a b) c)))
|#
|
