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 | ;;;; | |
a4060f67 LC |
4 | ;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. |
5 | ;;;; | |
ce09ee19 AW |
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 | 9 | ;;;; version 3 of the License, or (at your option) any later version. |
a4060f67 | 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. | |
a4060f67 | 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) |
a4c7fe5c | 26 | #:use-module (language tree-il primitives) |
4b856371 LC |
27 | #:use-module (language glil) |
28 | #:use-module (srfi srfi-13)) | |
ce09ee19 | 29 | |
e0c90f90 AW |
30 | ;; Of course, the GLIL that is emitted depends on the source info of the |
31 | ;; input. Here we're not concerned about that, so we strip source | |
32 | ;; information from the incoming tree-il. | |
33 | ||
34 | (define (strip-source x) | |
35 | (post-order! (lambda (x) (set! (tree-il-src x) #f)) | |
36 | x)) | |
37 | ||
ce09ee19 | 38 | (define-syntax assert-tree-il->glil |
11671bba LC |
39 | (syntax-rules (with-partial-evaluation without-partial-evaluation |
40 | with-options) | |
41 | ((_ with-partial-evaluation in pat test ...) | |
42 | (assert-tree-il->glil with-options (#:partial-eval? #t) | |
43 | in pat test ...)) | |
44 | ((_ without-partial-evaluation in pat test ...) | |
45 | (assert-tree-il->glil with-options (#:partial-eval? #f) | |
46 | in pat test ...)) | |
47 | ((_ with-options opts in pat test ...) | |
ce09ee19 AW |
48 | (let ((exp 'in)) |
49 | (pass-if 'in | |
50 | (let ((glil (unparse-glil | |
e0c90f90 | 51 | (compile (strip-source (parse-tree-il exp)) |
11671bba LC |
52 | #:from 'tree-il #:to 'glil |
53 | #:opts 'opts)))) | |
ce09ee19 AW |
54 | (pmatch glil |
55 | (pat (guard test ...) #t) | |
11671bba LC |
56 | (else #f)))))) |
57 | ((_ in pat test ...) | |
58 | (assert-tree-il->glil with-partial-evaluation | |
59 | in pat test ...)))) | |
ce09ee19 | 60 | |
335c8a89 AW |
61 | (define-syntax pass-if-tree-il->scheme |
62 | (syntax-rules () | |
63 | ((_ in pat) | |
64 | (assert-scheme->tree-il->scheme in pat #t)) | |
65 | ((_ in pat guard-exp) | |
66 | (pass-if 'in | |
67 | (pmatch (tree-il->scheme | |
68 | (compile 'in #:from 'scheme #:to 'tree-il)) | |
69 | (pat (guard guard-exp) #t) | |
70 | (_ #f)))))) | |
71 | ||
11671bba LC |
72 | (define peval |
73 | ;; The partial evaluator. | |
74 | (@@ (language tree-il optimize) peval)) | |
75 | ||
76 | (define-syntax pass-if-peval | |
ef9ffe5e | 77 | (syntax-rules () |
11671bba | 78 | ((_ in pat) |
a4c7fe5c LC |
79 | (pass-if-peval in pat |
80 | (expand-primitives! | |
81 | (resolve-primitives! | |
82 | (compile 'in #:from 'scheme #:to 'tree-il) | |
83 | (current-module))))) | |
84 | ((_ in pat code) | |
11671bba | 85 | (pass-if 'in |
a4c7fe5c | 86 | (let ((evaled (unparse-tree-il (peval code)))) |
11671bba LC |
87 | (pmatch evaled |
88 | (pat #t) | |
f6123e4f AW |
89 | (_ (pk 'peval-mismatch) |
90 | ((@ (ice-9 pretty-print) pretty-print) | |
91 | 'in) | |
92 | (newline) | |
93 | ((@ (ice-9 pretty-print) pretty-print) | |
94 | evaled) | |
95 | (newline) | |
96 | ((@ (ice-9 pretty-print) pretty-print) | |
97 | 'pat) | |
98 | (newline) | |
99 | #f))))))) | |
11671bba LC |
100 | |
101 | \f | |
335c8a89 AW |
102 | (with-test-prefix "tree-il->scheme" |
103 | (pass-if-tree-il->scheme | |
104 | (case-lambda ((a) a) ((b c) (list b c))) | |
105 | (case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1))) | |
106 | (and (eq? a a1) (eq? b b1) (eq? c c1)))) | |
107 | ||
ce09ee19 AW |
108 | (with-test-prefix "void" |
109 | (assert-tree-il->glil | |
110 | (void) | |
8a4ca0ea | 111 | (program () (std-prelude 0 0 #f) (label _) (void) (call return 1))) |
ce09ee19 AW |
112 | (assert-tree-il->glil |
113 | (begin (void) (const 1)) | |
8a4ca0ea | 114 | (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1))) |
ce09ee19 | 115 | (assert-tree-il->glil |
a881a4ae | 116 | (primcall + (void) (const 1)) |
8a4ca0ea | 117 | (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1)))) |
ce09ee19 AW |
118 | |
119 | (with-test-prefix "application" | |
120 | (assert-tree-il->glil | |
7081d4f9 | 121 | (call (toplevel foo) (const 1)) |
a5bbb22e | 122 | (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call tail-call 1))) |
8a4ca0ea | 123 | (assert-tree-il->glil |
7081d4f9 | 124 | (begin (call (toplevel foo) (const 1)) (void)) |
8a4ca0ea | 125 | (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1) |
0f423f20 | 126 | (call drop 1) (branch br ,l2) |
05c51bcf | 127 | (label ,l3) (mv-bind 0 #f) |
0f423f20 | 128 | (label ,l4) |
30a5e062 | 129 | (void) (call return 1)) |
0f423f20 | 130 | (and (eq? l1 l3) (eq? l2 l4))) |
ce09ee19 | 131 | (assert-tree-il->glil |
7081d4f9 | 132 | (call (toplevel foo) (call (toplevel bar))) |
8a4ca0ea | 133 | (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0) |
a5bbb22e | 134 | (call tail-call 1)))) |
ce09ee19 AW |
135 | |
136 | (with-test-prefix "conditional" | |
8a4ca0ea | 137 | (assert-tree-il->glil |
0e4b7818 AW |
138 | (if (toplevel foo) (const 1) (const 2)) |
139 | (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) | |
ce09ee19 AW |
140 | (const 1) (call return 1) |
141 | (label ,l2) (const 2) (call return 1)) | |
142 | (eq? l1 l2)) | |
11671bba LC |
143 | |
144 | (assert-tree-il->glil without-partial-evaluation | |
0e4b7818 AW |
145 | (begin (if (toplevel foo) (const 1) (const 2)) (const #f)) |
146 | (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (branch br ,l2) | |
ce09ee19 AW |
147 | (label ,l3) (label ,l4) (const #f) (call return 1)) |
148 | (eq? l1 l3) (eq? l2 l4)) | |
149 | ||
8a4ca0ea | 150 | (assert-tree-il->glil |
a881a4ae | 151 | (primcall null? (if (toplevel foo) (const 1) (const 2))) |
0e4b7818 | 152 | (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) |
ce09ee19 AW |
153 | (const 1) (branch br ,l2) |
154 | (label ,l3) (const 2) (label ,l4) | |
155 | (call null? 1) (call return 1)) | |
156 | (eq? l1 l3) (eq? l2 l4))) | |
157 | ||
158 | (with-test-prefix "primitive-ref" | |
159 | (assert-tree-il->glil | |
160 | (primitive +) | |
8a4ca0ea | 161 | (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call return 1))) |
ce09ee19 AW |
162 | |
163 | (assert-tree-il->glil | |
164 | (begin (primitive +) (const #f)) | |
8a4ca0ea | 165 | (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1))) |
ce09ee19 AW |
166 | |
167 | (assert-tree-il->glil | |
a881a4ae | 168 | (primcall null? (primitive +)) |
8a4ca0ea | 169 | (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1) |
ce09ee19 AW |
170 | (call return 1)))) |
171 | ||
172 | (with-test-prefix "lexical refs" | |
11671bba | 173 | (assert-tree-il->glil without-partial-evaluation |
ce09ee19 | 174 | (let (x) (y) ((const 1)) (lexical x y)) |
8a4ca0ea | 175 | (program () (std-prelude 0 1 #f) (label _) |
66d3e9a3 AW |
176 | (const 1) (bind (x #f 0)) (lexical #t #f set 0) |
177 | (lexical #t #f ref 0) (call return 1) | |
ce09ee19 AW |
178 | (unbind))) |
179 | ||
11671bba | 180 | (assert-tree-il->glil without-partial-evaluation |
ce09ee19 | 181 | (let (x) (y) ((const 1)) (begin (lexical x y) (const #f))) |
8a4ca0ea | 182 | (program () (std-prelude 0 1 #f) (label _) |
66d3e9a3 | 183 | (const 1) (bind (x #f 0)) (lexical #t #f set 0) |
ce09ee19 AW |
184 | (const #f) (call return 1) |
185 | (unbind))) | |
186 | ||
11671bba | 187 | (assert-tree-il->glil without-partial-evaluation |
a881a4ae | 188 | (let (x) (y) ((const 1)) (primcall null? (lexical x y))) |
8a4ca0ea | 189 | (program () (std-prelude 0 1 #f) (label _) |
66d3e9a3 AW |
190 | (const 1) (bind (x #f 0)) (lexical #t #f set 0) |
191 | (lexical #t #f ref 0) (call null? 1) (call return 1) | |
ce09ee19 AW |
192 | (unbind)))) |
193 | ||
194 | (with-test-prefix "lexical sets" | |
195 | (assert-tree-il->glil | |
aaae0d5a AW |
196 | ;; unreferenced sets may be optimized away -- make sure they are ref'd |
197 | (let (x) (y) ((const 1)) | |
a881a4ae | 198 | (set! (lexical x y) (primcall 1+ (lexical x y)))) |
8a4ca0ea | 199 | (program () (std-prelude 0 1 #f) (label _) |
66d3e9a3 | 200 | (const 1) (bind (x #t 0)) (lexical #t #t box 0) |
aaae0d5a AW |
201 | (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) |
202 | (void) (call return 1) | |
ce09ee19 AW |
203 | (unbind))) |
204 | ||
205 | (assert-tree-il->glil | |
aaae0d5a | 206 | (let (x) (y) ((const 1)) |
a881a4ae | 207 | (begin (set! (lexical x y) (primcall 1+ (lexical x y))) |
aaae0d5a | 208 | (lexical x y))) |
8a4ca0ea | 209 | (program () (std-prelude 0 1 #f) (label _) |
66d3e9a3 | 210 | (const 1) (bind (x #t 0)) (lexical #t #t box 0) |
aaae0d5a AW |
211 | (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) |
212 | (lexical #t #t ref 0) (call return 1) | |
ce09ee19 AW |
213 | (unbind))) |
214 | ||
215 | (assert-tree-il->glil | |
216 | (let (x) (y) ((const 1)) | |
a881a4ae AW |
217 | (primcall null? |
218 | (set! (lexical x y) (primcall 1+ (lexical x y))))) | |
8a4ca0ea | 219 | (program () (std-prelude 0 1 #f) (label _) |
66d3e9a3 | 220 | (const 1) (bind (x #t 0)) (lexical #t #t box 0) |
aaae0d5a AW |
221 | (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void) |
222 | (call null? 1) (call return 1) | |
ce09ee19 AW |
223 | (unbind)))) |
224 | ||
225 | (with-test-prefix "module refs" | |
226 | (assert-tree-il->glil | |
227 | (@ (foo) bar) | |
8a4ca0ea | 228 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
229 | (module public ref (foo) bar) |
230 | (call return 1))) | |
231 | ||
232 | (assert-tree-il->glil | |
233 | (begin (@ (foo) bar) (const #f)) | |
8a4ca0ea | 234 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
235 | (module public ref (foo) bar) (call drop 1) |
236 | (const #f) (call return 1))) | |
237 | ||
238 | (assert-tree-il->glil | |
a881a4ae | 239 | (primcall null? (@ (foo) bar)) |
8a4ca0ea | 240 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
241 | (module public ref (foo) bar) |
242 | (call null? 1) (call return 1))) | |
243 | ||
244 | (assert-tree-il->glil | |
245 | (@@ (foo) bar) | |
8a4ca0ea | 246 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
247 | (module private ref (foo) bar) |
248 | (call return 1))) | |
249 | ||
250 | (assert-tree-il->glil | |
251 | (begin (@@ (foo) bar) (const #f)) | |
8a4ca0ea | 252 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
253 | (module private ref (foo) bar) (call drop 1) |
254 | (const #f) (call return 1))) | |
255 | ||
256 | (assert-tree-il->glil | |
a881a4ae | 257 | (primcall null? (@@ (foo) bar)) |
8a4ca0ea | 258 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
259 | (module private ref (foo) bar) |
260 | (call null? 1) (call return 1)))) | |
261 | ||
262 | (with-test-prefix "module sets" | |
263 | (assert-tree-il->glil | |
264 | (set! (@ (foo) bar) (const 2)) | |
8a4ca0ea | 265 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
266 | (const 2) (module public set (foo) bar) |
267 | (void) (call return 1))) | |
268 | ||
269 | (assert-tree-il->glil | |
270 | (begin (set! (@ (foo) bar) (const 2)) (const #f)) | |
8a4ca0ea | 271 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
272 | (const 2) (module public set (foo) bar) |
273 | (const #f) (call return 1))) | |
274 | ||
275 | (assert-tree-il->glil | |
a881a4ae | 276 | (primcall null? (set! (@ (foo) bar) (const 2))) |
8a4ca0ea | 277 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
278 | (const 2) (module public set (foo) bar) |
279 | (void) (call null? 1) (call return 1))) | |
280 | ||
281 | (assert-tree-il->glil | |
282 | (set! (@@ (foo) bar) (const 2)) | |
8a4ca0ea | 283 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
284 | (const 2) (module private set (foo) bar) |
285 | (void) (call return 1))) | |
286 | ||
287 | (assert-tree-il->glil | |
288 | (begin (set! (@@ (foo) bar) (const 2)) (const #f)) | |
8a4ca0ea | 289 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
290 | (const 2) (module private set (foo) bar) |
291 | (const #f) (call return 1))) | |
292 | ||
293 | (assert-tree-il->glil | |
a881a4ae | 294 | (primcall null? (set! (@@ (foo) bar) (const 2))) |
8a4ca0ea | 295 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
296 | (const 2) (module private set (foo) bar) |
297 | (void) (call null? 1) (call return 1)))) | |
298 | ||
299 | (with-test-prefix "toplevel refs" | |
300 | (assert-tree-il->glil | |
301 | (toplevel bar) | |
8a4ca0ea | 302 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
303 | (toplevel ref bar) |
304 | (call return 1))) | |
305 | ||
11671bba | 306 | (assert-tree-il->glil without-partial-evaluation |
ce09ee19 | 307 | (begin (toplevel bar) (const #f)) |
8a4ca0ea | 308 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
309 | (toplevel ref bar) (call drop 1) |
310 | (const #f) (call return 1))) | |
311 | ||
312 | (assert-tree-il->glil | |
a881a4ae | 313 | (primcall null? (toplevel bar)) |
8a4ca0ea | 314 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
315 | (toplevel ref bar) |
316 | (call null? 1) (call return 1)))) | |
317 | ||
318 | (with-test-prefix "toplevel sets" | |
319 | (assert-tree-il->glil | |
320 | (set! (toplevel bar) (const 2)) | |
8a4ca0ea | 321 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
322 | (const 2) (toplevel set bar) |
323 | (void) (call return 1))) | |
324 | ||
325 | (assert-tree-il->glil | |
326 | (begin (set! (toplevel bar) (const 2)) (const #f)) | |
8a4ca0ea | 327 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
328 | (const 2) (toplevel set bar) |
329 | (const #f) (call return 1))) | |
330 | ||
331 | (assert-tree-il->glil | |
a881a4ae | 332 | (primcall null? (set! (toplevel bar) (const 2))) |
8a4ca0ea | 333 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
334 | (const 2) (toplevel set bar) |
335 | (void) (call null? 1) (call return 1)))) | |
336 | ||
337 | (with-test-prefix "toplevel defines" | |
338 | (assert-tree-il->glil | |
339 | (define bar (const 2)) | |
8a4ca0ea | 340 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
341 | (const 2) (toplevel define bar) |
342 | (void) (call return 1))) | |
343 | ||
344 | (assert-tree-il->glil | |
345 | (begin (define bar (const 2)) (const #f)) | |
8a4ca0ea | 346 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
347 | (const 2) (toplevel define bar) |
348 | (const #f) (call return 1))) | |
349 | ||
350 | (assert-tree-il->glil | |
a881a4ae | 351 | (primcall null? (define bar (const 2))) |
8a4ca0ea | 352 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
353 | (const 2) (toplevel define bar) |
354 | (void) (call null? 1) (call return 1)))) | |
355 | ||
356 | (with-test-prefix "constants" | |
357 | (assert-tree-il->glil | |
358 | (const 2) | |
8a4ca0ea | 359 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
360 | (const 2) (call return 1))) |
361 | ||
362 | (assert-tree-il->glil | |
363 | (begin (const 2) (const #f)) | |
8a4ca0ea | 364 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
365 | (const #f) (call return 1))) |
366 | ||
367 | (assert-tree-il->glil | |
11671bba | 368 | ;; This gets simplified by `peval'. |
a881a4ae | 369 | (primcall null? (const 2)) |
8a4ca0ea | 370 | (program () (std-prelude 0 0 #f) (label _) |
11671bba | 371 | (const #f) (call return 1)))) |
ce09ee19 | 372 | |
60d4b224 AW |
373 | (with-test-prefix "letrec" |
374 | ;; simple bindings -> let | |
11671bba | 375 | (assert-tree-il->glil without-partial-evaluation |
60d4b224 | 376 | (letrec (x y) (x1 y1) ((const 10) (const 20)) |
7081d4f9 | 377 | (call (toplevel foo) (lexical x x1) (lexical y y1))) |
60d4b224 AW |
378 | (program () (std-prelude 0 2 #f) (label _) |
379 | (const 10) (const 20) | |
380 | (bind (x #f 0) (y #f 1)) | |
381 | (lexical #t #f set 1) (lexical #t #f set 0) | |
382 | (toplevel ref foo) | |
383 | (lexical #t #f ref 0) (lexical #t #f ref 1) | |
384 | (call tail-call 2) | |
385 | (unbind))) | |
386 | ||
387 | ;; complex bindings -> box and set! within let | |
11671bba | 388 | (assert-tree-il->glil without-partial-evaluation |
7081d4f9 | 389 | (letrec (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar))) |
a881a4ae | 390 | (primcall + (lexical x x1) (lexical y y1))) |
60d4b224 AW |
391 | (program () (std-prelude 0 4 #f) (label _) |
392 | (void) (void) ;; what are these? | |
393 | (bind (x #t 0) (y #t 1)) | |
394 | (lexical #t #t box 1) (lexical #t #t box 0) | |
395 | (call new-frame 0) (toplevel ref foo) (call call 0) | |
396 | (call new-frame 0) (toplevel ref bar) (call call 0) | |
397 | (bind (x #f 2) (y #f 3)) (lexical #t #f set 3) (lexical #t #f set 2) | |
398 | (lexical #t #f ref 2) (lexical #t #t set 0) | |
02060279 AW |
399 | (lexical #t #f ref 3) (lexical #t #t set 1) |
400 | (void) (lexical #t #f set 2) (void) (lexical #t #f set 3) ;; clear bindings | |
401 | (unbind) | |
60d4b224 AW |
402 | (lexical #t #t ref 0) (lexical #t #t ref 1) |
403 | (call add 2) (call return 1) (unbind))) | |
404 | ||
405 | ;; complex bindings in letrec* -> box and set! in order | |
11671bba | 406 | (assert-tree-il->glil without-partial-evaluation |
7081d4f9 | 407 | (letrec* (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar))) |
a881a4ae | 408 | (primcall + (lexical x x1) (lexical y y1))) |
60d4b224 AW |
409 | (program () (std-prelude 0 2 #f) (label _) |
410 | (void) (void) ;; what are these? | |
411 | (bind (x #t 0) (y #t 1)) | |
412 | (lexical #t #t box 1) (lexical #t #t box 0) | |
413 | (call new-frame 0) (toplevel ref foo) (call call 0) | |
414 | (lexical #t #t set 0) | |
415 | (call new-frame 0) (toplevel ref bar) (call call 0) | |
416 | (lexical #t #t set 1) | |
417 | (lexical #t #t ref 0) | |
418 | (lexical #t #t ref 1) | |
65ea26c5 LC |
419 | (call add 2) (call return 1) (unbind))) |
420 | ||
421 | ;; simple bindings in letrec* -> equivalent to letrec | |
11671bba | 422 | (assert-tree-il->glil without-partial-evaluation |
65ea26c5 LC |
423 | (letrec* (x y) (xx yy) ((const 1) (const 2)) |
424 | (lexical y yy)) | |
425 | (program () (std-prelude 0 1 #f) (label _) | |
426 | (const 2) | |
427 | (bind (y #f 0)) ;; X is removed, and Y is unboxed | |
428 | (lexical #t #f set 0) | |
429 | (lexical #t #f ref 0) | |
430 | (call return 1) (unbind)))) | |
60d4b224 | 431 | |
ce09ee19 AW |
432 | (with-test-prefix "lambda" |
433 | (assert-tree-il->glil | |
8a4ca0ea | 434 | (lambda () |
1e2a8edb | 435 | (lambda-case (((x) #f #f #f () (y)) (const 2)) #f)) |
8a4ca0ea | 436 | (program () (std-prelude 0 0 #f) (label _) |
258344b4 | 437 | (program () (std-prelude 1 1 #f) |
8a4ca0ea AW |
438 | (bind (x #f 0)) (label _) |
439 | (const 2) (call return 1) (unbind)) | |
ce09ee19 AW |
440 | (call return 1))) |
441 | ||
442 | (assert-tree-il->glil | |
8a4ca0ea | 443 | (lambda () |
1e2a8edb | 444 | (lambda-case (((x y) #f #f #f () (x1 y1)) |
8a4ca0ea AW |
445 | (const 2)) |
446 | #f)) | |
447 | (program () (std-prelude 0 0 #f) (label _) | |
258344b4 | 448 | (program () (std-prelude 2 2 #f) |
8a4ca0ea AW |
449 | (bind (x #f 0) (y #f 1)) (label _) |
450 | (const 2) (call return 1) | |
451 | (unbind)) | |
ce09ee19 AW |
452 | (call return 1))) |
453 | ||
454 | (assert-tree-il->glil | |
8a4ca0ea | 455 | (lambda () |
1e2a8edb | 456 | (lambda-case ((() #f x #f () (y)) (const 2)) |
8a4ca0ea AW |
457 | #f)) |
458 | (program () (std-prelude 0 0 #f) (label _) | |
899d37a6 | 459 | (program () (opt-prelude 0 0 0 1 #f) |
8a4ca0ea AW |
460 | (bind (x #f 0)) (label _) |
461 | (const 2) (call return 1) | |
462 | (unbind)) | |
ce09ee19 AW |
463 | (call return 1))) |
464 | ||
465 | (assert-tree-il->glil | |
8a4ca0ea | 466 | (lambda () |
1e2a8edb | 467 | (lambda-case (((x) #f x1 #f () (y y1)) (const 2)) |
8a4ca0ea AW |
468 | #f)) |
469 | (program () (std-prelude 0 0 #f) (label _) | |
899d37a6 | 470 | (program () (opt-prelude 1 0 1 2 #f) |
8a4ca0ea AW |
471 | (bind (x #f 0) (x1 #f 1)) (label _) |
472 | (const 2) (call return 1) | |
473 | (unbind)) | |
ce09ee19 AW |
474 | (call return 1))) |
475 | ||
476 | (assert-tree-il->glil | |
8a4ca0ea | 477 | (lambda () |
1e2a8edb | 478 | (lambda-case (((x) #f x1 #f () (y y1)) (lexical x y)) |
8a4ca0ea AW |
479 | #f)) |
480 | (program () (std-prelude 0 0 #f) (label _) | |
899d37a6 | 481 | (program () (opt-prelude 1 0 1 2 #f) |
8a4ca0ea AW |
482 | (bind (x #f 0) (x1 #f 1)) (label _) |
483 | (lexical #t #f ref 0) (call return 1) | |
484 | (unbind)) | |
ce09ee19 AW |
485 | (call return 1))) |
486 | ||
487 | (assert-tree-il->glil | |
8a4ca0ea | 488 | (lambda () |
1e2a8edb | 489 | (lambda-case (((x) #f x1 #f () (y y1)) (lexical x1 y1)) |
8a4ca0ea AW |
490 | #f)) |
491 | (program () (std-prelude 0 0 #f) (label _) | |
899d37a6 | 492 | (program () (opt-prelude 1 0 1 2 #f) |
8a4ca0ea AW |
493 | (bind (x #f 0) (x1 #f 1)) (label _) |
494 | (lexical #t #f ref 1) (call return 1) | |
495 | (unbind)) | |
a1a482e0 AW |
496 | (call return 1))) |
497 | ||
498 | (assert-tree-il->glil | |
8a4ca0ea | 499 | (lambda () |
1e2a8edb | 500 | (lambda-case (((x) #f #f #f () (x1)) |
8a4ca0ea | 501 | (lambda () |
1e2a8edb | 502 | (lambda-case (((y) #f #f #f () (y1)) |
8a4ca0ea AW |
503 | (lexical x x1)) |
504 | #f))) | |
505 | #f)) | |
506 | (program () (std-prelude 0 0 #f) (label _) | |
507 | (program () (std-prelude 1 1 #f) | |
508 | (bind (x #f 0)) (label _) | |
258344b4 | 509 | (program () (std-prelude 1 1 #f) |
8a4ca0ea AW |
510 | (bind (y #f 0)) (label _) |
511 | (lexical #f #f ref 0) (call return 1) | |
512 | (unbind)) | |
66d3e9a3 | 513 | (lexical #t #f ref 0) |
6f16379e | 514 | (call make-closure 1) |
8a4ca0ea AW |
515 | (call return 1) |
516 | (unbind)) | |
ce09ee19 AW |
517 | (call return 1)))) |
518 | ||
519 | (with-test-prefix "sequence" | |
520 | (assert-tree-il->glil | |
521 | (begin (begin (const 2) (const #f)) (const #t)) | |
8a4ca0ea | 522 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
523 | (const #t) (call return 1))) |
524 | ||
525 | (assert-tree-il->glil | |
11671bba | 526 | ;; This gets simplified by `peval'. |
a881a4ae | 527 | (primcall null? (begin (const #f) (const 2))) |
8a4ca0ea | 528 | (program () (std-prelude 0 0 #f) (label _) |
11671bba | 529 | (const #f) (call return 1)))) |
5af166bd | 530 | |
b88fef55 AW |
531 | (with-test-prefix "values" |
532 | (assert-tree-il->glil | |
78f0ef20 AW |
533 | (primcall values |
534 | (primcall values (const 1) (const 2))) | |
b88fef55 AW |
535 | (program () (std-prelude 0 0 #f) (label _) |
536 | (const 1) (call return 1))) | |
537 | ||
538 | (assert-tree-il->glil | |
78f0ef20 AW |
539 | (primcall values |
540 | (primcall values (const 1) (const 2)) | |
541 | (const 3)) | |
b88fef55 AW |
542 | (program () (std-prelude 0 0 #f) (label _) |
543 | (const 1) (const 3) (call return/values 2))) | |
544 | ||
545 | (assert-tree-il->glil | |
78f0ef20 AW |
546 | (primcall + |
547 | (primcall values (const 1) (const 2))) | |
b88fef55 AW |
548 | (program () (std-prelude 0 0 #f) (label _) |
549 | (const 1) (call return 1)))) | |
550 | ||
5af166bd AW |
551 | ;; FIXME: binding info for or-hacked locals might bork the disassembler, |
552 | ;; and could be tightened in any case | |
553 | (with-test-prefix "the or hack" | |
11671bba | 554 | (assert-tree-il->glil without-partial-evaluation |
5af166bd AW |
555 | (let (x) (y) ((const 1)) |
556 | (if (lexical x y) | |
557 | (lexical x y) | |
558 | (let (a) (b) ((const 2)) | |
559 | (lexical a b)))) | |
8a4ca0ea | 560 | (program () (std-prelude 0 1 #f) (label _) |
66d3e9a3 AW |
561 | (const 1) (bind (x #f 0)) (lexical #t #f set 0) |
562 | (lexical #t #f ref 0) (branch br-if-not ,l1) | |
563 | (lexical #t #f ref 0) (call return 1) | |
5af166bd | 564 | (label ,l2) |
66d3e9a3 AW |
565 | (const 2) (bind (a #f 0)) (lexical #t #f set 0) |
566 | (lexical #t #f ref 0) (call return 1) | |
5af166bd AW |
567 | (unbind) |
568 | (unbind)) | |
569 | (eq? l1 l2)) | |
570 | ||
aaae0d5a | 571 | ;; second bound var is unreferenced |
11671bba | 572 | (assert-tree-il->glil without-partial-evaluation |
5af166bd AW |
573 | (let (x) (y) ((const 1)) |
574 | (if (lexical x y) | |
575 | (lexical x y) | |
576 | (let (a) (b) ((const 2)) | |
577 | (lexical x y)))) | |
8a4ca0ea | 578 | (program () (std-prelude 0 1 #f) (label _) |
66d3e9a3 AW |
579 | (const 1) (bind (x #f 0)) (lexical #t #f set 0) |
580 | (lexical #t #f ref 0) (branch br-if-not ,l1) | |
581 | (lexical #t #f ref 0) (call return 1) | |
5af166bd | 582 | (label ,l2) |
66d3e9a3 | 583 | (lexical #t #f ref 0) (call return 1) |
5af166bd AW |
584 | (unbind)) |
585 | (eq? l1 l2))) | |
0f423f20 AW |
586 | |
587 | (with-test-prefix "apply" | |
588 | (assert-tree-il->glil | |
a881a4ae | 589 | (primcall @apply (toplevel foo) (toplevel bar)) |
a5bbb22e | 590 | (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2))) |
8a4ca0ea | 591 | (assert-tree-il->glil |
a881a4ae | 592 | (begin (primcall @apply (toplevel foo) (toplevel bar)) (void)) |
8a4ca0ea | 593 | (program () (std-prelude 0 0 #f) (label _) |
b7946e9e | 594 | (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1) |
05c51bcf | 595 | (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f) |
0f423f20 AW |
596 | (label ,l4) |
597 | (void) (call return 1)) | |
598 | (and (eq? l1 l3) (eq? l2 l4))) | |
599 | (assert-tree-il->glil | |
7081d4f9 | 600 | (call (toplevel foo) (call (toplevel @apply) (toplevel bar) (toplevel baz))) |
8a4ca0ea | 601 | (program () (std-prelude 0 0 #f) (label _) |
0f423f20 | 602 | (toplevel ref foo) |
b7946e9e | 603 | (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2) |
a5bbb22e | 604 | (call tail-call 1)))) |
0f423f20 AW |
605 | |
606 | (with-test-prefix "call/cc" | |
607 | (assert-tree-il->glil | |
a881a4ae | 608 | (primcall @call-with-current-continuation (toplevel foo)) |
a5bbb22e | 609 | (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1))) |
8a4ca0ea | 610 | (assert-tree-il->glil |
a881a4ae | 611 | (begin (primcall @call-with-current-continuation (toplevel foo)) (void)) |
8a4ca0ea | 612 | (program () (std-prelude 0 0 #f) (label _) |
b7946e9e | 613 | (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1) |
05c51bcf | 614 | (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f) |
0f423f20 AW |
615 | (label ,l4) |
616 | (void) (call return 1)) | |
617 | (and (eq? l1 l3) (eq? l2 l4))) | |
618 | (assert-tree-il->glil | |
7081d4f9 AW |
619 | (call (toplevel foo) |
620 | (call (toplevel @call-with-current-continuation) (toplevel bar))) | |
8a4ca0ea | 621 | (program () (std-prelude 0 0 #f) (label _) |
0f423f20 AW |
622 | (toplevel ref foo) |
623 | (toplevel ref bar) (call call/cc 1) | |
a5bbb22e | 624 | (call tail-call 1)))) |
0f423f20 | 625 | |
f4aa0f10 | 626 | \f |
aa9c1985 AW |
627 | (with-test-prefix "labels allocation" |
628 | (pass-if "http://debbugs.gnu.org/9769" | |
629 | ((compile '(lambda () | |
630 | (let ((fail (lambda () #f))) | |
631 | (let ((test (lambda () (fail)))) | |
632 | (test)) | |
633 | #t)) | |
634 | ;; Prevent inlining. We're testing analyze.scm's | |
635 | ;; labels allocator here, and inlining it will | |
636 | ;; reduce the entire thing to #t. | |
637 | #:opts '(#:partial-eval? #f))))) | |
638 | ||
639 | \f | |
11671bba LC |
640 | (with-test-prefix "partial evaluation" |
641 | ||
642 | (pass-if-peval | |
643 | ;; First order, primitive. | |
644 | (let ((x 1) (y 2)) (+ x y)) | |
645 | (const 3)) | |
646 | ||
89436781 | 647 | (pass-if-peval |
73524951 LC |
648 | ;; First order, thunk. |
649 | (let ((x 1) (y 2)) | |
650 | (let ((f (lambda () (+ x y)))) | |
651 | (f))) | |
652 | (const 3)) | |
653 | ||
ef9ffe5e | 654 | (pass-if-peval |
a4c7fe5c LC |
655 | ;; First order, let-values (requires primitive expansion for |
656 | ;; `call-with-values'.) | |
657 | (let ((x 0)) | |
658 | (call-with-values | |
659 | (lambda () (if (zero? x) (values 1 2) (values 3 4))) | |
660 | (lambda (a b) | |
661 | (+ a b)))) | |
662 | (const 3)) | |
663 | ||
296004b3 | 664 | (pass-if-peval |
bcec8858 LC |
665 | ;; First order, multiple values. |
666 | (let ((x 1) (y 2)) | |
667 | (values x y)) | |
296004b3 | 668 | (primcall values (const 1) (const 2))) |
bcec8858 | 669 | |
296004b3 | 670 | (pass-if-peval |
bcec8858 LC |
671 | ;; First order, multiple values truncated. |
672 | (let ((x (values 1 'a)) (y 2)) | |
673 | (values x y)) | |
296004b3 | 674 | (primcall values (const 1) (const 2))) |
bcec8858 | 675 | |
296004b3 | 676 | (pass-if-peval |
bcec8858 LC |
677 | ;; First order, multiple values truncated. |
678 | (or (values 1 2) 3) | |
679 | (const 1)) | |
680 | ||
73524951 | 681 | (pass-if-peval |
02ebea53 | 682 | ;; First order, coalesced, mutability preserved. |
89436781 | 683 | (cons 0 (cons 1 (cons 2 (list 3 4 5)))) |
ca128245 AW |
684 | (primcall list |
685 | (const 0) (const 1) (const 2) (const 3) (const 4) (const 5))) | |
89436781 LC |
686 | |
687 | (pass-if-peval | |
02ebea53 AW |
688 | ;; First order, coalesced, mutability preserved. |
689 | (cons 0 (cons 1 (cons 2 (list 3 4 5)))) | |
690 | ;; This must not be a constant. | |
ca128245 AW |
691 | (primcall list |
692 | (const 0) (const 1) (const 2) (const 3) (const 4) (const 5))) | |
02ebea53 AW |
693 | |
694 | (pass-if-peval | |
695 | ;; First order, coalesced, immutability preserved. | |
696 | (cons 0 (cons 1 (cons 2 '(3 4 5)))) | |
ca128245 AW |
697 | (primcall cons (const 0) |
698 | (primcall cons (const 1) | |
699 | (primcall cons (const 2) | |
700 | (const (3 4 5)))))) | |
02ebea53 AW |
701 | |
702 | ;; These two tests doesn't work any more because we changed the way we | |
b8392332 AW |
703 | ;; deal with constants -- now the algorithm will see a construction as |
704 | ;; being bound to the lexical, so it won't propagate it. It can't | |
705 | ;; even propagate it in the case that it is only referenced once, | |
706 | ;; because: | |
707 | ;; | |
708 | ;; (let ((x (cons 1 2))) (lambda () x)) | |
709 | ;; | |
710 | ;; is not the same as | |
711 | ;; | |
712 | ;; (lambda () (cons 1 2)) | |
713 | ;; | |
714 | ;; Perhaps if we determined that not only was it only referenced once, | |
715 | ;; it was not closed over by a lambda, then we could propagate it, and | |
716 | ;; re-enable these two tests. | |
717 | ;; | |
718 | #; | |
89436781 | 719 | (pass-if-peval |
b8392332 AW |
720 | ;; First order, mutability preserved. |
721 | (let loop ((i 3) (r '())) | |
722 | (if (zero? i) | |
723 | r | |
724 | (loop (1- i) (cons (cons i i) r)))) | |
ca128245 AW |
725 | (primcall list |
726 | (primcall cons (const 1) (const 1)) | |
727 | (primcall cons (const 2) (const 2)) | |
728 | (primcall cons (const 3) (const 3)))) | |
b8392332 AW |
729 | ;; |
730 | ;; See above. | |
731 | #; | |
732 | (pass-if-peval | |
733 | ;; First order, evaluated. | |
734 | (let loop ((i 7) | |
735 | (r '())) | |
736 | (if (<= i 0) | |
737 | (car r) | |
738 | (loop (1- i) (cons i r)))) | |
739 | (const 1)) | |
740 | ||
741 | ;; Instead here are tests for what happens for the above cases: they | |
742 | ;; unroll but they don't fold. | |
743 | (pass-if-peval | |
744 | (let loop ((i 3) (r '())) | |
745 | (if (zero? i) | |
746 | r | |
747 | (loop (1- i) (cons (cons i i) r)))) | |
75170872 | 748 | (let (r) (_) |
a215c159 AW |
749 | ((primcall list |
750 | (primcall cons (const 3) (const 3)))) | |
75170872 | 751 | (let (r) (_) |
a215c159 AW |
752 | ((primcall cons |
753 | (primcall cons (const 2) (const 2)) | |
754 | (lexical r _))) | |
755 | (primcall cons | |
756 | (primcall cons (const 1) (const 1)) | |
757 | (lexical r _))))) | |
b8392332 AW |
758 | |
759 | ;; See above. | |
760 | (pass-if-peval | |
761 | (let loop ((i 4) | |
762 | (r '())) | |
763 | (if (<= i 0) | |
764 | (car r) | |
765 | (loop (1- i) (cons i r)))) | |
75170872 | 766 | (let (r) (_) |
a215c159 | 767 | ((primcall list (const 4))) |
75170872 | 768 | (let (r) (_) |
a215c159 AW |
769 | ((primcall cons |
770 | (const 3) | |
771 | (lexical r _))) | |
75170872 | 772 | (let (r) (_) |
a215c159 AW |
773 | ((primcall cons |
774 | (const 2) | |
775 | (lexical r _))) | |
75170872 | 776 | (let (r) (_) |
a215c159 AW |
777 | ((primcall cons |
778 | (const 1) | |
779 | (lexical r _))) | |
780 | (primcall car | |
781 | (lexical r _))))))) | |
89436781 | 782 | |
02ebea53 | 783 | ;; Static sums. |
870dfc60 | 784 | (pass-if-peval |
02ebea53 AW |
785 | (let loop ((l '(1 2 3 4)) (sum 0)) |
786 | (if (null? l) | |
787 | sum | |
788 | (loop (cdr l) (+ sum (car l))))) | |
789 | (const 10)) | |
790 | ||
ef9ffe5e | 791 | (pass-if-peval |
30fcf30f AW |
792 | (let ((string->chars |
793 | (lambda (s) | |
794 | (define (char-at n) | |
795 | (string-ref s n)) | |
796 | (define (len) | |
797 | (string-length s)) | |
798 | (let loop ((i 0)) | |
799 | (if (< i (len)) | |
800 | (cons (char-at i) | |
801 | (loop (1+ i))) | |
802 | '()))))) | |
803 | (string->chars "yo")) | |
17595572 | 804 | (primcall list (const #\y) (const #\o))) |
30fcf30f | 805 | |
16d50b8e LC |
806 | (pass-if-peval |
807 | ;; Primitives in module-refs are resolved (the expansion of `pmatch' | |
808 | ;; below leads to calls to (@@ (system base pmatch) car) and | |
809 | ;; similar, which is what we want to be inlined.) | |
810 | (begin | |
811 | (use-modules (system base pmatch)) | |
812 | (pmatch '(a b c d) | |
813 | ((a b . _) | |
814 | #t))) | |
a215c159 AW |
815 | (seq (call . _) |
816 | (const #t))) | |
16d50b8e | 817 | |
02ebea53 AW |
818 | (pass-if-peval |
819 | ;; Mutability preserved. | |
820 | ((lambda (x y z) (list x y z)) 1 2 3) | |
ca128245 | 821 | (primcall list (const 1) (const 2) (const 3))) |
89436781 | 822 | |
d851e32f AW |
823 | (pass-if-peval |
824 | ;; Don't propagate effect-free expressions that operate on mutable | |
825 | ;; objects. | |
826 | (let* ((x (list 1)) | |
827 | (y (car x))) | |
828 | (set-car! x 0) | |
829 | y) | |
ca128245 AW |
830 | (let (x) (_) ((primcall list (const 1))) |
831 | (let (y) (_) ((primcall car (lexical x _))) | |
832 | (seq | |
ef9ffe5e | 833 | (primcall set-car! (lexical x _) (const 0)) |
d851e32f AW |
834 | (lexical y _))))) |
835 | ||
836 | (pass-if-peval | |
837 | ;; Don't propagate effect-free expressions that operate on objects we | |
838 | ;; don't know about. | |
839 | (let ((y (car x))) | |
840 | (set-car! x 0) | |
841 | y) | |
ca128245 AW |
842 | (let (y) (_) ((primcall car (toplevel x))) |
843 | (seq | |
ef9ffe5e | 844 | (primcall set-car! (toplevel x) (const 0)) |
d851e32f AW |
845 | (lexical y _)))) |
846 | ||
89436781 | 847 | (pass-if-peval |
b8392332 AW |
848 | ;; Infinite recursion |
849 | ((lambda (x) (x x)) (lambda (x) (x x))) | |
0353a2d8 AW |
850 | (let (x) (_) |
851 | ((lambda _ | |
b8392332 AW |
852 | (lambda-case |
853 | (((x) _ _ _ _ _) | |
ca128245 AW |
854 | (call (lexical x _) (lexical x _)))))) |
855 | (call (lexical x _) (lexical x _)))) | |
89436781 | 856 | |
11671bba LC |
857 | (pass-if-peval |
858 | ;; First order, aliased primitive. | |
859 | (let* ((x *) (y (x 1 2))) y) | |
860 | (const 2)) | |
861 | ||
862 | (pass-if-peval | |
863 | ;; First order, shadowed primitive. | |
864 | (begin | |
865 | (define (+ x y) (pk x y)) | |
866 | (+ 1 2)) | |
ca128245 | 867 | (seq |
11671bba LC |
868 | (define + |
869 | (lambda (_) | |
870 | (lambda-case | |
871 | (((x y) #f #f #f () (_ _)) | |
ca128245 AW |
872 | (call (toplevel pk) (lexical x _) (lexical y _)))))) |
873 | (call (toplevel +) (const 1) (const 2)))) | |
11671bba LC |
874 | |
875 | (pass-if-peval | |
876 | ;; First-order, effects preserved. | |
877 | (let ((x 2)) | |
878 | (do-something!) | |
879 | x) | |
ca128245 AW |
880 | (seq |
881 | (call (toplevel do-something!)) | |
11671bba LC |
882 | (const 2))) |
883 | ||
884 | (pass-if-peval | |
885 | ;; First order, residual bindings removed. | |
886 | (let ((x 2) (y 3)) | |
887 | (* (+ x y) z)) | |
ca128245 | 888 | (primcall * (const 5) (toplevel z))) |
11671bba LC |
889 | |
890 | (pass-if-peval | |
891 | ;; First order, with lambda. | |
892 | (define (foo x) | |
893 | (define (bar z) (* z z)) | |
894 | (+ x (bar 3))) | |
895 | (define foo | |
896 | (lambda (_) | |
897 | (lambda-case | |
898 | (((x) #f #f #f () (_)) | |
ca128245 | 899 | (primcall + (lexical x _) (const 9))))))) |
11671bba LC |
900 | |
901 | (pass-if-peval | |
902 | ;; First order, with lambda inlined & specialized twice. | |
903 | (let ((f (lambda (x y) | |
904 | (+ (* x top) y))) | |
905 | (x 2) | |
906 | (y 3)) | |
907 | (+ (* x (f x y)) | |
908 | (f something x))) | |
ca128245 AW |
909 | (primcall + |
910 | (primcall * | |
911 | (const 2) | |
912 | (primcall + ; (f 2 3) | |
913 | (primcall * | |
914 | (const 2) | |
915 | (toplevel top)) | |
916 | (const 3))) | |
917 | (let (x) (_) ((toplevel something)) ; (f something 2) | |
918 | ;; `something' is not const, so preserve order of | |
919 | ;; effects with a lexical binding. | |
920 | (primcall + | |
921 | (primcall * | |
922 | (lexical x _) | |
923 | (toplevel top)) | |
924 | (const 2))))) | |
b8392332 | 925 | |
11671bba | 926 | (pass-if-peval |
b8392332 AW |
927 | ;; First order, with lambda inlined & specialized 3 times. |
928 | (let ((f (lambda (x y) (if (> x 0) y x)))) | |
929 | (+ (f -1 0) | |
930 | (f 1 0) | |
931 | (f -1 y) | |
932 | (f 2 y) | |
933 | (f z y))) | |
ef9ffe5e AW |
934 | (primcall |
935 | + | |
936 | (const -1) ; (f -1 0) | |
937 | (primcall | |
938 | + | |
939 | (const 0) ; (f 1 0) | |
940 | (primcall | |
941 | + | |
942 | (seq (toplevel y) (const -1)) ; (f -1 y) | |
943 | (primcall | |
944 | + | |
945 | (toplevel y) ; (f 2 y) | |
946 | (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y) | |
947 | (if (primcall > (lexical x _) (const 0)) | |
948 | (lexical y _) | |
949 | (lexical x _)))))))) | |
11671bba LC |
950 | |
951 | (pass-if-peval | |
952 | ;; First order, conditional. | |
953 | (let ((y 2)) | |
954 | (lambda (x) | |
955 | (if (> y 0) | |
956 | (display x) | |
957 | 'never-reached))) | |
958 | (lambda () | |
959 | (lambda-case | |
960 | (((x) #f #f #f () (_)) | |
ca128245 | 961 | (call (toplevel display) (lexical x _)))))) |
11671bba LC |
962 | |
963 | (pass-if-peval | |
964 | ;; First order, recursive procedure. | |
965 | (letrec ((fibo (lambda (n) | |
966 | (if (<= n 1) | |
967 | n | |
968 | (+ (fibo (- n 1)) | |
969 | (fibo (- n 2))))))) | |
b8392332 AW |
970 | (fibo 4)) |
971 | (const 3)) | |
11671bba | 972 | |
1eb4886f AW |
973 | (pass-if-peval |
974 | ;; Don't propagate toplevel references, as intervening expressions | |
975 | ;; could alter their bindings. | |
976 | (let ((x top)) | |
977 | (foo) | |
978 | x) | |
979 | (let (x) (_) ((toplevel top)) | |
ca128245 AW |
980 | (seq |
981 | (call (toplevel foo)) | |
1eb4886f AW |
982 | (lexical x _)))) |
983 | ||
11671bba LC |
984 | (pass-if-peval |
985 | ;; Higher order. | |
986 | ((lambda (f x) | |
987 | (f (* (car x) (cadr x)))) | |
988 | (lambda (x) | |
989 | (+ x 1)) | |
990 | '(2 3)) | |
991 | (const 7)) | |
992 | ||
993 | (pass-if-peval | |
994 | ;; Higher order with optional argument (default value). | |
995 | ((lambda* (f x #:optional (y 0)) | |
996 | (+ y (f (* (car x) (cadr x))))) | |
997 | (lambda (x) | |
998 | (+ x 1)) | |
999 | '(2 3)) | |
1000 | (const 7)) | |
1001 | ||
1002 | (pass-if-peval | |
1003 | ;; Higher order with optional argument (caller-supplied value). | |
1004 | ((lambda* (f x #:optional (y 0)) | |
1005 | (+ y (f (* (car x) (cadr x))))) | |
1006 | (lambda (x) | |
1007 | (+ x 1)) | |
1008 | '(2 3) | |
1009 | 35) | |
1010 | (const 42)) | |
1011 | ||
05c9389e AW |
1012 | (pass-if-peval |
1013 | ;; Higher order with optional argument (side-effecting default | |
1014 | ;; value). | |
1015 | ((lambda* (f x #:optional (y (foo))) | |
1016 | (+ y (f (* (car x) (cadr x))))) | |
1017 | (lambda (x) | |
1018 | (+ x 1)) | |
1019 | '(2 3)) | |
ca128245 AW |
1020 | (let (y) (_) ((call (toplevel foo))) |
1021 | (primcall + (lexical y _) (const 7)))) | |
05c9389e AW |
1022 | |
1023 | (pass-if-peval | |
1024 | ;; Higher order with optional argument (caller-supplied value). | |
1025 | ((lambda* (f x #:optional (y (foo))) | |
1026 | (+ y (f (* (car x) (cadr x))))) | |
1027 | (lambda (x) | |
1028 | (+ x 1)) | |
1029 | '(2 3) | |
1030 | 35) | |
1031 | (const 42)) | |
1032 | ||
61237fa4 LC |
1033 | (pass-if-peval |
1034 | ;; Higher order. | |
1035 | ((lambda (f) (f x)) (lambda (x) x)) | |
b8392332 | 1036 | (toplevel x)) |
61237fa4 LC |
1037 | |
1038 | (pass-if-peval | |
1039 | ;; Bug reported at | |
1040 | ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>. | |
1041 | (let ((fold (lambda (f g) (f (g top))))) | |
1042 | (fold 1+ (lambda (x) x))) | |
ca128245 | 1043 | (primcall 1+ (toplevel top))) |
b8392332 | 1044 | |
2ae0775e | 1045 | (pass-if-peval |
72b2ca55 LC |
1046 | ;; Procedure not inlined when residual code contains recursive calls. |
1047 | ;; <http://debbugs.gnu.org/9542> | |
2ae0775e LC |
1048 | (letrec ((fold (lambda (f x3 b null? car cdr) |
1049 | (if (null? x3) | |
1050 | b | |
1051 | (f (car x3) (fold f (cdr x3) b null? car cdr)))))) | |
1052 | (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1)))) | |
1053 | (letrec (fold) (_) (_) | |
ca128245 | 1054 | (call (lexical fold _) |
72b2ca55 LC |
1055 | (primitive *) |
1056 | (toplevel x) | |
1057 | (const 1) | |
1058 | (primitive zero?) | |
1059 | (lambda () | |
1060 | (lambda-case | |
1061 | (((x1) #f #f #f () (_)) | |
1062 | (lexical x1 _)))) | |
1063 | (lambda () | |
1064 | (lambda-case | |
1065 | (((x2) #f #f #f () (_)) | |
ef9ffe5e | 1066 | (primcall 1- (lexical x2 _)))))))) |
2ae0775e LC |
1067 | |
1068 | (pass-if "inlined lambdas are alpha-renamed" | |
1eb4886f AW |
1069 | ;; In this example, `make-adder' is inlined more than once; thus, |
1070 | ;; they should use different gensyms for their arguments, because | |
1071 | ;; the various optimization passes assume uniquely-named variables. | |
239b4b2a LC |
1072 | ;; |
1073 | ;; Bug reported at | |
1074 | ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and | |
1075 | ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>. | |
1076 | (pmatch (unparse-tree-il | |
ef9ffe5e AW |
1077 | (peval (expand-primitives! |
1078 | (resolve-primitives! | |
1079 | (compile | |
1080 | '(let ((make-adder | |
1081 | (lambda (x) (lambda (y) (+ x y))))) | |
1082 | (cons (make-adder 1) (make-adder 2))) | |
1083 | #:to 'tree-il) | |
1084 | (current-module))))) | |
ca128245 AW |
1085 | ((primcall cons |
1086 | (lambda () | |
1087 | (lambda-case | |
1088 | (((y) #f #f #f () (,gensym1)) | |
1089 | (primcall + | |
1090 | (const 1) | |
1091 | (lexical y ,ref1))))) | |
1092 | (lambda () | |
1093 | (lambda-case | |
1094 | (((y) #f #f #f () (,gensym2)) | |
1095 | (primcall + | |
1096 | (const 2) | |
1097 | (lexical y ,ref2)))))) | |
1eb4886f AW |
1098 | (and (eq? gensym1 ref1) |
1099 | (eq? gensym2 ref2) | |
239b4b2a LC |
1100 | (not (eq? gensym1 gensym2)))) |
1101 | (_ #f))) | |
2ae0775e | 1102 | |
75170872 AW |
1103 | (pass-if-peval |
1104 | ;; Unused letrec bindings are pruned. | |
1105 | (letrec ((a (lambda () (b))) | |
1106 | (b (lambda () (a))) | |
1107 | (c (lambda (x) x))) | |
1108 | (c 10)) | |
1109 | (const 10)) | |
1110 | ||
1111 | (pass-if-peval | |
1112 | ;; Unused letrec bindings are pruned. | |
1113 | (letrec ((a (foo!)) | |
1114 | (b (lambda () (a))) | |
1115 | (c (lambda (x) x))) | |
1116 | (c 10)) | |
a215c159 AW |
1117 | (seq (call (toplevel foo!)) |
1118 | (const 10))) | |
75170872 | 1119 | |
11671bba LC |
1120 | (pass-if-peval |
1121 | ;; Higher order, mutually recursive procedures. | |
1122 | (letrec ((even? (lambda (x) | |
1123 | (or (= 0 x) | |
1124 | (odd? (- x 1))))) | |
1125 | (odd? (lambda (x) | |
75170872 | 1126 | (not (even? x))))) |
11671bba LC |
1127 | (and (even? 4) (odd? 7))) |
1128 | (const #t)) | |
1129 | ||
4bf9e928 AW |
1130 | (pass-if-peval |
1131 | ;; Memv with constants. | |
1132 | (memv 1 '(3 2 1)) | |
1133 | (const '(1))) | |
1134 | ||
1135 | (pass-if-peval | |
1136 | ;; Memv with non-constant list. It could fold but doesn't | |
1137 | ;; currently. | |
1138 | (memv 1 (list 3 2 1)) | |
a215c159 AW |
1139 | (primcall memv |
1140 | (const 1) | |
1141 | (primcall list (const 3) (const 2) (const 1)))) | |
4bf9e928 AW |
1142 | |
1143 | (pass-if-peval | |
1144 | ;; Memv with non-constant key, constant list, test context | |
1145 | (case foo | |
1146 | ((3 2 1) 'a) | |
1147 | (else 'b)) | |
1148 | (if (let (t) (_) ((toplevel foo)) | |
a215c159 | 1149 | (if (primcall eqv? (lexical t _) (const 3)) |
4bf9e928 | 1150 | (const #t) |
a215c159 | 1151 | (if (primcall eqv? (lexical t _) (const 2)) |
4bf9e928 | 1152 | (const #t) |
a215c159 | 1153 | (primcall eqv? (lexical t _) (const 1))))) |
4bf9e928 AW |
1154 | (const a) |
1155 | (const b))) | |
1156 | ||
1157 | (pass-if-peval | |
1158 | ;; Memv with non-constant key, empty list, test context. Currently | |
1159 | ;; doesn't fold entirely. | |
1160 | (case foo | |
1161 | (() 'a) | |
1162 | (else 'b)) | |
a215c159 | 1163 | (if (seq (toplevel foo) (const #f)) |
4bf9e928 AW |
1164 | (const a) |
1165 | (const b))) | |
1166 | ||
11671bba LC |
1167 | ;; |
1168 | ;; Below are cases where constant propagation should bail out. | |
1169 | ;; | |
1170 | ||
1171 | (pass-if-peval | |
1172 | ;; Non-constant lexical is not propagated. | |
1173 | (let ((v (make-vector 6 #f))) | |
1174 | (lambda (n) | |
1175 | (vector-set! v n n))) | |
1176 | (let (v) (_) | |
ca128245 | 1177 | ((call (toplevel make-vector) (const 6) (const #f))) |
11671bba LC |
1178 | (lambda () |
1179 | (lambda-case | |
1180 | (((n) #f #f #f () (_)) | |
ef9ffe5e AW |
1181 | (primcall vector-set! |
1182 | (lexical v _) (lexical n _) (lexical n _))))))) | |
11671bba | 1183 | |
89436781 LC |
1184 | (pass-if-peval |
1185 | ;; Mutable lexical is not propagated. | |
1186 | (let ((v (vector 1 2 3))) | |
1187 | (lambda () | |
1188 | v)) | |
1189 | (let (v) (_) | |
ca128245 | 1190 | ((primcall vector (const 1) (const 2) (const 3))) |
89436781 LC |
1191 | (lambda () |
1192 | (lambda-case | |
1193 | ((() #f #f #f () ()) | |
1194 | (lexical v _)))))) | |
1195 | ||
11671bba LC |
1196 | (pass-if-peval |
1197 | ;; Lexical that is not provably pure is not inlined nor propagated. | |
1198 | (let* ((x (if (> p q) (frob!) (display 'chbouib))) | |
1199 | (y (* x 2))) | |
1200 | (+ x x y)) | |
ca128245 AW |
1201 | (let (x) (_) ((if (primcall > (toplevel p) (toplevel q)) |
1202 | (call (toplevel frob!)) | |
1203 | (call (toplevel display) (const chbouib)))) | |
1204 | (let (y) (_) ((primcall * (lexical x _) (const 2))) | |
1205 | (primcall + | |
ef9ffe5e AW |
1206 | (lexical x _) |
1207 | (primcall + (lexical x _) (lexical y _)))))) | |
11671bba | 1208 | |
870dfc60 LC |
1209 | (pass-if-peval |
1210 | ;; Non-constant arguments not propagated to lambdas. | |
1211 | ((lambda (x y z) | |
1212 | (vector-set! x 0 0) | |
1213 | (set-car! y 0) | |
1214 | (set-cdr! z '())) | |
1215 | (vector 1 2 3) | |
1216 | (make-list 10) | |
1217 | (list 1 2 3)) | |
b8392332 | 1218 | (let (x y z) (_ _ _) |
ca128245 AW |
1219 | ((primcall vector (const 1) (const 2) (const 3)) |
1220 | (call (toplevel make-list) (const 10)) | |
1221 | (primcall list (const 1) (const 2) (const 3))) | |
1222 | (seq | |
ef9ffe5e AW |
1223 | (primcall vector-set! |
1224 | (lexical x _) (const 0) (const 0)) | |
1225 | (seq (primcall set-car! | |
1226 | (lexical y _) (const 0)) | |
1227 | (primcall set-cdr! | |
1228 | (lexical z _) (const ())))))) | |
870dfc60 | 1229 | |
11671bba | 1230 | (pass-if-peval |
1eb4886f AW |
1231 | (let ((foo top-foo) (bar top-bar)) |
1232 | (let* ((g (lambda (x y) (+ x y))) | |
1233 | (f (lambda (g x) (g x x)))) | |
1234 | (+ (f g foo) (f g bar)))) | |
1235 | (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar)) | |
ca128245 AW |
1236 | (primcall + |
1237 | (primcall + (lexical foo _) (lexical foo _)) | |
1238 | (primcall + (lexical bar _) (lexical bar _))))) | |
11671bba | 1239 | |
89436781 | 1240 | (pass-if-peval |
02ebea53 AW |
1241 | ;; Fresh objects are not turned into constants, nor are constants |
1242 | ;; turned into fresh objects. | |
89436781 LC |
1243 | (let* ((c '(2 3)) |
1244 | (x (cons 1 c)) | |
1245 | (y (cons 0 x))) | |
1246 | y) | |
ca128245 AW |
1247 | (let (x) (_) ((primcall cons (const 1) (const (2 3)))) |
1248 | (primcall cons (const 0) (lexical x _)))) | |
02ebea53 | 1249 | |
11671bba LC |
1250 | (pass-if-peval |
1251 | ;; Bindings mutated. | |
1252 | (let ((x 2)) | |
1253 | (set! x 3) | |
1254 | x) | |
1255 | (let (x) (_) ((const 2)) | |
ca128245 | 1256 | (seq |
11671bba LC |
1257 | (set! (lexical x _) (const 3)) |
1258 | (lexical x _)))) | |
1259 | ||
1260 | (pass-if-peval | |
1261 | ;; Bindings mutated. | |
1262 | (letrec ((x 0) | |
1263 | (f (lambda () | |
1264 | (set! x (+ 1 x)) | |
1265 | x))) | |
1266 | (frob f) ; may mutate `x' | |
1267 | x) | |
b8392332 | 1268 | (letrec (x) (_) ((const 0)) |
ca128245 AW |
1269 | (seq |
1270 | (call (toplevel frob) (lambda _ _)) | |
b8392332 | 1271 | (lexical x _)))) |
11671bba LC |
1272 | |
1273 | (pass-if-peval | |
1274 | ;; Bindings mutated. | |
1275 | (letrec ((f (lambda (x) | |
1276 | (set! f (lambda (_) x)) | |
1277 | x))) | |
1278 | (f 2)) | |
1279 | (letrec _ . _)) | |
1280 | ||
89436781 LC |
1281 | (pass-if-peval |
1282 | ;; Bindings possibly mutated. | |
1283 | (let ((x (make-foo))) | |
1284 | (frob! x) ; may mutate `x' | |
1285 | x) | |
ca128245 AW |
1286 | (let (x) (_) ((call (toplevel make-foo))) |
1287 | (seq | |
1288 | (call (toplevel frob!) (lexical x _)) | |
89436781 LC |
1289 | (lexical x _)))) |
1290 | ||
1e8ace33 LC |
1291 | (pass-if-peval |
1292 | ;; Inlining stops at recursive calls with dynamic arguments. | |
1293 | (let loop ((x x)) | |
1294 | (if (< x 0) x (loop (1- x)))) | |
1295 | (letrec (loop) (_) ((lambda (_) | |
1296 | (lambda-case | |
1297 | (((x) #f #f #f () (_)) | |
1298 | (if _ _ | |
ca128245 AW |
1299 | (call (lexical loop _) |
1300 | (primcall 1- | |
1301 | (lexical x _)))))))) | |
1302 | (call (lexical loop _) (toplevel x)))) | |
1e8ace33 LC |
1303 | |
1304 | (pass-if-peval | |
72b2ca55 | 1305 | ;; Recursion on the 2nd argument is fully evaluated. |
1eb4886f AW |
1306 | (let ((x (top))) |
1307 | (let loop ((x x) (y 10)) | |
1308 | (if (> y 0) | |
1309 | (loop x (1- y)) | |
1310 | (foo x y)))) | |
ca128245 | 1311 | (let (x) (_) ((call (toplevel top))) |
a215c159 | 1312 | (call (toplevel foo) (lexical x _) (const 0)))) |
72b2ca55 LC |
1313 | |
1314 | (pass-if-peval | |
1315 | ;; Inlining aborted when residual code contains recursive calls. | |
b8392332 | 1316 | ;; |
72b2ca55 | 1317 | ;; <http://debbugs.gnu.org/9542> |
1e8ace33 LC |
1318 | (let loop ((x x) (y 0)) |
1319 | (if (> y 0) | |
b8392332 AW |
1320 | (loop (1- x) (1- y)) |
1321 | (if (< x 0) | |
1322 | x | |
1323 | (loop (1+ x) (1+ y))))) | |
1e8ace33 LC |
1324 | (letrec (loop) (_) ((lambda (_) |
1325 | (lambda-case | |
1326 | (((x y) #f #f #f () (_ _)) | |
ca128245 AW |
1327 | (if (primcall > |
1328 | (lexical y _) (const 0)) | |
1e8ace33 | 1329 | _ _))))) |
ca128245 | 1330 | (call (lexical loop _) (toplevel x) (const 0)))) |
1e8ace33 | 1331 | |
11671bba LC |
1332 | (pass-if-peval |
1333 | ;; Infinite recursion: `peval' gives up and leaves it as is. | |
1334 | (letrec ((f (lambda (x) (g (1- x)))) | |
1335 | (g (lambda (x) (h (1+ x)))) | |
1336 | (h (lambda (x) (f x)))) | |
1337 | (f 0)) | |
02ebea53 AW |
1338 | (letrec _ . _)) |
1339 | ||
21524430 LC |
1340 | (pass-if-peval |
1341 | ;; Infinite recursion: all the arguments to `loop' are static, but | |
1342 | ;; unrolling it would lead `peval' to enter an infinite loop. | |
1343 | (let loop ((x 0)) | |
1344 | (and (< x top) | |
1345 | (loop (1+ x)))) | |
1346 | (letrec (loop) (_) ((lambda . _)) | |
a215c159 | 1347 | (call (lexical loop _) (const 0)))) |
21524430 | 1348 | |
75170872 AW |
1349 | (pass-if-peval |
1350 | ;; This test checks that the `start' binding is indeed residualized. | |
1351 | ;; See the `referenced?' procedure in peval's `prune-bindings'. | |
1352 | (let ((pos 0)) | |
1353 | (set! pos 1) ;; Cause references to `pos' to residualize. | |
1354 | (let ((here (let ((start pos)) (lambda () start)))) | |
1355 | (here))) | |
1356 | (let (pos) (_) ((const 0)) | |
a215c159 | 1357 | (seq |
75170872 AW |
1358 | (set! (lexical pos _) (const 1)) |
1359 | (let (here) (_) (_) | |
a215c159 | 1360 | (call (lexical here _)))))) |
75170872 AW |
1361 | |
1362 | (pass-if-peval | |
1363 | ;; FIXME: should this one residualize the binding? | |
1364 | (letrec ((a a)) | |
1365 | 1) | |
1366 | (const 1)) | |
1367 | ||
1368 | (pass-if-peval | |
1369 | ;; This is a fun one for peval to handle. | |
1370 | (letrec ((a a)) | |
1371 | a) | |
1372 | (letrec (a) (_) ((lexical a _)) | |
1373 | (lexical a _))) | |
1374 | ||
1375 | (pass-if-peval | |
1376 | ;; Another interesting recursive case. | |
1377 | (letrec ((a b) (b a)) | |
1378 | a) | |
1379 | (letrec (a) (_) ((lexical a _)) | |
1380 | (lexical a _))) | |
1381 | ||
1382 | (pass-if-peval | |
1383 | ;; Another pruning case, that `a' is residualized. | |
1384 | (letrec ((a (lambda () (a))) | |
1385 | (b (lambda () (a))) | |
1386 | (c (lambda (x) x))) | |
1387 | (let ((d (foo b))) | |
1388 | (c d))) | |
1389 | ||
1390 | ;; "b c a" is the current order that we get with unordered letrec, | |
1391 | ;; but it's not important to this test, so if it changes, just adapt | |
1392 | ;; the test. | |
1393 | (letrec (b c a) (_ _ _) | |
1394 | ((lambda _ | |
1395 | (lambda-case | |
1396 | ((() #f #f #f () ()) | |
a215c159 | 1397 | (call (lexical a _))))) |
75170872 AW |
1398 | (lambda _ |
1399 | (lambda-case | |
1400 | (((x) #f #f #f () (_)) | |
1401 | (lexical x _)))) | |
1402 | (lambda _ | |
1403 | (lambda-case | |
1404 | ((() #f #f #f () ()) | |
a215c159 | 1405 | (call (lexical a _)))))) |
75170872 AW |
1406 | (let (d) |
1407 | (_) | |
a215c159 AW |
1408 | ((call (toplevel foo) (lexical b _))) |
1409 | (call (lexical c _) (lexical d _))))) | |
75170872 AW |
1410 | |
1411 | (pass-if-peval | |
1412 | ;; In this case, we can prune the bindings. `a' ends up being copied | |
1413 | ;; because it is only referenced once in the source program. Oh | |
1414 | ;; well. | |
1415 | (letrec* ((a (lambda (x) (top x))) | |
1416 | (b (lambda () a))) | |
1417 | (foo (b) (b))) | |
a215c159 AW |
1418 | (call (toplevel foo) |
1419 | (lambda _ | |
1420 | (lambda-case | |
1421 | (((x) #f #f #f () (_)) | |
1422 | (call (toplevel top) (lexical x _))))) | |
1423 | (lambda _ | |
1424 | (lambda-case | |
1425 | (((x) #f #f #f () (_)) | |
1426 | (call (toplevel top) (lexical x _))))))) | |
75170872 | 1427 | |
02ebea53 AW |
1428 | (pass-if-peval |
1429 | ;; Constant folding: cons | |
1430 | (begin (cons 1 2) #f) | |
1431 | (const #f)) | |
1432 | ||
1433 | (pass-if-peval | |
1434 | ;; Constant folding: cons | |
1435 | (begin (cons (foo) 2) #f) | |
ca128245 | 1436 | (seq (call (toplevel foo)) (const #f))) |
02ebea53 AW |
1437 | |
1438 | (pass-if-peval | |
1439 | ;; Constant folding: cons | |
1440 | (if (cons 0 0) 1 2) | |
1441 | (const 1)) | |
1442 | ||
1443 | (pass-if-peval | |
1444 | ;; Constant folding: car+cons | |
1445 | (car (cons 1 0)) | |
1446 | (const 1)) | |
1447 | ||
1448 | (pass-if-peval | |
1449 | ;; Constant folding: cdr+cons | |
1450 | (cdr (cons 1 0)) | |
1451 | (const 0)) | |
1452 | ||
1453 | (pass-if-peval | |
1454 | ;; Constant folding: car+cons, impure | |
1455 | (car (cons 1 (bar))) | |
ca128245 | 1456 | (seq (call (toplevel bar)) (const 1))) |
02ebea53 AW |
1457 | |
1458 | (pass-if-peval | |
1459 | ;; Constant folding: cdr+cons, impure | |
1460 | (cdr (cons (bar) 0)) | |
ca128245 | 1461 | (seq (call (toplevel bar)) (const 0))) |
02ebea53 AW |
1462 | |
1463 | (pass-if-peval | |
1464 | ;; Constant folding: car+list | |
1465 | (car (list 1 0)) | |
1466 | (const 1)) | |
1467 | ||
1468 | (pass-if-peval | |
1469 | ;; Constant folding: cdr+list | |
1470 | (cdr (list 1 0)) | |
ca128245 | 1471 | (primcall list (const 0))) |
02ebea53 AW |
1472 | |
1473 | (pass-if-peval | |
1474 | ;; Constant folding: car+list, impure | |
1475 | (car (list 1 (bar))) | |
ca128245 | 1476 | (seq (call (toplevel bar)) (const 1))) |
02ebea53 AW |
1477 | |
1478 | (pass-if-peval | |
1479 | ;; Constant folding: cdr+list, impure | |
1480 | (cdr (list (bar) 0)) | |
ca128245 | 1481 | (seq (call (toplevel bar)) (primcall list (const 0)))) |
02ebea53 | 1482 | |
8ee0b28b | 1483 | (pass-if-peval |
8ee0b28b AW |
1484 | ;; Non-constant guards get lexical bindings. |
1485 | (dynamic-wind foo (lambda () bar) baz) | |
880e7948 AW |
1486 | (let (w u) (_ _) ((toplevel foo) (toplevel baz)) |
1487 | (dynwind (lexical w _) | |
1488 | (call (lexical w _)) | |
1489 | (toplevel bar) | |
1490 | (call (lexical u _)) | |
1491 | (lexical u _)))) | |
8ee0b28b AW |
1492 | |
1493 | (pass-if-peval | |
8ee0b28b AW |
1494 | ;; Constant guards don't need lexical bindings. |
1495 | (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz)) | |
1496 | (dynwind | |
1497 | (lambda () | |
1498 | (lambda-case | |
1499 | ((() #f #f #f () ()) (toplevel foo)))) | |
880e7948 | 1500 | (toplevel foo) |
8ee0b28b | 1501 | (toplevel bar) |
880e7948 | 1502 | (toplevel baz) |
8ee0b28b AW |
1503 | (lambda () |
1504 | (lambda-case | |
1505 | ((() #f #f #f () ()) (toplevel baz)))))) | |
1506 | ||
ea726a53 | 1507 | (pass-if-peval |
ea726a53 AW |
1508 | ;; Prompt is removed if tag is unreferenced |
1509 | (let ((tag (make-prompt-tag))) | |
1510 | (call-with-prompt tag | |
1511 | (lambda () 1) | |
1512 | (lambda args args))) | |
6c4ffe2b AW |
1513 | (const 1)) |
1514 | ||
1515 | (pass-if-peval | |
6c4ffe2b AW |
1516 | ;; Prompt is removed if tag is unreferenced, with explicit stem |
1517 | (let ((tag (make-prompt-tag "foo"))) | |
1518 | (call-with-prompt tag | |
1519 | (lambda () 1) | |
1520 | (lambda args args))) | |
1521 | (const 1)) | |
40be30c9 AW |
1522 | |
1523 | (pass-if-peval | |
40be30c9 AW |
1524 | ;; `while' without `break' or `continue' has no prompts and gets its |
1525 | ;; condition folded. Unfortunately the outer `lp' does not yet get | |
1526 | ;; elided. | |
1527 | (while #t #t) | |
1528 | (letrec (lp) (_) | |
1529 | ((lambda _ | |
1530 | (lambda-case | |
1531 | ((() #f #f #f () ()) | |
1532 | (letrec (loop) (_) | |
1533 | ((lambda _ | |
1534 | (lambda-case | |
1535 | ((() #f #f #f () ()) | |
ca128245 AW |
1536 | (call (lexical loop _)))))) |
1537 | (call (lexical loop _))))))) | |
1538 | (call (lexical lp _))))) | |
40be30c9 | 1539 | |
11671bba LC |
1540 | |
1541 | \f | |
f4aa0f10 LC |
1542 | (with-test-prefix "tree-il-fold" |
1543 | ||
1544 | (pass-if "empty tree" | |
1545 | (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark))) | |
1546 | (and (eq? mark | |
1547 | (tree-il-fold (lambda (x y) (set! leaf? #t) y) | |
1548 | (lambda (x y) (set! down? #t) y) | |
1549 | (lambda (x y) (set! up? #t) y) | |
1550 | mark | |
1551 | '())) | |
1552 | (not leaf?) | |
1553 | (not up?) | |
1554 | (not down?)))) | |
1555 | ||
1556 | (pass-if "lambda and application" | |
1557 | (let* ((leaves '()) (ups '()) (downs '()) | |
1558 | (result (tree-il-fold (lambda (x y) | |
1559 | (set! leaves (cons x leaves)) | |
1560 | (1+ y)) | |
1561 | (lambda (x y) | |
1562 | (set! downs (cons x downs)) | |
1563 | (1+ y)) | |
1564 | (lambda (x y) | |
1565 | (set! ups (cons x ups)) | |
1566 | (1+ y)) | |
1567 | 0 | |
1568 | (parse-tree-il | |
8a4ca0ea AW |
1569 | '(lambda () |
1570 | (lambda-case | |
1e2a8edb | 1571 | (((x y) #f #f #f () (x1 y1)) |
7081d4f9 AW |
1572 | (call (toplevel +) |
1573 | (lexical x x1) | |
1574 | (lexical y y1))) | |
8a4ca0ea | 1575 | #f)))))) |
f4aa0f10 LC |
1576 | (and (equal? (map strip-source leaves) |
1577 | (list (make-lexical-ref #f 'y 'y1) | |
1578 | (make-lexical-ref #f 'x 'x1) | |
1579 | (make-toplevel-ref #f '+))) | |
8a4ca0ea | 1580 | (= (length downs) 3) |
f4aa0f10 LC |
1581 | (equal? (reverse (map strip-source ups)) |
1582 | (map strip-source downs)))))) | |
4b856371 LC |
1583 | |
1584 | \f | |
1585 | ;;; | |
1586 | ;;; Warnings. | |
1587 | ;;; | |
1588 | ||
1589 | ;; Make sure we get English messages. | |
1590 | (setlocale LC_ALL "C") | |
1591 | ||
1592 | (define (call-with-warnings thunk) | |
1593 | (let ((port (open-output-string))) | |
a4060f67 LC |
1594 | (with-fluids ((*current-warning-port* port) |
1595 | (*current-warning-prefix* "")) | |
1596 | (thunk)) | |
4b856371 LC |
1597 | (let ((warnings (get-output-string port))) |
1598 | (string-tokenize warnings | |
1599 | (char-set-complement (char-set #\newline)))))) | |
1600 | ||
1601 | (define %opts-w-unused | |
1602 | '(#:warnings (unused-variable))) | |
1603 | ||
bcae9a98 LC |
1604 | (define %opts-w-unused-toplevel |
1605 | '(#:warnings (unused-toplevel))) | |
1606 | ||
f67ddf9d LC |
1607 | (define %opts-w-unbound |
1608 | '(#:warnings (unbound-variable))) | |
4b856371 | 1609 | |
ae03cf1f LC |
1610 | (define %opts-w-arity |
1611 | '(#:warnings (arity-mismatch))) | |
1612 | ||
75365375 LC |
1613 | (define %opts-w-format |
1614 | '(#:warnings (format))) | |
1615 | ||
ae03cf1f | 1616 | |
4b856371 LC |
1617 | (with-test-prefix "warnings" |
1618 | ||
1619 | (pass-if "unknown warning type" | |
1620 | (let ((w (call-with-warnings | |
1621 | (lambda () | |
1622 | (compile #t #:opts '(#:warnings (does-not-exist))))))) | |
1623 | (and (= (length w) 1) | |
1624 | (number? (string-contains (car w) "unknown warning"))))) | |
1625 | ||
1626 | (with-test-prefix "unused-variable" | |
1627 | ||
1628 | (pass-if "quiet" | |
1629 | (null? (call-with-warnings | |
1630 | (lambda () | |
1631 | (compile '(lambda (x y) (+ x y)) | |
1632 | #:opts %opts-w-unused))))) | |
1633 | ||
1634 | (pass-if "let/unused" | |
1635 | (let ((w (call-with-warnings | |
1636 | (lambda () | |
1637 | (compile '(lambda (x) | |
1638 | (let ((y (+ x 2))) | |
1639 | x)) | |
1640 | #:opts %opts-w-unused))))) | |
1641 | (and (= (length w) 1) | |
1642 | (number? (string-contains (car w) "unused variable `y'"))))) | |
1643 | ||
1644 | (pass-if "shadowed variable" | |
1645 | (let ((w (call-with-warnings | |
1646 | (lambda () | |
1647 | (compile '(lambda (x) | |
1648 | (let ((y x)) | |
1649 | (let ((y (+ x 2))) | |
1650 | (+ x y)))) | |
1651 | #:opts %opts-w-unused))))) | |
1652 | (and (= (length w) 1) | |
1653 | (number? (string-contains (car w) "unused variable `y'"))))) | |
1654 | ||
1655 | (pass-if "letrec" | |
1656 | (null? (call-with-warnings | |
1657 | (lambda () | |
1658 | (compile '(lambda () | |
1659 | (letrec ((x (lambda () (y))) | |
1660 | (y (lambda () (x)))) | |
1661 | y)) | |
1662 | #:opts %opts-w-unused))))) | |
1663 | ||
1664 | (pass-if "unused argument" | |
1665 | ;; Unused arguments should not be reported. | |
1666 | (null? (call-with-warnings | |
1667 | (lambda () | |
1668 | (compile '(lambda (x y z) #t) | |
3a1a883b LC |
1669 | #:opts %opts-w-unused))))) |
1670 | ||
1671 | (pass-if "special variable names" | |
1672 | (null? (call-with-warnings | |
1673 | (lambda () | |
1674 | (compile '(lambda () | |
1675 | (let ((_ 'underscore) | |
1676 | (#{gensym name}# 'ignore-me)) | |
1677 | #t)) | |
1678 | #:to 'assembly | |
f67ddf9d LC |
1679 | #:opts %opts-w-unused)))))) |
1680 | ||
bcae9a98 LC |
1681 | (with-test-prefix "unused-toplevel" |
1682 | ||
1683 | (pass-if "used after definition" | |
1684 | (null? (call-with-warnings | |
1685 | (lambda () | |
1686 | (let ((in (open-input-string | |
1687 | "(define foo 2) foo"))) | |
1688 | (read-and-compile in | |
1689 | #:to 'assembly | |
1690 | #:opts %opts-w-unused-toplevel)))))) | |
1691 | ||
1692 | (pass-if "used before definition" | |
1693 | (null? (call-with-warnings | |
1694 | (lambda () | |
1695 | (let ((in (open-input-string | |
1696 | "(define (bar) foo) (define foo 2) (bar)"))) | |
1697 | (read-and-compile in | |
1698 | #:to 'assembly | |
1699 | #:opts %opts-w-unused-toplevel)))))) | |
1700 | ||
1701 | (pass-if "unused but public" | |
1702 | (let ((in (open-input-string | |
1703 | "(define-module (test-suite tree-il x) #:export (bar)) | |
1704 | (define (bar) #t)"))) | |
1705 | (null? (call-with-warnings | |
1706 | (lambda () | |
1707 | (read-and-compile in | |
1708 | #:to 'assembly | |
1709 | #:opts %opts-w-unused-toplevel)))))) | |
1710 | ||
1711 | (pass-if "unused but public (more)" | |
1712 | (let ((in (open-input-string | |
1713 | "(define-module (test-suite tree-il x) #:export (bar)) | |
1714 | (define (bar) (baz)) | |
1715 | (define (baz) (foo)) | |
1716 | (define (foo) #t)"))) | |
1717 | (null? (call-with-warnings | |
1718 | (lambda () | |
1719 | (read-and-compile in | |
1720 | #:to 'assembly | |
1721 | #:opts %opts-w-unused-toplevel)))))) | |
1722 | ||
1723 | (pass-if "unused but define-public" | |
bcae9a98 LC |
1724 | (null? (call-with-warnings |
1725 | (lambda () | |
1726 | (compile '(define-public foo 2) | |
1727 | #:to 'assembly | |
1728 | #:opts %opts-w-unused-toplevel))))) | |
1729 | ||
1730 | (pass-if "used by macro" | |
1731 | ;; FIXME: See comment about macros at `unused-toplevel-analysis'. | |
1732 | (throw 'unresolved) | |
1733 | ||
1734 | (null? (call-with-warnings | |
1735 | (lambda () | |
1736 | (let ((in (open-input-string | |
1737 | "(define (bar) 'foo) | |
1738 | (define-syntax baz | |
1739 | (syntax-rules () ((_) (bar))))"))) | |
1740 | (read-and-compile in | |
1741 | #:to 'assembly | |
1742 | #:opts %opts-w-unused-toplevel)))))) | |
1743 | ||
1744 | (pass-if "unused" | |
1745 | (let ((w (call-with-warnings | |
1746 | (lambda () | |
1747 | (compile '(define foo 2) | |
1748 | #:to 'assembly | |
1749 | #:opts %opts-w-unused-toplevel))))) | |
1750 | (and (= (length w) 1) | |
1751 | (number? (string-contains (car w) | |
1752 | (format #f "top-level variable `~A'" | |
1753 | 'foo)))))) | |
1754 | ||
1755 | (pass-if "unused recursive" | |
1756 | (let ((w (call-with-warnings | |
1757 | (lambda () | |
1758 | (compile '(define (foo) (foo)) | |
1759 | #:to 'assembly | |
1760 | #:opts %opts-w-unused-toplevel))))) | |
1761 | (and (= (length w) 1) | |
1762 | (number? (string-contains (car w) | |
1763 | (format #f "top-level variable `~A'" | |
1764 | 'foo)))))) | |
1765 | ||
1766 | (pass-if "unused mutually recursive" | |
1767 | (let* ((in (open-input-string | |
1768 | "(define (foo) (bar)) (define (bar) (foo))")) | |
1769 | (w (call-with-warnings | |
1770 | (lambda () | |
1771 | (read-and-compile in | |
1772 | #:to 'assembly | |
1773 | #:opts %opts-w-unused-toplevel))))) | |
1774 | (and (= (length w) 2) | |
1775 | (number? (string-contains (car w) | |
1776 | (format #f "top-level variable `~A'" | |
1777 | 'foo))) | |
1778 | (number? (string-contains (cadr w) | |
1779 | (format #f "top-level variable `~A'" | |
3a1a883b LC |
1780 | 'bar)))))) |
1781 | ||
1782 | (pass-if "special variable names" | |
1783 | (null? (call-with-warnings | |
1784 | (lambda () | |
1785 | (compile '(define #{gensym name}# 'ignore-me) | |
1786 | #:to 'assembly | |
1787 | #:opts %opts-w-unused-toplevel)))))) | |
bcae9a98 | 1788 | |
f67ddf9d LC |
1789 | (with-test-prefix "unbound variable" |
1790 | ||
1791 | (pass-if "quiet" | |
1792 | (null? (call-with-warnings | |
1793 | (lambda () | |
1794 | (compile '+ #:opts %opts-w-unbound))))) | |
1795 | ||
1796 | (pass-if "ref" | |
1797 | (let* ((v (gensym)) | |
1798 | (w (call-with-warnings | |
1799 | (lambda () | |
1800 | (compile v | |
1801 | #:to 'assembly | |
1802 | #:opts %opts-w-unbound))))) | |
1803 | (and (= (length w) 1) | |
1804 | (number? (string-contains (car w) | |
1805 | (format #f "unbound variable `~A'" | |
1806 | v)))))) | |
1807 | ||
1808 | (pass-if "set!" | |
1809 | (let* ((v (gensym)) | |
1810 | (w (call-with-warnings | |
1811 | (lambda () | |
1812 | (compile `(set! ,v 7) | |
1813 | #:to 'assembly | |
1814 | #:opts %opts-w-unbound))))) | |
1815 | (and (= (length w) 1) | |
1816 | (number? (string-contains (car w) | |
1817 | (format #f "unbound variable `~A'" | |
1818 | v)))))) | |
1819 | ||
1820 | (pass-if "module-local top-level is visible" | |
1821 | (let ((m (make-module)) | |
1822 | (v (gensym))) | |
1823 | (beautify-user-module! m) | |
1824 | (compile `(define ,v 123) | |
1825 | #:env m #:opts %opts-w-unbound) | |
1826 | (null? (call-with-warnings | |
1827 | (lambda () | |
1828 | (compile v | |
1829 | #:env m | |
1830 | #:to 'assembly | |
1831 | #:opts %opts-w-unbound)))))) | |
1832 | ||
1833 | (pass-if "module-local top-level is visible after" | |
1834 | (let ((m (make-module)) | |
1835 | (v (gensym))) | |
1836 | (beautify-user-module! m) | |
1837 | (null? (call-with-warnings | |
1838 | (lambda () | |
1839 | (let ((in (open-input-string | |
1840 | "(define (f) | |
1841 | (set! chbouib 3)) | |
1842 | (define chbouib 5)"))) | |
b6d2306d LC |
1843 | (read-and-compile in |
1844 | #:env m | |
1845 | #:opts %opts-w-unbound))))))) | |
1846 | ||
bd36e901 LC |
1847 | (pass-if "optional arguments are visible" |
1848 | (null? (call-with-warnings | |
1849 | (lambda () | |
1850 | (compile '(lambda* (x #:optional y z) (list x y z)) | |
1851 | #:opts %opts-w-unbound | |
1852 | #:to 'assembly))))) | |
1853 | ||
1854 | (pass-if "keyword arguments are visible" | |
1855 | (null? (call-with-warnings | |
1856 | (lambda () | |
1857 | (compile '(lambda* (x #:key y z) (list x y z)) | |
1858 | #:opts %opts-w-unbound | |
1859 | #:to 'assembly))))) | |
1860 | ||
b6d2306d LC |
1861 | (pass-if "GOOPS definitions are visible" |
1862 | (let ((m (make-module)) | |
1863 | (v (gensym))) | |
1864 | (beautify-user-module! m) | |
1865 | (module-use! m (resolve-interface '(oop goops))) | |
1866 | (null? (call-with-warnings | |
1867 | (lambda () | |
1868 | (let ((in (open-input-string | |
1869 | "(define-class <foo> () | |
1870 | (bar #:getter foo-bar)) | |
1871 | (define z (foo-bar (make <foo>)))"))) | |
f67ddf9d LC |
1872 | (read-and-compile in |
1873 | #:env m | |
ae03cf1f LC |
1874 | #:opts %opts-w-unbound)))))))) |
1875 | ||
1876 | (with-test-prefix "arity mismatch" | |
1877 | ||
1878 | (pass-if "quiet" | |
1879 | (null? (call-with-warnings | |
1880 | (lambda () | |
1881 | (compile '(cons 'a 'b) #:opts %opts-w-arity))))) | |
1882 | ||
1883 | (pass-if "direct application" | |
1884 | (let ((w (call-with-warnings | |
1885 | (lambda () | |
1886 | (compile '((lambda (x y) (or x y)) 1 2 3 4 5) | |
1887 | #:opts %opts-w-arity | |
1888 | #:to 'assembly))))) | |
1889 | (and (= (length w) 1) | |
1890 | (number? (string-contains (car w) | |
1891 | "wrong number of arguments to"))))) | |
1892 | (pass-if "local" | |
1893 | (let ((w (call-with-warnings | |
1894 | (lambda () | |
1895 | (compile '(let ((f (lambda (x y) (+ x y)))) | |
1896 | (f 2)) | |
1897 | #:opts %opts-w-arity | |
1898 | #:to 'assembly))))) | |
1899 | (and (= (length w) 1) | |
1900 | (number? (string-contains (car w) | |
1901 | "wrong number of arguments to"))))) | |
1902 | ||
1903 | (pass-if "global" | |
1904 | (let ((w (call-with-warnings | |
1905 | (lambda () | |
1906 | (compile '(cons 1 2 3 4) | |
1907 | #:opts %opts-w-arity | |
1908 | #:to 'assembly))))) | |
1909 | (and (= (length w) 1) | |
1910 | (number? (string-contains (car w) | |
1911 | "wrong number of arguments to"))))) | |
1912 | ||
1913 | (pass-if "alias to global" | |
1914 | (let ((w (call-with-warnings | |
1915 | (lambda () | |
1916 | (compile '(let ((f cons)) (f 1 2 3 4)) | |
1917 | #:opts %opts-w-arity | |
1918 | #:to 'assembly))))) | |
1919 | (and (= (length w) 1) | |
1920 | (number? (string-contains (car w) | |
1921 | "wrong number of arguments to"))))) | |
1922 | ||
1923 | (pass-if "alias to lexical to global" | |
1924 | (let ((w (call-with-warnings | |
1925 | (lambda () | |
1926 | (compile '(let ((f number?)) | |
1927 | (let ((g f)) | |
1928 | (f 1 2 3 4))) | |
1929 | #:opts %opts-w-arity | |
1930 | #:to 'assembly))))) | |
1931 | (and (= (length w) 1) | |
1932 | (number? (string-contains (car w) | |
1933 | "wrong number of arguments to"))))) | |
1934 | ||
1935 | (pass-if "alias to lexical" | |
1936 | (let ((w (call-with-warnings | |
1937 | (lambda () | |
1938 | (compile '(let ((f (lambda (x y z) (+ x y z)))) | |
1939 | (let ((g f)) | |
1940 | (g 1))) | |
1941 | #:opts %opts-w-arity | |
1942 | #:to 'assembly))))) | |
1943 | (and (= (length w) 1) | |
1944 | (number? (string-contains (car w) | |
1945 | "wrong number of arguments to"))))) | |
1946 | ||
1947 | (pass-if "letrec" | |
1948 | (let ((w (call-with-warnings | |
1949 | (lambda () | |
1950 | (compile '(letrec ((odd? (lambda (x) (even? (1- x)))) | |
1951 | (even? (lambda (x) | |
1952 | (or (= 0 x) | |
1953 | (odd?))))) | |
1954 | (odd? 1)) | |
1955 | #:opts %opts-w-arity | |
1956 | #:to 'assembly))))) | |
1957 | (and (= (length w) 1) | |
1958 | (number? (string-contains (car w) | |
1959 | "wrong number of arguments to"))))) | |
1960 | ||
99480e11 LC |
1961 | (pass-if "case-lambda" |
1962 | (null? (call-with-warnings | |
1963 | (lambda () | |
1964 | (compile '(let ((f (case-lambda | |
1965 | ((x) 1) | |
1966 | ((x y) 2) | |
1967 | ((x y z) 3)))) | |
1968 | (list (f 1) | |
1969 | (f 1 2) | |
1970 | (f 1 2 3))) | |
1971 | #:opts %opts-w-arity | |
1972 | #:to 'assembly))))) | |
1973 | ||
1974 | (pass-if "case-lambda with wrong number of arguments" | |
1975 | (let ((w (call-with-warnings | |
1976 | (lambda () | |
1977 | (compile '(let ((f (case-lambda | |
1978 | ((x) 1) | |
1979 | ((x y) 2)))) | |
1980 | (f 1 2 3)) | |
1981 | #:opts %opts-w-arity | |
1982 | #:to 'assembly))))) | |
1983 | (and (= (length w) 1) | |
1984 | (number? (string-contains (car w) | |
1985 | "wrong number of arguments to"))))) | |
1986 | ||
1987 | (pass-if "case-lambda*" | |
1988 | (null? (call-with-warnings | |
1989 | (lambda () | |
1990 | (compile '(let ((f (case-lambda* | |
1991 | ((x #:optional y) 1) | |
1992 | ((x #:key y) 2) | |
1993 | ((x y #:key z) 3)))) | |
1994 | (list (f 1) | |
1995 | (f 1 2) | |
1996 | (f #:y 2) | |
1997 | (f 1 2 #:z 3))) | |
1998 | #:opts %opts-w-arity | |
1999 | #:to 'assembly))))) | |
2000 | ||
2001 | (pass-if "case-lambda* with wrong arguments" | |
2002 | (let ((w (call-with-warnings | |
2003 | (lambda () | |
2004 | (compile '(let ((f (case-lambda* | |
2005 | ((x #:optional y) 1) | |
2006 | ((x #:key y) 2) | |
2007 | ((x y #:key z) 3)))) | |
2008 | (list (f) | |
2009 | (f 1 #:z 3))) | |
2010 | #:opts %opts-w-arity | |
2011 | #:to 'assembly))))) | |
2012 | (and (= (length w) 2) | |
2013 | (null? (filter (lambda (w) | |
2014 | (not | |
2015 | (number? | |
2016 | (string-contains | |
2017 | w "wrong number of arguments to")))) | |
2018 | w))))) | |
2019 | ||
ae03cf1f LC |
2020 | (pass-if "local toplevel-defines" |
2021 | (let ((w (call-with-warnings | |
2022 | (lambda () | |
2023 | (let ((in (open-input-string " | |
2024 | (define (g x) (f x)) | |
2025 | (define (f) 1)"))) | |
2026 | (read-and-compile in | |
2027 | #:opts %opts-w-arity | |
2028 | #:to 'assembly)))))) | |
2029 | (and (= (length w) 1) | |
2030 | (number? (string-contains (car w) | |
2031 | "wrong number of arguments to"))))) | |
2032 | ||
2033 | (pass-if "global toplevel alias" | |
2034 | (let ((w (call-with-warnings | |
2035 | (lambda () | |
2036 | (let ((in (open-input-string " | |
2037 | (define f cons) | |
2038 | (define (g) (f))"))) | |
2039 | (read-and-compile in | |
2040 | #:opts %opts-w-arity | |
2041 | #:to 'assembly)))))) | |
2042 | (and (= (length w) 1) | |
2043 | (number? (string-contains (car w) | |
2044 | "wrong number of arguments to"))))) | |
2045 | ||
2046 | (pass-if "local toplevel overrides global" | |
2047 | (null? (call-with-warnings | |
2048 | (lambda () | |
2049 | (let ((in (open-input-string " | |
2050 | (define (cons) 0) | |
2051 | (define (foo x) (cons))"))) | |
2052 | (read-and-compile in | |
2053 | #:opts %opts-w-arity | |
af5ed549 LC |
2054 | #:to 'assembly)))))) |
2055 | ||
2056 | (pass-if "keyword not passed and quiet" | |
2057 | (null? (call-with-warnings | |
2058 | (lambda () | |
2059 | (compile '(let ((f (lambda* (x #:key y) y))) | |
2060 | (f 2)) | |
2061 | #:opts %opts-w-arity | |
2062 | #:to 'assembly))))) | |
2063 | ||
2064 | (pass-if "keyword passed and quiet" | |
2065 | (null? (call-with-warnings | |
2066 | (lambda () | |
2067 | (compile '(let ((f (lambda* (x #:key y) y))) | |
2068 | (f 2 #:y 3)) | |
2069 | #:opts %opts-w-arity | |
2070 | #:to 'assembly))))) | |
2071 | ||
2072 | (pass-if "keyword passed to global and quiet" | |
2073 | (null? (call-with-warnings | |
2074 | (lambda () | |
2075 | (let ((in (open-input-string " | |
2076 | (use-modules (system base compile)) | |
2077 | (compile '(+ 2 3) #:env (current-module))"))) | |
2078 | (read-and-compile in | |
2079 | #:opts %opts-w-arity | |
2080 | #:to 'assembly)))))) | |
2081 | ||
2082 | (pass-if "extra keyword" | |
2083 | (let ((w (call-with-warnings | |
2084 | (lambda () | |
2085 | (compile '(let ((f (lambda* (x #:key y) y))) | |
2086 | (f 2 #:Z 3)) | |
2087 | #:opts %opts-w-arity | |
2088 | #:to 'assembly))))) | |
2089 | (and (= (length w) 1) | |
2090 | (number? (string-contains (car w) | |
2091 | "wrong number of arguments to"))))) | |
2092 | ||
2093 | (pass-if "extra keywords allowed" | |
2094 | (null? (call-with-warnings | |
2095 | (lambda () | |
2096 | (compile '(let ((f (lambda* (x #:key y #:allow-other-keys) | |
2097 | y))) | |
2098 | (f 2 #:Z 3)) | |
2099 | #:opts %opts-w-arity | |
75365375 LC |
2100 | #:to 'assembly)))))) |
2101 | ||
2102 | (with-test-prefix "format" | |
2103 | ||
2104 | (pass-if "quiet (no args)" | |
2105 | (null? (call-with-warnings | |
2106 | (lambda () | |
2107 | (compile '(format #t "hey!") | |
2108 | #:opts %opts-w-format | |
2109 | #:to 'assembly))))) | |
2110 | ||
2111 | (pass-if "quiet (1 arg)" | |
2112 | (null? (call-with-warnings | |
2113 | (lambda () | |
2114 | (compile '(format #t "hey ~A!" "you") | |
2115 | #:opts %opts-w-format | |
2116 | #:to 'assembly))))) | |
2117 | ||
2118 | (pass-if "quiet (2 args)" | |
2119 | (null? (call-with-warnings | |
2120 | (lambda () | |
2121 | (compile '(format #t "~A ~A!" "hello" "world") | |
2122 | #:opts %opts-w-format | |
2123 | #:to 'assembly))))) | |
2124 | ||
60f01304 LC |
2125 | (pass-if "wrong port arg" |
2126 | (let ((w (call-with-warnings | |
2127 | (lambda () | |
2128 | (compile '(format 10 "foo") | |
2129 | #:opts %opts-w-format | |
2130 | #:to 'assembly))))) | |
2131 | (and (= (length w) 1) | |
2132 | (number? (string-contains (car w) | |
2133 | "wrong port argument"))))) | |
2134 | ||
2135 | (pass-if "non-literal format string" | |
2136 | (let ((w (call-with-warnings | |
2137 | (lambda () | |
2138 | (compile '(format #f fmt) | |
2139 | #:opts %opts-w-format | |
2140 | #:to 'assembly))))) | |
2141 | (and (= (length w) 1) | |
2142 | (number? (string-contains (car w) | |
2143 | "non-literal format string"))))) | |
2144 | ||
022ae742 LC |
2145 | (pass-if "non-literal format string using gettext" |
2146 | (null? (call-with-warnings | |
2147 | (lambda () | |
2148 | (compile '(format #t (_ "~A ~A!") "hello" "world") | |
2149 | #:opts %opts-w-format | |
2150 | #:to 'assembly))))) | |
2151 | ||
60f01304 LC |
2152 | (pass-if "wrong format string" |
2153 | (let ((w (call-with-warnings | |
2154 | (lambda () | |
2155 | (compile '(format #f 'not-a-string) | |
2156 | #:opts %opts-w-format | |
2157 | #:to 'assembly))))) | |
2158 | (and (= (length w) 1) | |
2159 | (number? (string-contains (car w) | |
2160 | "wrong format string"))))) | |
2161 | ||
2162 | (pass-if "wrong number of args" | |
2163 | (let ((w (call-with-warnings | |
2164 | (lambda () | |
2165 | (compile '(format "shbweeb") | |
2166 | #:opts %opts-w-format | |
2167 | #:to 'assembly))))) | |
2168 | (and (= (length w) 1) | |
2169 | (number? (string-contains (car w) | |
2170 | "wrong number of arguments"))))) | |
2171 | ||
e0697241 | 2172 | (pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n" |
75365375 LC |
2173 | (null? (call-with-warnings |
2174 | (lambda () | |
e0697241 | 2175 | (compile '(format some-port "~&~3_~~ ~\n~12they~%") |
75365375 LC |
2176 | #:opts %opts-w-format |
2177 | #:to 'assembly))))) | |
2178 | ||
2179 | (pass-if "one missing argument" | |
2180 | (let ((w (call-with-warnings | |
2181 | (lambda () | |
2182 | (compile '(format some-port "foo ~A~%") | |
2183 | #:opts %opts-w-format | |
2184 | #:to 'assembly))))) | |
2185 | (and (= (length w) 1) | |
2186 | (number? (string-contains (car w) | |
2187 | "expected 1, got 0"))))) | |
2188 | ||
022ae742 LC |
2189 | (pass-if "one missing argument, gettext" |
2190 | (let ((w (call-with-warnings | |
2191 | (lambda () | |
2192 | (compile '(format some-port (_ "foo ~A~%")) | |
2193 | #:opts %opts-w-format | |
2194 | #:to 'assembly))))) | |
2195 | (and (= (length w) 1) | |
2196 | (number? (string-contains (car w) | |
2197 | "expected 1, got 0"))))) | |
2198 | ||
75365375 LC |
2199 | (pass-if "two missing arguments" |
2200 | (let ((w (call-with-warnings | |
2201 | (lambda () | |
2202 | (compile '(format #f "foo ~10,2f and bar ~S~%") | |
2203 | #:opts %opts-w-format | |
2204 | #:to 'assembly))))) | |
2205 | (and (= (length w) 1) | |
2206 | (number? (string-contains (car w) | |
2207 | "expected 2, got 0"))))) | |
2208 | ||
2209 | (pass-if "one given, one missing argument" | |
2210 | (let ((w (call-with-warnings | |
2211 | (lambda () | |
2212 | (compile '(format #t "foo ~A and ~S~%" hey) | |
2213 | #:opts %opts-w-format | |
2214 | #:to 'assembly))))) | |
2215 | (and (= (length w) 1) | |
2216 | (number? (string-contains (car w) | |
2217 | "expected 2, got 1"))))) | |
2218 | ||
2219 | (pass-if "too many arguments" | |
2220 | (let ((w (call-with-warnings | |
2221 | (lambda () | |
2222 | (compile '(format #t "foo ~A~%" 1 2) | |
2223 | #:opts %opts-w-format | |
2224 | #:to 'assembly))))) | |
2225 | (and (= (length w) 1) | |
2226 | (number? (string-contains (car w) | |
2227 | "expected 1, got 2"))))) | |
2228 | ||
e0697241 LC |
2229 | (with-test-prefix "conditionals" |
2230 | (pass-if "literals" | |
2231 | (null? (call-with-warnings | |
2232 | (lambda () | |
2233 | (compile '(format #f "~A ~[foo~;bar~;baz~;~] ~10,2f" | |
2234 | 'a 1 3.14) | |
2235 | #:opts %opts-w-format | |
2236 | #:to 'assembly))))) | |
2237 | ||
2238 | (pass-if "literals with selector" | |
2239 | (let ((w (call-with-warnings | |
2240 | (lambda () | |
2241 | (compile '(format #f "~2[foo~;bar~;baz~;~] ~A" | |
2242 | 1 'dont-ignore-me) | |
2243 | #:opts %opts-w-format | |
2244 | #:to 'assembly))))) | |
2245 | (and (= (length w) 1) | |
2246 | (number? (string-contains (car w) | |
2247 | "expected 1, got 2"))))) | |
2248 | ||
2249 | (pass-if "escapes (exact count)" | |
2250 | (let ((w (call-with-warnings | |
2251 | (lambda () | |
2252 | (compile '(format #f "~[~a~;~a~]") | |
2253 | #:opts %opts-w-format | |
2254 | #:to 'assembly))))) | |
2255 | (and (= (length w) 1) | |
2256 | (number? (string-contains (car w) | |
2257 | "expected 2, got 0"))))) | |
2258 | ||
2259 | (pass-if "escapes with selector" | |
2260 | (let ((w (call-with-warnings | |
2261 | (lambda () | |
2262 | (compile '(format #f "~1[chbouib~;~a~]") | |
2263 | #:opts %opts-w-format | |
2264 | #:to 'assembly))))) | |
2265 | (and (= (length w) 1) | |
2266 | (number? (string-contains (car w) | |
2267 | "expected 1, got 0"))))) | |
2268 | ||
2269 | (pass-if "escapes, range" | |
2270 | (let ((w (call-with-warnings | |
2271 | (lambda () | |
2272 | (compile '(format #f "~[chbouib~;~a~;~2*~a~]") | |
2273 | #:opts %opts-w-format | |
2274 | #:to 'assembly))))) | |
2275 | (and (= (length w) 1) | |
2276 | (number? (string-contains (car w) | |
2277 | "expected 1 to 4, got 0"))))) | |
2278 | ||
2279 | (pass-if "@" | |
2280 | (let ((w (call-with-warnings | |
2281 | (lambda () | |
2282 | (compile '(format #f "~@[temperature=~d~]") | |
2283 | #:opts %opts-w-format | |
2284 | #:to 'assembly))))) | |
2285 | (and (= (length w) 1) | |
2286 | (number? (string-contains (car w) | |
2287 | "expected 1, got 0"))))) | |
2288 | ||
2289 | (pass-if "nested" | |
2290 | (let ((w (call-with-warnings | |
2291 | (lambda () | |
2292 | (compile '(format #f "~:[~[hey~;~a~;~va~]~;~3*~]") | |
2293 | #:opts %opts-w-format | |
2294 | #:to 'assembly))))) | |
2295 | (and (= (length w) 1) | |
2296 | (number? (string-contains (car w) | |
2297 | "expected 2 to 4, got 0"))))) | |
2298 | ||
8e6c15a6 LC |
2299 | (pass-if "unterminated" |
2300 | (let ((w (call-with-warnings | |
2301 | (lambda () | |
2302 | (compile '(format #f "~[unterminated") | |
2303 | #:opts %opts-w-format | |
2304 | #:to 'assembly))))) | |
2305 | (and (= (length w) 1) | |
2306 | (number? (string-contains (car w) | |
2307 | "unterminated conditional"))))) | |
2308 | ||
2309 | (pass-if "unexpected ~;" | |
2310 | (let ((w (call-with-warnings | |
2311 | (lambda () | |
2312 | (compile '(format #f "foo~;bar") | |
2313 | #:opts %opts-w-format | |
2314 | #:to 'assembly))))) | |
2315 | (and (= (length w) 1) | |
2316 | (number? (string-contains (car w) | |
2317 | "unexpected"))))) | |
2318 | ||
2319 | (pass-if "unexpected ~]" | |
2320 | (let ((w (call-with-warnings | |
2321 | (lambda () | |
2322 | (compile '(format #f "foo~]") | |
2323 | #:opts %opts-w-format | |
2324 | #:to 'assembly))))) | |
2325 | (and (= (length w) 1) | |
2326 | (number? (string-contains (car w) | |
2327 | "unexpected")))))) | |
e0697241 LC |
2328 | |
2329 | (pass-if "~{...~}" | |
2330 | (null? (call-with-warnings | |
2331 | (lambda () | |
2332 | (compile '(format #f "~A ~{~S~} ~A" | |
2333 | 'hello '("ladies" "and") | |
2334 | 'gentlemen) | |
2335 | #:opts %opts-w-format | |
2336 | #:to 'assembly))))) | |
2337 | ||
2338 | (pass-if "~{...~}, too many args" | |
2339 | (let ((w (call-with-warnings | |
2340 | (lambda () | |
2341 | (compile '(format #f "~{~S~}" 1 2 3) | |
2342 | #:opts %opts-w-format | |
2343 | #:to 'assembly))))) | |
2344 | (and (= (length w) 1) | |
2345 | (number? (string-contains (car w) | |
2346 | "expected 1, got 3"))))) | |
2347 | ||
2348 | (pass-if "~@{...~}" | |
2349 | (null? (call-with-warnings | |
2350 | (lambda () | |
2351 | (compile '(format #f "~@{~S~}" 1 2 3) | |
2352 | #:opts %opts-w-format | |
2353 | #:to 'assembly))))) | |
2354 | ||
2355 | (pass-if "~@{...~}, too few args" | |
2356 | (let ((w (call-with-warnings | |
2357 | (lambda () | |
2358 | (compile '(format #f "~A ~@{~S~}") | |
2359 | #:opts %opts-w-format | |
2360 | #:to 'assembly))))) | |
2361 | (and (= (length w) 1) | |
2362 | (number? (string-contains (car w) | |
2363 | "expected at least 1, got 0"))))) | |
2364 | ||
8e6c15a6 LC |
2365 | (pass-if "unterminated ~{...~}" |
2366 | (let ((w (call-with-warnings | |
2367 | (lambda () | |
2368 | (compile '(format #f "~{") | |
2369 | #:opts %opts-w-format | |
2370 | #:to 'assembly))))) | |
2371 | (and (= (length w) 1) | |
2372 | (number? (string-contains (car w) | |
2373 | "unterminated"))))) | |
2374 | ||
e0697241 LC |
2375 | (pass-if "~(...~)" |
2376 | (null? (call-with-warnings | |
2377 | (lambda () | |
2378 | (compile '(format #f "~:@(~A ~A~)" 'foo 'bar) | |
2379 | #:opts %opts-w-format | |
2380 | #:to 'assembly))))) | |
2381 | ||
2382 | (pass-if "~v" | |
2383 | (let ((w (call-with-warnings | |
2384 | (lambda () | |
2385 | (compile '(format #f "~v_foo") | |
2386 | #:opts %opts-w-format | |
2387 | #:to 'assembly))))) | |
2388 | (and (= (length w) 1) | |
2389 | (number? (string-contains (car w) | |
2390 | "expected 1, got 0"))))) | |
2391 | (pass-if "~v:@y" | |
2392 | (null? (call-with-warnings | |
2393 | (lambda () | |
2394 | (compile '(format #f "~v:@y" 1 123) | |
2395 | #:opts %opts-w-format | |
2396 | #:to 'assembly))))) | |
2397 | ||
2398 | ||
2399 | (pass-if "~*" | |
2400 | (let ((w (call-with-warnings | |
2401 | (lambda () | |
2402 | (compile '(format #f "~2*~a" 'a 'b) | |
2403 | #:opts %opts-w-format | |
2404 | #:to 'assembly))))) | |
2405 | (and (= (length w) 1) | |
2406 | (number? (string-contains (car w) | |
2407 | "expected 3, got 2"))))) | |
2408 | ||
2409 | (pass-if "~?" | |
2410 | (null? (call-with-warnings | |
2411 | (lambda () | |
2412 | (compile '(format #f "~?" "~d ~d" '(1 2)) | |
2413 | #:opts %opts-w-format | |
2414 | #:to 'assembly))))) | |
2415 | ||
2416 | (pass-if "complex 1" | |
2417 | (let ((w (call-with-warnings | |
2418 | (lambda () | |
2419 | (compile '(format #f | |
2420 | "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n" | |
2421 | 1 2 3 4 5 6) | |
2422 | #:opts %opts-w-format | |
2423 | #:to 'assembly))))) | |
2424 | (and (= (length w) 1) | |
2425 | (number? (string-contains (car w) | |
2426 | "expected 4, got 6"))))) | |
2427 | ||
2428 | (pass-if "complex 2" | |
2429 | (let ((w (call-with-warnings | |
2430 | (lambda () | |
2431 | (compile '(format #f | |
2432 | "~:(~A~) Commands~:[~; [abbrev]~]:~2%" | |
2433 | 1 2 3 4) | |
2434 | #:opts %opts-w-format | |
2435 | #:to 'assembly))))) | |
2436 | (and (= (length w) 1) | |
2437 | (number? (string-contains (car w) | |
2438 | "expected 2, got 4"))))) | |
2439 | ||
2440 | (pass-if "complex 3" | |
2441 | (let ((w (call-with-warnings | |
2442 | (lambda () | |
2443 | (compile '(format #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%") | |
2444 | #:opts %opts-w-format | |
2445 | #:to 'assembly))))) | |
2446 | (and (= (length w) 1) | |
2447 | (number? (string-contains (car w) | |
2448 | "expected 5, got 0"))))) | |
2449 | ||
75365375 LC |
2450 | (pass-if "ice-9 format" |
2451 | (let ((w (call-with-warnings | |
2452 | (lambda () | |
2453 | (let ((in (open-input-string | |
2454 | "(use-modules ((ice-9 format) | |
2455 | #:renamer (symbol-prefix-proc 'i9-))) | |
2456 | (i9-format #t \"yo! ~A\" 1 2)"))) | |
2457 | (read-and-compile in | |
2458 | #:opts %opts-w-format | |
2459 | #:to 'assembly)))))) | |
2460 | (and (= (length w) 1) | |
2461 | (number? (string-contains (car w) | |
2462 | "expected 1, got 2"))))) | |
2463 | ||
2464 | (pass-if "not format" | |
2465 | (null? (call-with-warnings | |
2466 | (lambda () | |
2467 | (compile '(let ((format chbouib)) | |
2468 | (format #t "not ~A a format string")) | |
2469 | #:opts %opts-w-format | |
2470 | #:to 'assembly))))))) |