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))) | |
71 | (assert-tree-il->glil | |
72 | (begin (apply (toplevel foo) (const 1)) (void)) | |
73 | (program 0 0 0 0 () (toplevel ref foo) (const 1) (call call 1) | |
74 | (call drop 1) (void) (call return 1))) | |
75 | (assert-tree-il->glil | |
76 | (apply (toplevel foo) (apply (toplevel bar))) | |
77 | (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0) | |
78 | (call goto/args 1)))) | |
79 | ||
80 | (with-test-prefix "conditional" | |
81 | (assert-tree-il->glil/pmatch | |
82 | (if (const #t) (const 1) (const 2)) | |
83 | (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) | |
84 | (const 1) (call return 1) | |
85 | (label ,l2) (const 2) (call return 1)) | |
86 | (eq? l1 l2)) | |
87 | ||
88 | (assert-tree-il->glil/pmatch | |
89 | (begin (if (const #t) (const 1) (const 2)) (const #f)) | |
90 | (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2) | |
91 | (label ,l3) (label ,l4) (const #f) (call return 1)) | |
92 | (eq? l1 l3) (eq? l2 l4)) | |
93 | ||
94 | (assert-tree-il->glil/pmatch | |
95 | (apply (primitive null?) (if (const #t) (const 1) (const 2))) | |
96 | (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) | |
97 | (const 1) (branch br ,l2) | |
98 | (label ,l3) (const 2) (label ,l4) | |
99 | (call null? 1) (call return 1)) | |
100 | (eq? l1 l3) (eq? l2 l4))) | |
101 | ||
102 | (with-test-prefix "primitive-ref" | |
103 | (assert-tree-il->glil | |
104 | (primitive +) | |
a1a482e0 | 105 | (program 0 0 0 0 () (toplevel ref +) (call return 1))) |
ce09ee19 AW |
106 | |
107 | (assert-tree-il->glil | |
108 | (begin (primitive +) (const #f)) | |
109 | (program 0 0 0 0 () (const #f) (call return 1))) | |
110 | ||
111 | (assert-tree-il->glil | |
112 | (apply (primitive null?) (primitive +)) | |
a1a482e0 | 113 | (program 0 0 0 0 () (toplevel ref +) (call null? 1) |
ce09ee19 AW |
114 | (call return 1)))) |
115 | ||
116 | (with-test-prefix "lexical refs" | |
117 | (assert-tree-il->glil | |
118 | (let (x) (y) ((const 1)) (lexical x y)) | |
119 | (program 0 0 1 0 () | |
120 | (const 1) (bind (x local 0)) (local set 0) | |
121 | (local ref 0) (call return 1) | |
122 | (unbind))) | |
123 | ||
124 | (assert-tree-il->glil | |
125 | (let (x) (y) ((const 1)) (begin (lexical x y) (const #f))) | |
126 | (program 0 0 1 0 () | |
127 | (const 1) (bind (x local 0)) (local set 0) | |
128 | (const #f) (call return 1) | |
129 | (unbind))) | |
130 | ||
131 | (assert-tree-il->glil | |
132 | (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y))) | |
133 | (program 0 0 1 0 () | |
134 | (const 1) (bind (x local 0)) (local set 0) | |
135 | (local ref 0) (call null? 1) (call return 1) | |
136 | (unbind)))) | |
137 | ||
138 | (with-test-prefix "lexical sets" | |
139 | (assert-tree-il->glil | |
140 | (let (x) (y) ((const 1)) (set! (lexical x y) (const 2))) | |
141 | (program 0 0 0 1 () | |
142 | (const 1) (bind (x external 0)) (external set 0 0) | |
143 | (const 2) (external set 0 0) (void) (call return 1) | |
144 | (unbind))) | |
145 | ||
146 | (assert-tree-il->glil | |
147 | (let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f))) | |
148 | (program 0 0 0 1 () | |
149 | (const 1) (bind (x external 0)) (external set 0 0) | |
150 | (const 2) (external set 0 0) (const #f) (call return 1) | |
151 | (unbind))) | |
152 | ||
153 | (assert-tree-il->glil | |
154 | (let (x) (y) ((const 1)) | |
155 | (apply (primitive null?) (set! (lexical x y) (const 2)))) | |
156 | (program 0 0 0 1 () | |
157 | (const 1) (bind (x external 0)) (external set 0 0) | |
158 | (const 2) (external set 0 0) (void) (call null? 1) (call return 1) | |
159 | (unbind)))) | |
160 | ||
161 | (with-test-prefix "module refs" | |
162 | (assert-tree-il->glil | |
163 | (@ (foo) bar) | |
164 | (program 0 0 0 0 () | |
165 | (module public ref (foo) bar) | |
166 | (call return 1))) | |
167 | ||
168 | (assert-tree-il->glil | |
169 | (begin (@ (foo) bar) (const #f)) | |
170 | (program 0 0 0 0 () | |
171 | (module public ref (foo) bar) (call drop 1) | |
172 | (const #f) (call return 1))) | |
173 | ||
174 | (assert-tree-il->glil | |
175 | (apply (primitive null?) (@ (foo) bar)) | |
176 | (program 0 0 0 0 () | |
177 | (module public ref (foo) bar) | |
178 | (call null? 1) (call return 1))) | |
179 | ||
180 | (assert-tree-il->glil | |
181 | (@@ (foo) bar) | |
182 | (program 0 0 0 0 () | |
183 | (module private ref (foo) bar) | |
184 | (call return 1))) | |
185 | ||
186 | (assert-tree-il->glil | |
187 | (begin (@@ (foo) bar) (const #f)) | |
188 | (program 0 0 0 0 () | |
189 | (module private ref (foo) bar) (call drop 1) | |
190 | (const #f) (call return 1))) | |
191 | ||
192 | (assert-tree-il->glil | |
193 | (apply (primitive null?) (@@ (foo) bar)) | |
194 | (program 0 0 0 0 () | |
195 | (module private ref (foo) bar) | |
196 | (call null? 1) (call return 1)))) | |
197 | ||
198 | (with-test-prefix "module sets" | |
199 | (assert-tree-il->glil | |
200 | (set! (@ (foo) bar) (const 2)) | |
201 | (program 0 0 0 0 () | |
202 | (const 2) (module public set (foo) bar) | |
203 | (void) (call return 1))) | |
204 | ||
205 | (assert-tree-il->glil | |
206 | (begin (set! (@ (foo) bar) (const 2)) (const #f)) | |
207 | (program 0 0 0 0 () | |
208 | (const 2) (module public set (foo) bar) | |
209 | (const #f) (call return 1))) | |
210 | ||
211 | (assert-tree-il->glil | |
212 | (apply (primitive null?) (set! (@ (foo) bar) (const 2))) | |
213 | (program 0 0 0 0 () | |
214 | (const 2) (module public set (foo) bar) | |
215 | (void) (call null? 1) (call return 1))) | |
216 | ||
217 | (assert-tree-il->glil | |
218 | (set! (@@ (foo) bar) (const 2)) | |
219 | (program 0 0 0 0 () | |
220 | (const 2) (module private set (foo) bar) | |
221 | (void) (call return 1))) | |
222 | ||
223 | (assert-tree-il->glil | |
224 | (begin (set! (@@ (foo) bar) (const 2)) (const #f)) | |
225 | (program 0 0 0 0 () | |
226 | (const 2) (module private set (foo) bar) | |
227 | (const #f) (call return 1))) | |
228 | ||
229 | (assert-tree-il->glil | |
230 | (apply (primitive null?) (set! (@@ (foo) bar) (const 2))) | |
231 | (program 0 0 0 0 () | |
232 | (const 2) (module private set (foo) bar) | |
233 | (void) (call null? 1) (call return 1)))) | |
234 | ||
235 | (with-test-prefix "toplevel refs" | |
236 | (assert-tree-il->glil | |
237 | (toplevel bar) | |
238 | (program 0 0 0 0 () | |
239 | (toplevel ref bar) | |
240 | (call return 1))) | |
241 | ||
242 | (assert-tree-il->glil | |
243 | (begin (toplevel bar) (const #f)) | |
244 | (program 0 0 0 0 () | |
245 | (toplevel ref bar) (call drop 1) | |
246 | (const #f) (call return 1))) | |
247 | ||
248 | (assert-tree-il->glil | |
249 | (apply (primitive null?) (toplevel bar)) | |
250 | (program 0 0 0 0 () | |
251 | (toplevel ref bar) | |
252 | (call null? 1) (call return 1)))) | |
253 | ||
254 | (with-test-prefix "toplevel sets" | |
255 | (assert-tree-il->glil | |
256 | (set! (toplevel bar) (const 2)) | |
257 | (program 0 0 0 0 () | |
258 | (const 2) (toplevel set bar) | |
259 | (void) (call return 1))) | |
260 | ||
261 | (assert-tree-il->glil | |
262 | (begin (set! (toplevel bar) (const 2)) (const #f)) | |
263 | (program 0 0 0 0 () | |
264 | (const 2) (toplevel set bar) | |
265 | (const #f) (call return 1))) | |
266 | ||
267 | (assert-tree-il->glil | |
268 | (apply (primitive null?) (set! (toplevel bar) (const 2))) | |
269 | (program 0 0 0 0 () | |
270 | (const 2) (toplevel set bar) | |
271 | (void) (call null? 1) (call return 1)))) | |
272 | ||
273 | (with-test-prefix "toplevel defines" | |
274 | (assert-tree-il->glil | |
275 | (define bar (const 2)) | |
276 | (program 0 0 0 0 () | |
277 | (const 2) (toplevel define bar) | |
278 | (void) (call return 1))) | |
279 | ||
280 | (assert-tree-il->glil | |
281 | (begin (define bar (const 2)) (const #f)) | |
282 | (program 0 0 0 0 () | |
283 | (const 2) (toplevel define bar) | |
284 | (const #f) (call return 1))) | |
285 | ||
286 | (assert-tree-il->glil | |
287 | (apply (primitive null?) (define bar (const 2))) | |
288 | (program 0 0 0 0 () | |
289 | (const 2) (toplevel define bar) | |
290 | (void) (call null? 1) (call return 1)))) | |
291 | ||
292 | (with-test-prefix "constants" | |
293 | (assert-tree-il->glil | |
294 | (const 2) | |
295 | (program 0 0 0 0 () | |
296 | (const 2) (call return 1))) | |
297 | ||
298 | (assert-tree-il->glil | |
299 | (begin (const 2) (const #f)) | |
300 | (program 0 0 0 0 () | |
301 | (const #f) (call return 1))) | |
302 | ||
303 | (assert-tree-il->glil | |
304 | (apply (primitive null?) (const 2)) | |
305 | (program 0 0 0 0 () | |
306 | (const 2) (call null? 1) (call return 1)))) | |
307 | ||
308 | (with-test-prefix "lambda" | |
309 | (assert-tree-il->glil | |
310 | (lambda (x) (y) () (const 2)) | |
311 | (program 0 0 0 0 () | |
a1a482e0 | 312 | (program 1 0 0 0 () |
ce09ee19 AW |
313 | (bind (x local 0)) |
314 | (const 2) (call return 1)) | |
315 | (call return 1))) | |
316 | ||
317 | (assert-tree-il->glil | |
318 | (lambda (x x1) (y y1) () (const 2)) | |
319 | (program 0 0 0 0 () | |
a1a482e0 | 320 | (program 2 0 0 0 () |
ce09ee19 AW |
321 | (bind (x local 0) (x1 local 1)) |
322 | (const 2) (call return 1)) | |
323 | (call return 1))) | |
324 | ||
325 | (assert-tree-il->glil | |
326 | (lambda x y () (const 2)) | |
327 | (program 0 0 0 0 () | |
a1a482e0 | 328 | (program 1 1 0 0 () |
ce09ee19 AW |
329 | (bind (x local 0)) |
330 | (const 2) (call return 1)) | |
331 | (call return 1))) | |
332 | ||
333 | (assert-tree-il->glil | |
334 | (lambda (x . x1) (y . y1) () (const 2)) | |
335 | (program 0 0 0 0 () | |
a1a482e0 | 336 | (program 2 1 0 0 () |
ce09ee19 AW |
337 | (bind (x local 0) (x1 local 1)) |
338 | (const 2) (call return 1)) | |
339 | (call return 1))) | |
340 | ||
341 | (assert-tree-il->glil | |
342 | (lambda (x . x1) (y . y1) () (lexical x y)) | |
343 | (program 0 0 0 0 () | |
a1a482e0 | 344 | (program 2 1 0 0 () |
ce09ee19 AW |
345 | (bind (x local 0) (x1 local 1)) |
346 | (local ref 0) (call return 1)) | |
347 | (call return 1))) | |
348 | ||
349 | (assert-tree-il->glil | |
350 | (lambda (x . x1) (y . y1) () (lexical x1 y1)) | |
351 | (program 0 0 0 0 () | |
a1a482e0 | 352 | (program 2 1 0 0 () |
ce09ee19 AW |
353 | (bind (x local 0) (x1 local 1)) |
354 | (local ref 1) (call return 1)) | |
a1a482e0 AW |
355 | (call return 1))) |
356 | ||
357 | (assert-tree-il->glil | |
358 | (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1))) | |
359 | (program 0 0 0 0 () | |
360 | (program 1 0 0 1 () | |
361 | (bind (x external 0)) | |
362 | (local ref 0) (external set 0 0) | |
363 | (program 1 0 0 0 () | |
364 | (bind (y local 0)) | |
365 | (external ref 1 0) (call return 1)) | |
366 | (call return 1)) | |
ce09ee19 AW |
367 | (call return 1)))) |
368 | ||
369 | (with-test-prefix "sequence" | |
370 | (assert-tree-il->glil | |
371 | (begin (begin (const 2) (const #f)) (const #t)) | |
372 | (program 0 0 0 0 () | |
373 | (const #t) (call return 1))) | |
374 | ||
375 | (assert-tree-il->glil | |
376 | (apply (primitive null?) (begin (const #f) (const 2))) | |
377 | (program 0 0 0 0 () | |
378 | (const 2) (call null? 1) (call return 1)))) | |
5af166bd AW |
379 | |
380 | ;; FIXME: binding info for or-hacked locals might bork the disassembler, | |
381 | ;; and could be tightened in any case | |
382 | (with-test-prefix "the or hack" | |
383 | (assert-tree-il->glil/pmatch | |
384 | (let (x) (y) ((const 1)) | |
385 | (if (lexical x y) | |
386 | (lexical x y) | |
387 | (let (a) (b) ((const 2)) | |
388 | (lexical a b)))) | |
389 | (program 0 0 1 0 () | |
390 | (const 1) (bind (x local 0)) (local set 0) | |
391 | (local ref 0) (branch br-if-not ,l1) | |
392 | (local ref 0) (call return 1) | |
393 | (label ,l2) | |
394 | (const 2) (bind (a local 0)) (local set 0) | |
395 | (local ref 0) (call return 1) | |
396 | (unbind) | |
397 | (unbind)) | |
398 | (eq? l1 l2)) | |
399 | ||
400 | (assert-tree-il->glil/pmatch | |
401 | (let (x) (y) ((const 1)) | |
402 | (if (lexical x y) | |
403 | (lexical x y) | |
404 | (let (a) (b) ((const 2)) | |
405 | (lexical x y)))) | |
406 | (program 0 0 2 0 () | |
407 | (const 1) (bind (x local 0)) (local set 0) | |
408 | (local ref 0) (branch br-if-not ,l1) | |
409 | (local ref 0) (call return 1) | |
410 | (label ,l2) | |
411 | (const 2) (bind (a local 1)) (local set 1) | |
412 | (local ref 0) (call return 1) | |
413 | (unbind) | |
414 | (unbind)) | |
415 | (eq? l1 l2))) |