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 | |
53befeb7 NJ |
9 | ;;;; version 3 of the License, or (at your option) any later version. |
10 | ;;;; | |
ce09ee19 AW |
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. | |
53befeb7 | 15 | ;;;; |
ce09ee19 AW |
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) | |
4b856371 | 24 | #:use-module (system base message) |
ce09ee19 | 25 | #:use-module (language tree-il) |
4b856371 LC |
26 | #:use-module (language glil) |
27 | #:use-module (srfi srfi-13)) | |
ce09ee19 | 28 | |
f67ddf9d LC |
29 | (define read-and-compile |
30 | (@@ (system base compile) read-and-compile)) | |
31 | ||
e0c90f90 AW |
32 | ;; Of course, the GLIL that is emitted depends on the source info of the |
33 | ;; input. Here we're not concerned about that, so we strip source | |
34 | ;; information from the incoming tree-il. | |
35 | ||
36 | (define (strip-source x) | |
37 | (post-order! (lambda (x) (set! (tree-il-src x) #f)) | |
38 | x)) | |
39 | ||
ce09ee19 AW |
40 | (define-syntax assert-scheme->glil |
41 | (syntax-rules () | |
42 | ((_ in out) | |
e0c90f90 AW |
43 | (let ((tree-il (strip-source |
44 | (compile 'in #:from 'scheme #:to 'tree-il)))) | |
ce09ee19 AW |
45 | (pass-if 'in |
46 | (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil)) | |
47 | 'out)))))) | |
48 | ||
49 | (define-syntax assert-tree-il->glil | |
50 | (syntax-rules () | |
51 | ((_ in out) | |
52 | (pass-if 'in | |
e0c90f90 | 53 | (let ((tree-il (strip-source (parse-tree-il 'in)))) |
ce09ee19 AW |
54 | (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil)) |
55 | 'out)))))) | |
56 | ||
57 | (define-syntax assert-tree-il->glil/pmatch | |
58 | (syntax-rules () | |
59 | ((_ in pat test ...) | |
60 | (let ((exp 'in)) | |
61 | (pass-if 'in | |
62 | (let ((glil (unparse-glil | |
e0c90f90 | 63 | (compile (strip-source (parse-tree-il exp)) |
ce09ee19 AW |
64 | #:from 'tree-il #:to 'glil)))) |
65 | (pmatch glil | |
66 | (pat (guard test ...) #t) | |
67 | (else #f)))))))) | |
68 | ||
ce09ee19 AW |
69 | (with-test-prefix "void" |
70 | (assert-tree-il->glil | |
71 | (void) | |
56164a5a | 72 | (program () (arity 0 0 #f) (void) (call return 1))) |
ce09ee19 AW |
73 | (assert-tree-il->glil |
74 | (begin (void) (const 1)) | |
56164a5a | 75 | (program () (arity 0 0 #f) (const 1) (call return 1))) |
ce09ee19 AW |
76 | (assert-tree-il->glil |
77 | (apply (primitive +) (void) (const 1)) | |
56164a5a | 78 | (program () (arity 0 0 #f) (void) (call add1 1) (call return 1)))) |
ce09ee19 AW |
79 | |
80 | (with-test-prefix "application" | |
81 | (assert-tree-il->glil | |
82 | (apply (toplevel foo) (const 1)) | |
56164a5a | 83 | (program () (arity 0 0 #f) (toplevel ref foo) (const 1) (call goto/args 1))) |
30a5e062 | 84 | (assert-tree-il->glil/pmatch |
ce09ee19 | 85 | (begin (apply (toplevel foo) (const 1)) (void)) |
56164a5a | 86 | (program () (arity 0 0 #f) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1) |
0f423f20 AW |
87 | (call drop 1) (branch br ,l2) |
88 | (label ,l3) (mv-bind () #f) (unbind) | |
89 | (label ,l4) | |
30a5e062 | 90 | (void) (call return 1)) |
0f423f20 | 91 | (and (eq? l1 l3) (eq? l2 l4))) |
ce09ee19 AW |
92 | (assert-tree-il->glil |
93 | (apply (toplevel foo) (apply (toplevel bar))) | |
56164a5a | 94 | (program () (arity 0 0 #f)(toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0) |
ce09ee19 AW |
95 | (call goto/args 1)))) |
96 | ||
97 | (with-test-prefix "conditional" | |
98 | (assert-tree-il->glil/pmatch | |
99 | (if (const #t) (const 1) (const 2)) | |
56164a5a | 100 | (program () (arity 0 0 #f) (const #t) (branch br-if-not ,l1) |
ce09ee19 AW |
101 | (const 1) (call return 1) |
102 | (label ,l2) (const 2) (call return 1)) | |
103 | (eq? l1 l2)) | |
104 | ||
105 | (assert-tree-il->glil/pmatch | |
106 | (begin (if (const #t) (const 1) (const 2)) (const #f)) | |
56164a5a | 107 | (program () (arity 0 0 #f) (const #t) (branch br-if-not ,l1) (branch br ,l2) |
ce09ee19 AW |
108 | (label ,l3) (label ,l4) (const #f) (call return 1)) |
109 | (eq? l1 l3) (eq? l2 l4)) | |
110 | ||
111 | (assert-tree-il->glil/pmatch | |
112 | (apply (primitive null?) (if (const #t) (const 1) (const 2))) | |
56164a5a | 113 | (program () (arity 0 0 #f) (const #t) (branch br-if-not ,l1) |
ce09ee19 AW |
114 | (const 1) (branch br ,l2) |
115 | (label ,l3) (const 2) (label ,l4) | |
116 | (call null? 1) (call return 1)) | |
117 | (eq? l1 l3) (eq? l2 l4))) | |
118 | ||
119 | (with-test-prefix "primitive-ref" | |
120 | (assert-tree-il->glil | |
121 | (primitive +) | |
56164a5a | 122 | (program () (arity 0 0 #f) (toplevel ref +) (call return 1))) |
ce09ee19 AW |
123 | |
124 | (assert-tree-il->glil | |
125 | (begin (primitive +) (const #f)) | |
56164a5a | 126 | (program () (arity 0 0 #f) (const #f) (call return 1))) |
ce09ee19 AW |
127 | |
128 | (assert-tree-il->glil | |
129 | (apply (primitive null?) (primitive +)) | |
56164a5a | 130 | (program () (arity 0 0 #f) (toplevel ref +) (call null? 1) |
ce09ee19 AW |
131 | (call return 1)))) |
132 | ||
133 | (with-test-prefix "lexical refs" | |
134 | (assert-tree-il->glil | |
135 | (let (x) (y) ((const 1)) (lexical x y)) | |
56164a5a | 136 | (program () (arity 0 0 #f) (call reserve-locals 1) |
66d3e9a3 AW |
137 | (const 1) (bind (x #f 0)) (lexical #t #f set 0) |
138 | (lexical #t #f ref 0) (call return 1) | |
ce09ee19 AW |
139 | (unbind))) |
140 | ||
141 | (assert-tree-il->glil | |
142 | (let (x) (y) ((const 1)) (begin (lexical x y) (const #f))) | |
56164a5a | 143 | (program () (arity 0 0 #f) (call reserve-locals 1) |
66d3e9a3 | 144 | (const 1) (bind (x #f 0)) (lexical #t #f set 0) |
ce09ee19 AW |
145 | (const #f) (call return 1) |
146 | (unbind))) | |
147 | ||
148 | (assert-tree-il->glil | |
149 | (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y))) | |
56164a5a | 150 | (program () (arity 0 0 #f) (call reserve-locals 1) |
66d3e9a3 AW |
151 | (const 1) (bind (x #f 0)) (lexical #t #f set 0) |
152 | (lexical #t #f ref 0) (call null? 1) (call return 1) | |
ce09ee19 AW |
153 | (unbind)))) |
154 | ||
155 | (with-test-prefix "lexical sets" | |
156 | (assert-tree-il->glil | |
aaae0d5a AW |
157 | ;; unreferenced sets may be optimized away -- make sure they are ref'd |
158 | (let (x) (y) ((const 1)) | |
159 | (set! (lexical x y) (apply (primitive 1+) (lexical x y)))) | |
56164a5a | 160 | (program () (arity 0 0 #f) (call reserve-locals 1) |
66d3e9a3 | 161 | (const 1) (bind (x #t 0)) (lexical #t #t box 0) |
aaae0d5a AW |
162 | (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) |
163 | (void) (call return 1) | |
ce09ee19 AW |
164 | (unbind))) |
165 | ||
166 | (assert-tree-il->glil | |
aaae0d5a AW |
167 | (let (x) (y) ((const 1)) |
168 | (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y))) | |
169 | (lexical x y))) | |
56164a5a | 170 | (program () (arity 0 0 #f) (call reserve-locals 1) |
66d3e9a3 | 171 | (const 1) (bind (x #t 0)) (lexical #t #t box 0) |
aaae0d5a AW |
172 | (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) |
173 | (lexical #t #t ref 0) (call return 1) | |
ce09ee19 AW |
174 | (unbind))) |
175 | ||
176 | (assert-tree-il->glil | |
177 | (let (x) (y) ((const 1)) | |
aaae0d5a AW |
178 | (apply (primitive null?) |
179 | (set! (lexical x y) (apply (primitive 1+) (lexical x y))))) | |
56164a5a | 180 | (program () (arity 0 0 #f) (call reserve-locals 1) |
66d3e9a3 | 181 | (const 1) (bind (x #t 0)) (lexical #t #t box 0) |
aaae0d5a AW |
182 | (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void) |
183 | (call null? 1) (call return 1) | |
ce09ee19 AW |
184 | (unbind)))) |
185 | ||
186 | (with-test-prefix "module refs" | |
187 | (assert-tree-il->glil | |
188 | (@ (foo) bar) | |
56164a5a | 189 | (program () (arity 0 0 #f) |
ce09ee19 AW |
190 | (module public ref (foo) bar) |
191 | (call return 1))) | |
192 | ||
193 | (assert-tree-il->glil | |
194 | (begin (@ (foo) bar) (const #f)) | |
56164a5a | 195 | (program () (arity 0 0 #f) |
ce09ee19 AW |
196 | (module public ref (foo) bar) (call drop 1) |
197 | (const #f) (call return 1))) | |
198 | ||
199 | (assert-tree-il->glil | |
200 | (apply (primitive null?) (@ (foo) bar)) | |
56164a5a | 201 | (program () (arity 0 0 #f) |
ce09ee19 AW |
202 | (module public ref (foo) bar) |
203 | (call null? 1) (call return 1))) | |
204 | ||
205 | (assert-tree-il->glil | |
206 | (@@ (foo) bar) | |
56164a5a | 207 | (program () (arity 0 0 #f) |
ce09ee19 AW |
208 | (module private ref (foo) bar) |
209 | (call return 1))) | |
210 | ||
211 | (assert-tree-il->glil | |
212 | (begin (@@ (foo) bar) (const #f)) | |
56164a5a | 213 | (program () (arity 0 0 #f) |
ce09ee19 AW |
214 | (module private ref (foo) bar) (call drop 1) |
215 | (const #f) (call return 1))) | |
216 | ||
217 | (assert-tree-il->glil | |
218 | (apply (primitive null?) (@@ (foo) bar)) | |
56164a5a | 219 | (program () (arity 0 0 #f) |
ce09ee19 AW |
220 | (module private ref (foo) bar) |
221 | (call null? 1) (call return 1)))) | |
222 | ||
223 | (with-test-prefix "module sets" | |
224 | (assert-tree-il->glil | |
225 | (set! (@ (foo) bar) (const 2)) | |
56164a5a | 226 | (program () (arity 0 0 #f) |
ce09ee19 AW |
227 | (const 2) (module public set (foo) bar) |
228 | (void) (call return 1))) | |
229 | ||
230 | (assert-tree-il->glil | |
231 | (begin (set! (@ (foo) bar) (const 2)) (const #f)) | |
56164a5a | 232 | (program () (arity 0 0 #f) |
ce09ee19 AW |
233 | (const 2) (module public set (foo) bar) |
234 | (const #f) (call return 1))) | |
235 | ||
236 | (assert-tree-il->glil | |
237 | (apply (primitive null?) (set! (@ (foo) bar) (const 2))) | |
56164a5a | 238 | (program () (arity 0 0 #f) |
ce09ee19 AW |
239 | (const 2) (module public set (foo) bar) |
240 | (void) (call null? 1) (call return 1))) | |
241 | ||
242 | (assert-tree-il->glil | |
243 | (set! (@@ (foo) bar) (const 2)) | |
56164a5a | 244 | (program () (arity 0 0 #f) |
ce09ee19 AW |
245 | (const 2) (module private set (foo) bar) |
246 | (void) (call return 1))) | |
247 | ||
248 | (assert-tree-il->glil | |
249 | (begin (set! (@@ (foo) bar) (const 2)) (const #f)) | |
56164a5a | 250 | (program () (arity 0 0 #f) |
ce09ee19 AW |
251 | (const 2) (module private set (foo) bar) |
252 | (const #f) (call return 1))) | |
253 | ||
254 | (assert-tree-il->glil | |
255 | (apply (primitive null?) (set! (@@ (foo) bar) (const 2))) | |
56164a5a | 256 | (program () (arity 0 0 #f) |
ce09ee19 AW |
257 | (const 2) (module private set (foo) bar) |
258 | (void) (call null? 1) (call return 1)))) | |
259 | ||
260 | (with-test-prefix "toplevel refs" | |
261 | (assert-tree-il->glil | |
262 | (toplevel bar) | |
56164a5a | 263 | (program () (arity 0 0 #f) |
ce09ee19 AW |
264 | (toplevel ref bar) |
265 | (call return 1))) | |
266 | ||
267 | (assert-tree-il->glil | |
268 | (begin (toplevel bar) (const #f)) | |
56164a5a | 269 | (program () (arity 0 0 #f) |
ce09ee19 AW |
270 | (toplevel ref bar) (call drop 1) |
271 | (const #f) (call return 1))) | |
272 | ||
273 | (assert-tree-il->glil | |
274 | (apply (primitive null?) (toplevel bar)) | |
56164a5a | 275 | (program () (arity 0 0 #f) |
ce09ee19 AW |
276 | (toplevel ref bar) |
277 | (call null? 1) (call return 1)))) | |
278 | ||
279 | (with-test-prefix "toplevel sets" | |
280 | (assert-tree-il->glil | |
281 | (set! (toplevel bar) (const 2)) | |
56164a5a | 282 | (program () (arity 0 0 #f) |
ce09ee19 AW |
283 | (const 2) (toplevel set bar) |
284 | (void) (call return 1))) | |
285 | ||
286 | (assert-tree-il->glil | |
287 | (begin (set! (toplevel bar) (const 2)) (const #f)) | |
56164a5a | 288 | (program () (arity 0 0 #f) |
ce09ee19 AW |
289 | (const 2) (toplevel set bar) |
290 | (const #f) (call return 1))) | |
291 | ||
292 | (assert-tree-il->glil | |
293 | (apply (primitive null?) (set! (toplevel bar) (const 2))) | |
56164a5a | 294 | (program () (arity 0 0 #f) |
ce09ee19 AW |
295 | (const 2) (toplevel set bar) |
296 | (void) (call null? 1) (call return 1)))) | |
297 | ||
298 | (with-test-prefix "toplevel defines" | |
299 | (assert-tree-il->glil | |
300 | (define bar (const 2)) | |
56164a5a | 301 | (program () (arity 0 0 #f) |
ce09ee19 AW |
302 | (const 2) (toplevel define bar) |
303 | (void) (call return 1))) | |
304 | ||
305 | (assert-tree-il->glil | |
306 | (begin (define bar (const 2)) (const #f)) | |
56164a5a | 307 | (program () (arity 0 0 #f) |
ce09ee19 AW |
308 | (const 2) (toplevel define bar) |
309 | (const #f) (call return 1))) | |
310 | ||
311 | (assert-tree-il->glil | |
312 | (apply (primitive null?) (define bar (const 2))) | |
56164a5a | 313 | (program () (arity 0 0 #f) |
ce09ee19 AW |
314 | (const 2) (toplevel define bar) |
315 | (void) (call null? 1) (call return 1)))) | |
316 | ||
317 | (with-test-prefix "constants" | |
318 | (assert-tree-il->glil | |
319 | (const 2) | |
56164a5a | 320 | (program () (arity 0 0 #f) |
ce09ee19 AW |
321 | (const 2) (call return 1))) |
322 | ||
323 | (assert-tree-il->glil | |
324 | (begin (const 2) (const #f)) | |
56164a5a | 325 | (program () (arity 0 0 #f) |
ce09ee19 AW |
326 | (const #f) (call return 1))) |
327 | ||
328 | (assert-tree-il->glil | |
329 | (apply (primitive null?) (const 2)) | |
56164a5a | 330 | (program () (arity 0 0 #f) |
ce09ee19 AW |
331 | (const 2) (call null? 1) (call return 1)))) |
332 | ||
333 | (with-test-prefix "lambda" | |
334 | (assert-tree-il->glil | |
335 | (lambda (x) (y) () (const 2)) | |
56164a5a AW |
336 | (program () (arity 0 0 #f) |
337 | (program () (arity 1 0 #f) | |
66d3e9a3 | 338 | (bind (x #f 0)) |
ce09ee19 AW |
339 | (const 2) (call return 1)) |
340 | (call return 1))) | |
341 | ||
342 | (assert-tree-il->glil | |
343 | (lambda (x x1) (y y1) () (const 2)) | |
56164a5a AW |
344 | (program () (arity 0 0 #f) |
345 | (program () (arity 2 0 #f) | |
66d3e9a3 | 346 | (bind (x #f 0) (x1 #f 1)) |
ce09ee19 AW |
347 | (const 2) (call return 1)) |
348 | (call return 1))) | |
349 | ||
350 | (assert-tree-il->glil | |
351 | (lambda x y () (const 2)) | |
56164a5a AW |
352 | (program () (arity 0 0 #f) |
353 | (program () (arity 1 1 #f) | |
66d3e9a3 | 354 | (bind (x #f 0)) |
ce09ee19 AW |
355 | (const 2) (call return 1)) |
356 | (call return 1))) | |
357 | ||
358 | (assert-tree-il->glil | |
359 | (lambda (x . x1) (y . y1) () (const 2)) | |
56164a5a AW |
360 | (program () (arity 0 0 #f) |
361 | (program () (arity 2 1 #f) | |
66d3e9a3 | 362 | (bind (x #f 0) (x1 #f 1)) |
ce09ee19 AW |
363 | (const 2) (call return 1)) |
364 | (call return 1))) | |
365 | ||
366 | (assert-tree-il->glil | |
367 | (lambda (x . x1) (y . y1) () (lexical x y)) | |
56164a5a AW |
368 | (program () (arity 0 0 #f) |
369 | (program () (arity 2 1 #f) | |
66d3e9a3 AW |
370 | (bind (x #f 0) (x1 #f 1)) |
371 | (lexical #t #f ref 0) (call return 1)) | |
ce09ee19 AW |
372 | (call return 1))) |
373 | ||
374 | (assert-tree-il->glil | |
375 | (lambda (x . x1) (y . y1) () (lexical x1 y1)) | |
56164a5a AW |
376 | (program () (arity 0 0 #f) |
377 | (program () (arity 2 1 #f) | |
66d3e9a3 AW |
378 | (bind (x #f 0) (x1 #f 1)) |
379 | (lexical #t #f ref 1) (call return 1)) | |
a1a482e0 AW |
380 | (call return 1))) |
381 | ||
382 | (assert-tree-il->glil | |
383 | (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1))) | |
56164a5a AW |
384 | (program () (arity 0 0 #f) |
385 | (program () (arity 1 0 #f) | |
66d3e9a3 | 386 | (bind (x #f 0)) |
56164a5a | 387 | (program () (arity 1 0 #f) |
66d3e9a3 AW |
388 | (bind (y #f 0)) |
389 | (lexical #f #f ref 0) (call return 1)) | |
390 | (lexical #t #f ref 0) | |
391 | (call vector 1) | |
57ab0671 | 392 | (call make-closure 2) |
a1a482e0 | 393 | (call return 1)) |
ce09ee19 AW |
394 | (call return 1)))) |
395 | ||
396 | (with-test-prefix "sequence" | |
397 | (assert-tree-il->glil | |
398 | (begin (begin (const 2) (const #f)) (const #t)) | |
56164a5a | 399 | (program () (arity 0 0 #f) |
ce09ee19 AW |
400 | (const #t) (call return 1))) |
401 | ||
402 | (assert-tree-il->glil | |
403 | (apply (primitive null?) (begin (const #f) (const 2))) | |
56164a5a | 404 | (program () (arity 0 0 #f) |
ce09ee19 | 405 | (const 2) (call null? 1) (call return 1)))) |
5af166bd AW |
406 | |
407 | ;; FIXME: binding info for or-hacked locals might bork the disassembler, | |
408 | ;; and could be tightened in any case | |
409 | (with-test-prefix "the or hack" | |
410 | (assert-tree-il->glil/pmatch | |
411 | (let (x) (y) ((const 1)) | |
412 | (if (lexical x y) | |
413 | (lexical x y) | |
414 | (let (a) (b) ((const 2)) | |
415 | (lexical a b)))) | |
56164a5a | 416 | (program () (arity 0 0 #f) (call reserve-locals 1) |
66d3e9a3 AW |
417 | (const 1) (bind (x #f 0)) (lexical #t #f set 0) |
418 | (lexical #t #f ref 0) (branch br-if-not ,l1) | |
419 | (lexical #t #f ref 0) (call return 1) | |
5af166bd | 420 | (label ,l2) |
66d3e9a3 AW |
421 | (const 2) (bind (a #f 0)) (lexical #t #f set 0) |
422 | (lexical #t #f ref 0) (call return 1) | |
5af166bd AW |
423 | (unbind) |
424 | (unbind)) | |
425 | (eq? l1 l2)) | |
426 | ||
aaae0d5a | 427 | ;; second bound var is unreferenced |
5af166bd AW |
428 | (assert-tree-il->glil/pmatch |
429 | (let (x) (y) ((const 1)) | |
430 | (if (lexical x y) | |
431 | (lexical x y) | |
432 | (let (a) (b) ((const 2)) | |
433 | (lexical x y)))) | |
56164a5a | 434 | (program () (arity 0 0 #f) (call reserve-locals 1) |
66d3e9a3 AW |
435 | (const 1) (bind (x #f 0)) (lexical #t #f set 0) |
436 | (lexical #t #f ref 0) (branch br-if-not ,l1) | |
437 | (lexical #t #f ref 0) (call return 1) | |
5af166bd | 438 | (label ,l2) |
66d3e9a3 | 439 | (lexical #t #f ref 0) (call return 1) |
5af166bd AW |
440 | (unbind)) |
441 | (eq? l1 l2))) | |
0f423f20 AW |
442 | |
443 | (with-test-prefix "apply" | |
444 | (assert-tree-il->glil | |
445 | (apply (primitive @apply) (toplevel foo) (toplevel bar)) | |
56164a5a | 446 | (program () (arity 0 0 #f) (toplevel ref foo) (toplevel ref bar) (call goto/apply 2))) |
0f423f20 AW |
447 | (assert-tree-il->glil/pmatch |
448 | (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void)) | |
56164a5a | 449 | (program () (arity 0 0 #f) |
b7946e9e | 450 | (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1) |
0f423f20 AW |
451 | (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind) |
452 | (label ,l4) | |
453 | (void) (call return 1)) | |
454 | (and (eq? l1 l3) (eq? l2 l4))) | |
455 | (assert-tree-il->glil | |
456 | (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz))) | |
56164a5a | 457 | (program () (arity 0 0 #f) |
0f423f20 | 458 | (toplevel ref foo) |
b7946e9e | 459 | (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2) |
0f423f20 AW |
460 | (call goto/args 1)))) |
461 | ||
462 | (with-test-prefix "call/cc" | |
463 | (assert-tree-il->glil | |
464 | (apply (primitive @call-with-current-continuation) (toplevel foo)) | |
56164a5a | 465 | (program () (arity 0 0 #f) (toplevel ref foo) (call goto/cc 1))) |
0f423f20 AW |
466 | (assert-tree-il->glil/pmatch |
467 | (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void)) | |
56164a5a | 468 | (program () (arity 0 0 #f) |
b7946e9e | 469 | (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1) |
0f423f20 AW |
470 | (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind) |
471 | (label ,l4) | |
472 | (void) (call return 1)) | |
473 | (and (eq? l1 l3) (eq? l2 l4))) | |
474 | (assert-tree-il->glil | |
475 | (apply (toplevel foo) | |
476 | (apply (toplevel @call-with-current-continuation) (toplevel bar))) | |
56164a5a | 477 | (program () (arity 0 0 #f) |
0f423f20 AW |
478 | (toplevel ref foo) |
479 | (toplevel ref bar) (call call/cc 1) | |
480 | (call goto/args 1)))) | |
481 | ||
f4aa0f10 LC |
482 | \f |
483 | (with-test-prefix "tree-il-fold" | |
484 | ||
485 | (pass-if "empty tree" | |
486 | (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark))) | |
487 | (and (eq? mark | |
488 | (tree-il-fold (lambda (x y) (set! leaf? #t) y) | |
489 | (lambda (x y) (set! down? #t) y) | |
490 | (lambda (x y) (set! up? #t) y) | |
491 | mark | |
492 | '())) | |
493 | (not leaf?) | |
494 | (not up?) | |
495 | (not down?)))) | |
496 | ||
497 | (pass-if "lambda and application" | |
498 | (let* ((leaves '()) (ups '()) (downs '()) | |
499 | (result (tree-il-fold (lambda (x y) | |
500 | (set! leaves (cons x leaves)) | |
501 | (1+ y)) | |
502 | (lambda (x y) | |
503 | (set! downs (cons x downs)) | |
504 | (1+ y)) | |
505 | (lambda (x y) | |
506 | (set! ups (cons x ups)) | |
507 | (1+ y)) | |
508 | 0 | |
509 | (parse-tree-il | |
510 | '(lambda (x y) (x1 y1) | |
511 | (apply (toplevel +) | |
512 | (lexical x x1) | |
513 | (lexical y y1))))))) | |
514 | (and (equal? (map strip-source leaves) | |
515 | (list (make-lexical-ref #f 'y 'y1) | |
516 | (make-lexical-ref #f 'x 'x1) | |
517 | (make-toplevel-ref #f '+))) | |
518 | (= (length downs) 2) | |
519 | (equal? (reverse (map strip-source ups)) | |
520 | (map strip-source downs)))))) | |
4b856371 LC |
521 | |
522 | \f | |
523 | ;;; | |
524 | ;;; Warnings. | |
525 | ;;; | |
526 | ||
527 | ;; Make sure we get English messages. | |
528 | (setlocale LC_ALL "C") | |
529 | ||
530 | (define (call-with-warnings thunk) | |
531 | (let ((port (open-output-string))) | |
532 | (with-fluid* *current-warning-port* port | |
533 | thunk) | |
534 | (let ((warnings (get-output-string port))) | |
535 | (string-tokenize warnings | |
536 | (char-set-complement (char-set #\newline)))))) | |
537 | ||
538 | (define %opts-w-unused | |
539 | '(#:warnings (unused-variable))) | |
540 | ||
f67ddf9d LC |
541 | (define %opts-w-unbound |
542 | '(#:warnings (unbound-variable))) | |
4b856371 LC |
543 | |
544 | (with-test-prefix "warnings" | |
545 | ||
546 | (pass-if "unknown warning type" | |
547 | (let ((w (call-with-warnings | |
548 | (lambda () | |
549 | (compile #t #:opts '(#:warnings (does-not-exist))))))) | |
550 | (and (= (length w) 1) | |
551 | (number? (string-contains (car w) "unknown warning"))))) | |
552 | ||
553 | (with-test-prefix "unused-variable" | |
554 | ||
555 | (pass-if "quiet" | |
556 | (null? (call-with-warnings | |
557 | (lambda () | |
558 | (compile '(lambda (x y) (+ x y)) | |
559 | #:opts %opts-w-unused))))) | |
560 | ||
561 | (pass-if "let/unused" | |
562 | (let ((w (call-with-warnings | |
563 | (lambda () | |
564 | (compile '(lambda (x) | |
565 | (let ((y (+ x 2))) | |
566 | x)) | |
567 | #:opts %opts-w-unused))))) | |
568 | (and (= (length w) 1) | |
569 | (number? (string-contains (car w) "unused variable `y'"))))) | |
570 | ||
571 | (pass-if "shadowed variable" | |
572 | (let ((w (call-with-warnings | |
573 | (lambda () | |
574 | (compile '(lambda (x) | |
575 | (let ((y x)) | |
576 | (let ((y (+ x 2))) | |
577 | (+ x y)))) | |
578 | #:opts %opts-w-unused))))) | |
579 | (and (= (length w) 1) | |
580 | (number? (string-contains (car w) "unused variable `y'"))))) | |
581 | ||
582 | (pass-if "letrec" | |
583 | (null? (call-with-warnings | |
584 | (lambda () | |
585 | (compile '(lambda () | |
586 | (letrec ((x (lambda () (y))) | |
587 | (y (lambda () (x)))) | |
588 | y)) | |
589 | #:opts %opts-w-unused))))) | |
590 | ||
591 | (pass-if "unused argument" | |
592 | ;; Unused arguments should not be reported. | |
593 | (null? (call-with-warnings | |
594 | (lambda () | |
595 | (compile '(lambda (x y z) #t) | |
f67ddf9d LC |
596 | #:opts %opts-w-unused)))))) |
597 | ||
598 | (with-test-prefix "unbound variable" | |
599 | ||
600 | (pass-if "quiet" | |
601 | (null? (call-with-warnings | |
602 | (lambda () | |
603 | (compile '+ #:opts %opts-w-unbound))))) | |
604 | ||
605 | (pass-if "ref" | |
606 | (let* ((v (gensym)) | |
607 | (w (call-with-warnings | |
608 | (lambda () | |
609 | (compile v | |
610 | #:to 'assembly | |
611 | #:opts %opts-w-unbound))))) | |
612 | (and (= (length w) 1) | |
613 | (number? (string-contains (car w) | |
614 | (format #f "unbound variable `~A'" | |
615 | v)))))) | |
616 | ||
617 | (pass-if "set!" | |
618 | (let* ((v (gensym)) | |
619 | (w (call-with-warnings | |
620 | (lambda () | |
621 | (compile `(set! ,v 7) | |
622 | #:to 'assembly | |
623 | #:opts %opts-w-unbound))))) | |
624 | (and (= (length w) 1) | |
625 | (number? (string-contains (car w) | |
626 | (format #f "unbound variable `~A'" | |
627 | v)))))) | |
628 | ||
629 | (pass-if "module-local top-level is visible" | |
630 | (let ((m (make-module)) | |
631 | (v (gensym))) | |
632 | (beautify-user-module! m) | |
633 | (compile `(define ,v 123) | |
634 | #:env m #:opts %opts-w-unbound) | |
635 | (null? (call-with-warnings | |
636 | (lambda () | |
637 | (compile v | |
638 | #:env m | |
639 | #:to 'assembly | |
640 | #:opts %opts-w-unbound)))))) | |
641 | ||
642 | (pass-if "module-local top-level is visible after" | |
643 | (let ((m (make-module)) | |
644 | (v (gensym))) | |
645 | (beautify-user-module! m) | |
646 | (null? (call-with-warnings | |
647 | (lambda () | |
648 | (let ((in (open-input-string | |
649 | "(define (f) | |
650 | (set! chbouib 3)) | |
651 | (define chbouib 5)"))) | |
b6d2306d LC |
652 | (read-and-compile in |
653 | #:env m | |
654 | #:opts %opts-w-unbound))))))) | |
655 | ||
656 | (pass-if "GOOPS definitions are visible" | |
657 | (let ((m (make-module)) | |
658 | (v (gensym))) | |
659 | (beautify-user-module! m) | |
660 | (module-use! m (resolve-interface '(oop goops))) | |
661 | (null? (call-with-warnings | |
662 | (lambda () | |
663 | (let ((in (open-input-string | |
664 | "(define-class <foo> () | |
665 | (bar #:getter foo-bar)) | |
666 | (define z (foo-bar (make <foo>)))"))) | |
f67ddf9d LC |
667 | (read-and-compile in |
668 | #:env m | |
669 | #:opts %opts-w-unbound))))))))) |