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