Commit | Line | Data |
---|---|---|
ce09ee19 AW |
1 | ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- |
2 | ;;;; Andy Wingo <wingo@pobox.com> --- May 2009 | |
3 | ;;;; | |
4 | ;;;; Copyright (C) 2009 Free Software Foundation, Inc. | |
5 | ;;;; | |
6 | ;;;; This library is free software; you can redistribute it and/or | |
7 | ;;;; modify it under the terms of the GNU Lesser General Public | |
8 | ;;;; License as published by the Free Software Foundation; either | |
9 | ;;;; version 2.1 of the License, or (at your option) any later version. | |
10 | ;;;; | |
11 | ;;;; This library is distributed in the hope that it will be useful, | |
12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
14 | ;;;; Lesser General Public License for more details. | |
15 | ;;;; | |
16 | ;;;; You should have received a copy of the GNU Lesser General Public | |
17 | ;;;; License along with this library; if not, write to the Free Software | |
18 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
19 | ||
20 | (define-module (test-suite tree-il) | |
21 | #:use-module (test-suite lib) | |
22 | #:use-module (system base compile) | |
23 | #:use-module (system base pmatch) | |
24 | #:use-module (language tree-il) | |
25 | #:use-module (language glil)) | |
26 | ||
27 | (define-syntax assert-scheme->glil | |
28 | (syntax-rules () | |
29 | ((_ in out) | |
30 | (let ((tree-il (compile 'in #:from 'scheme #:to 'tree-il))) | |
31 | (pass-if 'in | |
32 | (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil)) | |
33 | 'out)))))) | |
34 | ||
35 | (define-syntax assert-tree-il->glil | |
36 | (syntax-rules () | |
37 | ((_ in out) | |
38 | (pass-if 'in | |
39 | (let ((tree-il (parse-tree-il 'in))) | |
40 | (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil)) | |
41 | 'out)))))) | |
42 | ||
43 | (define-syntax assert-tree-il->glil/pmatch | |
44 | (syntax-rules () | |
45 | ((_ in pat test ...) | |
46 | (let ((exp 'in)) | |
47 | (pass-if 'in | |
48 | (let ((glil (unparse-glil | |
49 | (compile (parse-tree-il exp) | |
50 | #:from 'tree-il #:to 'glil)))) | |
51 | (pmatch glil | |
52 | (pat (guard test ...) #t) | |
53 | (else #f)))))))) | |
54 | ||
55 | ||
56 | (with-test-prefix "void" | |
57 | (assert-tree-il->glil | |
58 | (void) | |
59 | (program 0 0 0 0 () (void) (call return 1))) | |
60 | (assert-tree-il->glil | |
61 | (begin (void) (const 1)) | |
62 | (program 0 0 0 0 () (const 1) (call return 1))) | |
63 | (assert-tree-il->glil | |
64 | (apply (primitive +) (void) (const 1)) | |
65 | (program 0 0 0 0 () (void) (const 1) (call add 2) (call return 1)))) | |
66 | ||
67 | (with-test-prefix "application" | |
68 | (assert-tree-il->glil | |
69 | (apply (toplevel foo) (const 1)) | |
70 | (program 0 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1))) | |
30a5e062 | 71 | (assert-tree-il->glil/pmatch |
ce09ee19 | 72 | (begin (apply (toplevel foo) (const 1)) (void)) |
30a5e062 AW |
73 | (program 0 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1) |
74 | (const 1) (label ,l2) (mv-bind () #f) (unbind) | |
75 | (void) (call return 1)) | |
76 | (eq? l1 l2)) | |
ce09ee19 AW |
77 | (assert-tree-il->glil |
78 | (apply (toplevel foo) (apply (toplevel bar))) | |
79 | (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0) | |
80 | (call goto/args 1)))) | |
81 | ||
82 | (with-test-prefix "conditional" | |
83 | (assert-tree-il->glil/pmatch | |
84 | (if (const #t) (const 1) (const 2)) | |
85 | (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) | |
86 | (const 1) (call return 1) | |
87 | (label ,l2) (const 2) (call return 1)) | |
88 | (eq? l1 l2)) | |
89 | ||
90 | (assert-tree-il->glil/pmatch | |
91 | (begin (if (const #t) (const 1) (const 2)) (const #f)) | |
92 | (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2) | |
93 | (label ,l3) (label ,l4) (const #f) (call return 1)) | |
94 | (eq? l1 l3) (eq? l2 l4)) | |
95 | ||
96 | (assert-tree-il->glil/pmatch | |
97 | (apply (primitive null?) (if (const #t) (const 1) (const 2))) | |
98 | (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) | |
99 | (const 1) (branch br ,l2) | |
100 | (label ,l3) (const 2) (label ,l4) | |
101 | (call null? 1) (call return 1)) | |
102 | (eq? l1 l3) (eq? l2 l4))) | |
103 | ||
104 | (with-test-prefix "primitive-ref" | |
105 | (assert-tree-il->glil | |
106 | (primitive +) | |
a1a482e0 | 107 | (program 0 0 0 0 () (toplevel ref +) (call return 1))) |
ce09ee19 AW |
108 | |
109 | (assert-tree-il->glil | |
110 | (begin (primitive +) (const #f)) | |
111 | (program 0 0 0 0 () (const #f) (call return 1))) | |
112 | ||
113 | (assert-tree-il->glil | |
114 | (apply (primitive null?) (primitive +)) | |
a1a482e0 | 115 | (program 0 0 0 0 () (toplevel ref +) (call null? 1) |
ce09ee19 AW |
116 | (call return 1)))) |
117 | ||
118 | (with-test-prefix "lexical refs" | |
119 | (assert-tree-il->glil | |
120 | (let (x) (y) ((const 1)) (lexical x y)) | |
121 | (program 0 0 1 0 () | |
122 | (const 1) (bind (x local 0)) (local set 0) | |
123 | (local ref 0) (call return 1) | |
124 | (unbind))) | |
125 | ||
126 | (assert-tree-il->glil | |
127 | (let (x) (y) ((const 1)) (begin (lexical x y) (const #f))) | |
128 | (program 0 0 1 0 () | |
129 | (const 1) (bind (x local 0)) (local set 0) | |
130 | (const #f) (call return 1) | |
131 | (unbind))) | |
132 | ||
133 | (assert-tree-il->glil | |
134 | (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y))) | |
135 | (program 0 0 1 0 () | |
136 | (const 1) (bind (x local 0)) (local set 0) | |
137 | (local ref 0) (call null? 1) (call return 1) | |
138 | (unbind)))) | |
139 | ||
140 | (with-test-prefix "lexical sets" | |
141 | (assert-tree-il->glil | |
142 | (let (x) (y) ((const 1)) (set! (lexical x y) (const 2))) | |
143 | (program 0 0 0 1 () | |
144 | (const 1) (bind (x external 0)) (external set 0 0) | |
145 | (const 2) (external set 0 0) (void) (call return 1) | |
146 | (unbind))) | |
147 | ||
148 | (assert-tree-il->glil | |
149 | (let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f))) | |
150 | (program 0 0 0 1 () | |
151 | (const 1) (bind (x external 0)) (external set 0 0) | |
152 | (const 2) (external set 0 0) (const #f) (call return 1) | |
153 | (unbind))) | |
154 | ||
155 | (assert-tree-il->glil | |
156 | (let (x) (y) ((const 1)) | |
157 | (apply (primitive null?) (set! (lexical x y) (const 2)))) | |
158 | (program 0 0 0 1 () | |
159 | (const 1) (bind (x external 0)) (external set 0 0) | |
160 | (const 2) (external set 0 0) (void) (call null? 1) (call return 1) | |
161 | (unbind)))) | |
162 | ||
163 | (with-test-prefix "module refs" | |
164 | (assert-tree-il->glil | |
165 | (@ (foo) bar) | |
166 | (program 0 0 0 0 () | |
167 | (module public ref (foo) bar) | |
168 | (call return 1))) | |
169 | ||
170 | (assert-tree-il->glil | |
171 | (begin (@ (foo) bar) (const #f)) | |
172 | (program 0 0 0 0 () | |
173 | (module public ref (foo) bar) (call drop 1) | |
174 | (const #f) (call return 1))) | |
175 | ||
176 | (assert-tree-il->glil | |
177 | (apply (primitive null?) (@ (foo) bar)) | |
178 | (program 0 0 0 0 () | |
179 | (module public ref (foo) bar) | |
180 | (call null? 1) (call return 1))) | |
181 | ||
182 | (assert-tree-il->glil | |
183 | (@@ (foo) bar) | |
184 | (program 0 0 0 0 () | |
185 | (module private ref (foo) bar) | |
186 | (call return 1))) | |
187 | ||
188 | (assert-tree-il->glil | |
189 | (begin (@@ (foo) bar) (const #f)) | |
190 | (program 0 0 0 0 () | |
191 | (module private ref (foo) bar) (call drop 1) | |
192 | (const #f) (call return 1))) | |
193 | ||
194 | (assert-tree-il->glil | |
195 | (apply (primitive null?) (@@ (foo) bar)) | |
196 | (program 0 0 0 0 () | |
197 | (module private ref (foo) bar) | |
198 | (call null? 1) (call return 1)))) | |
199 | ||
200 | (with-test-prefix "module sets" | |
201 | (assert-tree-il->glil | |
202 | (set! (@ (foo) bar) (const 2)) | |
203 | (program 0 0 0 0 () | |
204 | (const 2) (module public set (foo) bar) | |
205 | (void) (call return 1))) | |
206 | ||
207 | (assert-tree-il->glil | |
208 | (begin (set! (@ (foo) bar) (const 2)) (const #f)) | |
209 | (program 0 0 0 0 () | |
210 | (const 2) (module public set (foo) bar) | |
211 | (const #f) (call return 1))) | |
212 | ||
213 | (assert-tree-il->glil | |
214 | (apply (primitive null?) (set! (@ (foo) bar) (const 2))) | |
215 | (program 0 0 0 0 () | |
216 | (const 2) (module public set (foo) bar) | |
217 | (void) (call null? 1) (call return 1))) | |
218 | ||
219 | (assert-tree-il->glil | |
220 | (set! (@@ (foo) bar) (const 2)) | |
221 | (program 0 0 0 0 () | |
222 | (const 2) (module private set (foo) bar) | |
223 | (void) (call return 1))) | |
224 | ||
225 | (assert-tree-il->glil | |
226 | (begin (set! (@@ (foo) bar) (const 2)) (const #f)) | |
227 | (program 0 0 0 0 () | |
228 | (const 2) (module private set (foo) bar) | |
229 | (const #f) (call return 1))) | |
230 | ||
231 | (assert-tree-il->glil | |
232 | (apply (primitive null?) (set! (@@ (foo) bar) (const 2))) | |
233 | (program 0 0 0 0 () | |
234 | (const 2) (module private set (foo) bar) | |
235 | (void) (call null? 1) (call return 1)))) | |
236 | ||
237 | (with-test-prefix "toplevel refs" | |
238 | (assert-tree-il->glil | |
239 | (toplevel bar) | |
240 | (program 0 0 0 0 () | |
241 | (toplevel ref bar) | |
242 | (call return 1))) | |
243 | ||
244 | (assert-tree-il->glil | |
245 | (begin (toplevel bar) (const #f)) | |
246 | (program 0 0 0 0 () | |
247 | (toplevel ref bar) (call drop 1) | |
248 | (const #f) (call return 1))) | |
249 | ||
250 | (assert-tree-il->glil | |
251 | (apply (primitive null?) (toplevel bar)) | |
252 | (program 0 0 0 0 () | |
253 | (toplevel ref bar) | |
254 | (call null? 1) (call return 1)))) | |
255 | ||
256 | (with-test-prefix "toplevel sets" | |
257 | (assert-tree-il->glil | |
258 | (set! (toplevel bar) (const 2)) | |
259 | (program 0 0 0 0 () | |
260 | (const 2) (toplevel set bar) | |
261 | (void) (call return 1))) | |
262 | ||
263 | (assert-tree-il->glil | |
264 | (begin (set! (toplevel bar) (const 2)) (const #f)) | |
265 | (program 0 0 0 0 () | |
266 | (const 2) (toplevel set bar) | |
267 | (const #f) (call return 1))) | |
268 | ||
269 | (assert-tree-il->glil | |
270 | (apply (primitive null?) (set! (toplevel bar) (const 2))) | |
271 | (program 0 0 0 0 () | |
272 | (const 2) (toplevel set bar) | |
273 | (void) (call null? 1) (call return 1)))) | |
274 | ||
275 | (with-test-prefix "toplevel defines" | |
276 | (assert-tree-il->glil | |
277 | (define bar (const 2)) | |
278 | (program 0 0 0 0 () | |
279 | (const 2) (toplevel define bar) | |
280 | (void) (call return 1))) | |
281 | ||
282 | (assert-tree-il->glil | |
283 | (begin (define bar (const 2)) (const #f)) | |
284 | (program 0 0 0 0 () | |
285 | (const 2) (toplevel define bar) | |
286 | (const #f) (call return 1))) | |
287 | ||
288 | (assert-tree-il->glil | |
289 | (apply (primitive null?) (define bar (const 2))) | |
290 | (program 0 0 0 0 () | |
291 | (const 2) (toplevel define bar) | |
292 | (void) (call null? 1) (call return 1)))) | |
293 | ||
294 | (with-test-prefix "constants" | |
295 | (assert-tree-il->glil | |
296 | (const 2) | |
297 | (program 0 0 0 0 () | |
298 | (const 2) (call return 1))) | |
299 | ||
300 | (assert-tree-il->glil | |
301 | (begin (const 2) (const #f)) | |
302 | (program 0 0 0 0 () | |
303 | (const #f) (call return 1))) | |
304 | ||
305 | (assert-tree-il->glil | |
306 | (apply (primitive null?) (const 2)) | |
307 | (program 0 0 0 0 () | |
308 | (const 2) (call null? 1) (call return 1)))) | |
309 | ||
310 | (with-test-prefix "lambda" | |
311 | (assert-tree-il->glil | |
312 | (lambda (x) (y) () (const 2)) | |
313 | (program 0 0 0 0 () | |
a1a482e0 | 314 | (program 1 0 0 0 () |
ce09ee19 AW |
315 | (bind (x local 0)) |
316 | (const 2) (call return 1)) | |
317 | (call return 1))) | |
318 | ||
319 | (assert-tree-il->glil | |
320 | (lambda (x x1) (y y1) () (const 2)) | |
321 | (program 0 0 0 0 () | |
a1a482e0 | 322 | (program 2 0 0 0 () |
ce09ee19 AW |
323 | (bind (x local 0) (x1 local 1)) |
324 | (const 2) (call return 1)) | |
325 | (call return 1))) | |
326 | ||
327 | (assert-tree-il->glil | |
328 | (lambda x y () (const 2)) | |
329 | (program 0 0 0 0 () | |
a1a482e0 | 330 | (program 1 1 0 0 () |
ce09ee19 AW |
331 | (bind (x local 0)) |
332 | (const 2) (call return 1)) | |
333 | (call return 1))) | |
334 | ||
335 | (assert-tree-il->glil | |
336 | (lambda (x . x1) (y . y1) () (const 2)) | |
337 | (program 0 0 0 0 () | |
a1a482e0 | 338 | (program 2 1 0 0 () |
ce09ee19 AW |
339 | (bind (x local 0) (x1 local 1)) |
340 | (const 2) (call return 1)) | |
341 | (call return 1))) | |
342 | ||
343 | (assert-tree-il->glil | |
344 | (lambda (x . x1) (y . y1) () (lexical x y)) | |
345 | (program 0 0 0 0 () | |
a1a482e0 | 346 | (program 2 1 0 0 () |
ce09ee19 AW |
347 | (bind (x local 0) (x1 local 1)) |
348 | (local ref 0) (call return 1)) | |
349 | (call return 1))) | |
350 | ||
351 | (assert-tree-il->glil | |
352 | (lambda (x . x1) (y . y1) () (lexical x1 y1)) | |
353 | (program 0 0 0 0 () | |
a1a482e0 | 354 | (program 2 1 0 0 () |
ce09ee19 AW |
355 | (bind (x local 0) (x1 local 1)) |
356 | (local ref 1) (call return 1)) | |
a1a482e0 AW |
357 | (call return 1))) |
358 | ||
359 | (assert-tree-il->glil | |
360 | (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1))) | |
361 | (program 0 0 0 0 () | |
362 | (program 1 0 0 1 () | |
363 | (bind (x external 0)) | |
364 | (local ref 0) (external set 0 0) | |
365 | (program 1 0 0 0 () | |
366 | (bind (y local 0)) | |
367 | (external ref 1 0) (call return 1)) | |
368 | (call return 1)) | |
ce09ee19 AW |
369 | (call return 1)))) |
370 | ||
371 | (with-test-prefix "sequence" | |
372 | (assert-tree-il->glil | |
373 | (begin (begin (const 2) (const #f)) (const #t)) | |
374 | (program 0 0 0 0 () | |
375 | (const #t) (call return 1))) | |
376 | ||
377 | (assert-tree-il->glil | |
378 | (apply (primitive null?) (begin (const #f) (const 2))) | |
379 | (program 0 0 0 0 () | |
380 | (const 2) (call null? 1) (call return 1)))) | |
5af166bd AW |
381 | |
382 | ;; FIXME: binding info for or-hacked locals might bork the disassembler, | |
383 | ;; and could be tightened in any case | |
384 | (with-test-prefix "the or hack" | |
385 | (assert-tree-il->glil/pmatch | |
386 | (let (x) (y) ((const 1)) | |
387 | (if (lexical x y) | |
388 | (lexical x y) | |
389 | (let (a) (b) ((const 2)) | |
390 | (lexical a b)))) | |
391 | (program 0 0 1 0 () | |
392 | (const 1) (bind (x local 0)) (local set 0) | |
393 | (local ref 0) (branch br-if-not ,l1) | |
394 | (local ref 0) (call return 1) | |
395 | (label ,l2) | |
396 | (const 2) (bind (a local 0)) (local set 0) | |
397 | (local ref 0) (call return 1) | |
398 | (unbind) | |
399 | (unbind)) | |
400 | (eq? l1 l2)) | |
401 | ||
402 | (assert-tree-il->glil/pmatch | |
403 | (let (x) (y) ((const 1)) | |
404 | (if (lexical x y) | |
405 | (lexical x y) | |
406 | (let (a) (b) ((const 2)) | |
407 | (lexical x y)))) | |
408 | (program 0 0 2 0 () | |
409 | (const 1) (bind (x local 0)) (local set 0) | |
410 | (local ref 0) (branch br-if-not ,l1) | |
411 | (local ref 0) (call return 1) | |
412 | (label ,l2) | |
413 | (const 2) (bind (a local 1)) (local set 1) | |
414 | (local ref 0) (call return 1) | |
415 | (unbind) | |
416 | (unbind)) | |
417 | (eq? l1 l2))) |