Commit | Line | Data |
---|---|---|
811d10f5 AW |
1 | ;;;; Copyright (C) 2009 Free Software Foundation, Inc. |
2 | ;;;; | |
3 | ;;;; This library is free software; you can redistribute it and/or | |
4 | ;;;; modify it under the terms of the GNU Lesser General Public | |
5 | ;;;; License as published by the Free Software Foundation; either | |
6 | ;;;; version 2.1 of the License, or (at your option) any later version. | |
7 | ;;;; | |
8 | ;;;; This library is distributed in the hope that it will be useful, | |
9 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
11 | ;;;; Lesser General Public License for more details. | |
12 | ;;;; | |
13 | ;;;; You should have received a copy of the GNU Lesser General Public | |
14 | ;;;; License along with this library; if not, write to the Free Software | |
15 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
16 | ;;;; | |
17 | \f | |
18 | ||
19 | (define-module (language tree-il) | |
20 | #:use-module (system base pmatch) | |
21 | #:use-module (system base syntax) | |
9efc833d | 22 | #:export (tree-il-src |
811d10f5 | 23 | |
cf10678f | 24 | <void> void? make-void void-src |
81fd3152 | 25 | <const> const? make-const const-src const-exp |
cb28c085 AW |
26 | <primitive-ref> primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name |
27 | <lexical-ref> lexical-ref? make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym | |
28 | <lexical-set> lexical-set? make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp | |
29 | <module-ref> module-ref? make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public? | |
30 | <module-set> module-set? make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp | |
31 | <toplevel-ref> toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name | |
32 | <toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp | |
33 | <toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp | |
81fd3152 AW |
34 | <conditional> conditional? make-conditional conditional-src conditional-test conditional-then conditional-else |
35 | <application> application? make-application application-src application-proc application-args | |
cb28c085 | 36 | <sequence> sequence? make-sequence sequence-src sequence-exps |
81fd3152 | 37 | <lambda> lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body |
f4aa8d53 AW |
38 | <let> let? make-let let-src let-names let-vars let-vals let-body |
39 | <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body | |
40 | <let-values> let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body | |
41 | ||
9efc833d AW |
42 | parse-tree-il |
43 | unparse-tree-il | |
cb28c085 AW |
44 | tree-il->scheme |
45 | ||
46 | post-order! | |
47 | pre-order!)) | |
811d10f5 AW |
48 | |
49 | (define-type (<tree-il> #:common-slots (src)) | |
cf10678f | 50 | (<void>) |
81fd3152 | 51 | (<const> exp) |
811d10f5 AW |
52 | (<primitive-ref> name) |
53 | (<lexical-ref> name gensym) | |
54 | (<lexical-set> name gensym exp) | |
55 | (<module-ref> mod name public?) | |
56 | (<module-set> mod name public? exp) | |
57 | (<toplevel-ref> name) | |
58 | (<toplevel-set> name exp) | |
59 | (<toplevel-define> name exp) | |
81fd3152 AW |
60 | (<conditional> test then else) |
61 | (<application> proc args) | |
811d10f5 | 62 | (<sequence> exps) |
81fd3152 | 63 | (<lambda> names vars meta body) |
f4aa8d53 AW |
64 | (<let> names vars vals body) |
65 | (<letrec> names vars vals body) | |
66 | (<let-values> names vars exp body)) | |
811d10f5 | 67 | |
811d10f5 AW |
68 | \f |
69 | ||
811d10f5 AW |
70 | (define (location x) |
71 | (and (pair? x) | |
72 | (let ((props (source-properties x))) | |
81fd3152 | 73 | (and (pair? props) props)))) |
811d10f5 | 74 | |
ce09ee19 | 75 | (define (parse-tree-il exp) |
811d10f5 | 76 | (let ((loc (location exp)) |
ce09ee19 | 77 | (retrans (lambda (x) (parse-tree-il x)))) |
811d10f5 | 78 | (pmatch exp |
cf10678f AW |
79 | ((void) |
80 | (make-void loc)) | |
81 | ||
ce09ee19 AW |
82 | ((apply ,proc . ,args) |
83 | (make-application loc (retrans proc) (map retrans args))) | |
811d10f5 AW |
84 | |
85 | ((if ,test ,then ,else) | |
86 | (make-conditional loc (retrans test) (retrans then) (retrans else))) | |
87 | ||
88 | ((primitive ,name) (guard (symbol? name)) | |
89 | (make-primitive-ref loc name)) | |
90 | ||
91 | ((lexical ,name) (guard (symbol? name)) | |
92 | (make-lexical-ref loc name name)) | |
93 | ||
94 | ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym)) | |
95 | (make-lexical-ref loc name sym)) | |
96 | ||
97 | ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym)) | |
98 | (make-lexical-set loc name sym (retrans exp))) | |
99 | ||
100 | ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) | |
101 | (make-module-ref loc mod name #t)) | |
102 | ||
103 | ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) | |
104 | (make-module-set loc mod name #t (retrans exp))) | |
105 | ||
106 | ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) | |
107 | (make-module-ref loc mod name #f)) | |
108 | ||
ce09ee19 | 109 | ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) |
811d10f5 AW |
110 | (make-module-set loc mod name #f (retrans exp))) |
111 | ||
112 | ((toplevel ,name) (guard (symbol? name)) | |
113 | (make-toplevel-ref loc name)) | |
114 | ||
ce09ee19 | 115 | ((set! (toplevel ,name) ,exp) (guard (symbol? name)) |
811d10f5 AW |
116 | (make-toplevel-set loc name (retrans exp))) |
117 | ||
ce09ee19 | 118 | ((define ,name ,exp) (guard (symbol? name)) |
811d10f5 AW |
119 | (make-toplevel-define loc name (retrans exp))) |
120 | ||
696495f4 AW |
121 | ((lambda ,names ,vars ,exp) |
122 | (make-lambda loc names vars '() (retrans exp))) | |
811d10f5 | 123 | |
696495f4 AW |
124 | ((lambda ,names ,vars ,meta ,exp) |
125 | (make-lambda loc names vars meta (retrans exp))) | |
811d10f5 AW |
126 | |
127 | ((const ,exp) | |
128 | (make-const loc exp)) | |
129 | ||
130 | ((begin . ,exps) | |
131 | (make-sequence loc (map retrans exps))) | |
132 | ||
f4aa8d53 AW |
133 | ((let ,names ,vars ,vals ,body) |
134 | (make-let loc names vars (map retrans vals) (retrans body))) | |
135 | ||
136 | ((letrec ,names ,vars ,vals ,body) | |
137 | (make-letrec loc names vars (map retrans vals) (retrans body))) | |
811d10f5 | 138 | |
f4aa8d53 AW |
139 | ((let-values ,names ,vars ,exp ,body) |
140 | (make-let-values loc names vars (retrans exp) (retrans body))) | |
811d10f5 AW |
141 | |
142 | (else | |
143 | (error "unrecognized tree-il" exp))))) | |
144 | ||
145 | (define (unparse-tree-il tree-il) | |
146 | (record-case tree-il | |
cf10678f AW |
147 | ((<void>) |
148 | '(void)) | |
149 | ||
811d10f5 | 150 | ((<application> proc args) |
ce09ee19 | 151 | `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args))) |
811d10f5 AW |
152 | |
153 | ((<conditional> test then else) | |
154 | `(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il else))) | |
155 | ||
156 | ((<primitive-ref> name) | |
157 | `(primitive ,name)) | |
158 | ||
159 | ((<lexical-ref> name gensym) | |
160 | `(lexical ,name ,gensym)) | |
161 | ||
162 | ((<lexical-set> name gensym exp) | |
163 | `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp))) | |
164 | ||
165 | ((<module-ref> mod name public?) | |
166 | `(,(if public? '@ '@@) ,mod ,name)) | |
167 | ||
168 | ((<module-set> mod name public? exp) | |
169 | `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp))) | |
170 | ||
171 | ((<toplevel-ref> name) | |
172 | `(toplevel ,name)) | |
173 | ||
174 | ((<toplevel-set> name exp) | |
175 | `(set! (toplevel ,name) ,(unparse-tree-il exp))) | |
176 | ||
177 | ((<toplevel-define> name exp) | |
178 | `(define ,name ,(unparse-tree-il exp))) | |
179 | ||
696495f4 AW |
180 | ((<lambda> names vars meta body) |
181 | `(lambda ,names ,vars ,meta ,(unparse-tree-il body))) | |
811d10f5 AW |
182 | |
183 | ((<const> exp) | |
184 | `(const ,exp)) | |
185 | ||
186 | ((<sequence> exps) | |
187 | `(begin ,@(map unparse-tree-il exps))) | |
188 | ||
f4aa8d53 AW |
189 | ((<let> names vars vals body) |
190 | `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) | |
811d10f5 | 191 | |
f4aa8d53 AW |
192 | ((<letrec> names vars vals body) |
193 | `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) | |
194 | ||
195 | ((<let-values> names vars exp body) | |
196 | `(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body))))) | |
811d10f5 AW |
197 | |
198 | (define (tree-il->scheme e) | |
f4aa8d53 AW |
199 | (record-case e |
200 | ((<void>) | |
201 | '(if #f #f)) | |
202 | ||
203 | ((<application> proc args) | |
204 | `(,(tree-il->scheme proc) ,@(map tree-il->scheme args))) | |
205 | ||
206 | ((<conditional> test then else) | |
207 | (if (void? else) | |
208 | `(if ,(tree-il->scheme test) ,(tree-il->scheme then)) | |
209 | `(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else)))) | |
210 | ||
211 | ((<primitive-ref> name) | |
212 | name) | |
213 | ||
214 | ((<lexical-ref> name gensym) | |
215 | gensym) | |
216 | ||
217 | ((<lexical-set> name gensym exp) | |
218 | `(set! ,gensym ,(tree-il->scheme exp))) | |
219 | ||
220 | ((<module-ref> mod name public?) | |
221 | `(,(if public? '@ '@@) ,mod ,name)) | |
222 | ||
223 | ((<module-set> mod name public? exp) | |
224 | `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp))) | |
225 | ||
226 | ((<toplevel-ref> name) | |
227 | name) | |
228 | ||
229 | ((<toplevel-set> name exp) | |
230 | `(set! ,name ,(tree-il->scheme exp))) | |
231 | ||
232 | ((<toplevel-define> name exp) | |
233 | `(define ,name ,(tree-il->scheme exp))) | |
234 | ||
235 | ((<lambda> vars meta body) | |
236 | `(lambda ,vars | |
237 | ,@(cond ((assq-ref meta 'documentation) => list) (else '())) | |
238 | ,(tree-il->scheme body))) | |
239 | ||
240 | ((<const> exp) | |
241 | (if (and (self-evaluating? exp) (not (vector? exp))) | |
242 | exp | |
243 | (list 'quote exp))) | |
244 | ||
245 | ((<sequence> exps) | |
246 | `(begin ,@(map tree-il->scheme exps))) | |
247 | ||
248 | ((<let> vars vals body) | |
249 | `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) | |
250 | ||
251 | ((<letrec> vars vals body) | |
252 | `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) | |
253 | ||
254 | ((<let-values> vars exp body) | |
255 | `(call-with-values (lambda () ,(tree-il->scheme exp)) | |
256 | (lambda ,vars ,(tree-il->scheme body)))))) | |
cb28c085 AW |
257 | |
258 | (define (post-order! f x) | |
259 | (let lp ((x x)) | |
260 | (record-case x | |
261 | ((<application> proc args) | |
262 | (set! (application-proc x) (lp proc)) | |
f4aa8d53 | 263 | (set! (application-args x) (map lp args))) |
cb28c085 AW |
264 | |
265 | ((<conditional> test then else) | |
266 | (set! (conditional-test x) (lp test)) | |
267 | (set! (conditional-then x) (lp then)) | |
f4aa8d53 AW |
268 | (set! (conditional-else x) (lp else))) |
269 | ||
cb28c085 | 270 | ((<lexical-set> name gensym exp) |
f4aa8d53 AW |
271 | (set! (lexical-set-exp x) (lp exp))) |
272 | ||
cb28c085 | 273 | ((<module-set> mod name public? exp) |
f4aa8d53 AW |
274 | (set! (module-set-exp x) (lp exp))) |
275 | ||
cb28c085 | 276 | ((<toplevel-set> name exp) |
f4aa8d53 AW |
277 | (set! (toplevel-set-exp x) (lp exp))) |
278 | ||
cb28c085 | 279 | ((<toplevel-define> name exp) |
f4aa8d53 AW |
280 | (set! (toplevel-define-exp x) (lp exp))) |
281 | ||
cb28c085 | 282 | ((<lambda> vars meta body) |
f4aa8d53 AW |
283 | (set! (lambda-body x) (lp body))) |
284 | ||
cb28c085 | 285 | ((<sequence> exps) |
f4aa8d53 AW |
286 | (set! (sequence-exps x) (map lp exps))) |
287 | ||
288 | ((<let> vars vals body) | |
cb28c085 | 289 | (set! (let-vals x) (map lp vals)) |
f4aa8d53 AW |
290 | (set! (let-body x) (lp body))) |
291 | ||
292 | ((<letrec> vars vals body) | |
cb28c085 | 293 | (set! (letrec-vals x) (map lp vals)) |
f4aa8d53 AW |
294 | (set! (letrec-body x) (lp body))) |
295 | ||
296 | ((<let-values> vars exp body) | |
297 | (set! (let-values-exp x) (lp exp)) | |
298 | (set! (let-values-body x) (lp body))) | |
299 | ||
300 | (else #f)) | |
301 | ||
302 | (or (f x) x))) | |
cb28c085 AW |
303 | |
304 | (define (pre-order! f x) | |
305 | (let lp ((x x)) | |
306 | (let ((x (or (f x) x))) | |
307 | (record-case x | |
308 | ((<application> proc args) | |
309 | (set! (application-proc x) (lp proc)) | |
310 | (set! (application-args x) (map lp args))) | |
311 | ||
312 | ((<conditional> test then else) | |
313 | (set! (conditional-test x) (lp test)) | |
314 | (set! (conditional-then x) (lp then)) | |
315 | (set! (conditional-else x) (lp else))) | |
316 | ||
317 | ((<lexical-set> name gensym exp) | |
318 | (set! (lexical-set-exp x) (lp exp))) | |
319 | ||
320 | ((<module-set> mod name public? exp) | |
321 | (set! (module-set-exp x) (lp exp))) | |
322 | ||
323 | ((<toplevel-set> name exp) | |
324 | (set! (toplevel-set-exp x) (lp exp))) | |
325 | ||
326 | ((<toplevel-define> name exp) | |
327 | (set! (toplevel-define-exp x) (lp exp))) | |
328 | ||
329 | ((<lambda> vars meta body) | |
330 | (set! (lambda-body x) (lp body))) | |
331 | ||
332 | ((<sequence> exps) | |
333 | (set! (sequence-exps x) (map lp exps))) | |
334 | ||
f4aa8d53 | 335 | ((<let> vars vals body) |
cb28c085 | 336 | (set! (let-vals x) (map lp vals)) |
f4aa8d53 | 337 | (set! (let-body x) (lp body))) |
cb28c085 | 338 | |
f4aa8d53 | 339 | ((<letrec> vars vals body) |
cb28c085 | 340 | (set! (letrec-vals x) (map lp vals)) |
f4aa8d53 AW |
341 | (set! (letrec-body x) (lp body))) |
342 | ||
343 | ((<let-values> vars exp body) | |
344 | (set! (let-values-exp x) (lp exp)) | |
345 | (set! (let-values-body x) (lp body))) | |
cb28c085 AW |
346 | |
347 | (else #f)) | |
348 | x))) |