| blob | 629710bbcfee82b3d400116745f344fb5882957a |
1 /* A nice test of the translator would be to translate the entire test suite ...
2 * In the meantime here are some tests to verify some specific bugs are fixed.
3 */
5 (kill (all), 0);
6 0;
8 /* There are various cases where (by design) translate and compile don't
9 * signal an error when a function fails to translate. So here we define
10 * translate_or_lose and compile_or_lose so we don't have to explicitly
11 * check the return values of translate and compile in every test.
12 *
13 * Passing `all' or `functions' is not supported. I'm not sure how much
14 * sense those make here for tests, but something could be added later if
15 * a test really wants them for some reason.
16 */
17 block ([translate : false],
18 local (make_tester),
19 make_tester (trfun) ::=
20 buildq ([trfun, name : concat (trfun, '_or_lose)],
21 (name (['fns]) :=
22 block ([ret : apply ('trfun, fns), losers : []],
23 if ret # fns then
24 /* Report failures in the same order as the given args */
25 (for f in fns do if not (member (f, ret)) then push (f, losers),
26 error ('trfun, "failed unexpectedly for", reverse (losers))),
27 fns),
28 /* Prevent this from being killed during kill(all), etc.
29 * We can remove this later if we're more precise about
30 * what we're killing throughout this file.
31 */
32 ?mfunction\-delete ('name, functions))),
33 make_tester (translate),
34 make_tester (compile),
35 0);
36 0;
38 /* SF [ 1728888 ] translator bugs: no mnot mprogn */
40 (foo (e,v) := block([vi], for vi in v while not(emptyp(e)) do (print(vi), e : rest(e)), e),
41 foo ([1, 2, 3], [a, b]));
42 [3];
44 (translate_or_lose (foo), foo ([1, 2, 3], [a, b]));
45 [3];
47 /* simpler function featuring mprogn and mnot */
49 (bar (x) := (x : 2*x, x : 3*x, not (x < 100)), bar (3));
50 false;
52 (translate_or_lose (bar), bar (3));
53 false;
55 /* SF [ 1646525 ] no function mdoin */
57 (try_me(x) := block([acc : 0], for i in x while i > 5 do acc : acc + i, acc),
58 try_me ([10, 9, 8, 7, 6, 5, 4, 5, 6, 7, 8, 9, 10]));
59 40;
61 (translate_or_lose (try_me), try_me ([10, 9, 8, 7, 6, 5, 4, 5, 6, 7, 8, 9, 10]));
62 40;
64 /* SF [ 1818645 ] Compiled maxima code containing $ARRAY gets a Lisp error. */
66 (test_array_comp (x) :=
67 block ([abc, i],
68 array (abc, 3),
69 for i thru 3 do (abc[i]: i*i),
70 abc[3] : x,
71 [abc, abc[3], abc[2]]),
72 test_array_comp (100));
73 [abc, 100, 4];
75 (translate_or_lose (test_array_comp), test_array_comp (100));
76 [abc, 100, 4];
78 /* SF [ 545794 ] Local Array does not compile properly */
80 (trial (a) :=
81 block ([myvar, i],
82 local(myvar),
83 array (myvar, 7),
84 for i : 0 thru 7 do myvar [i] : a^i,
85 [member (myvar, arrays), listarray (myvar)]),
86 trial (2));
87 [true, [1, 2, 4, 8, 16, 32, 64, 128]];
89 (translate_or_lose (trial), trial (2));
90 [true, [1, 2, 4, 8, 16, 32, 64, 128]];
92 /* This next test used to fail because local properties would leak out
93 * in the translated case. This test is expected to pass now. There
94 * are more local tests below for bug #2976.
95 */
97 [member (myvar, arrays), errcatch (listarray (myvar))];
98 [false, []];
100 /* for loop variable not special
101 * reported to mailing list 2009-08-13 "Why won't this compile?"
102 */
104 (kill (foo1, bar1),
105 foo1 () := bar1 + 1,
106 baz1 (n) := block ([S : 0], for bar1:0 thru n - 1 do S : S + foo1 (), S),
107 translate_or_lose (baz1),
108 baz1 (10));
109 55;
111 /* original example */
113 (fun(A,b,s,VF,x,h):= block
114 ([Y],
115 Y[1]: x,
116 for i:2 thru s do
117 Y[i]: x + h*(sum(A[i,j]*VF(Y[j]),j,1,i-1)),
118 x: expand(x + h*sum(b[i]*VF(Y[i]),i,1,s))),
119 A: matrix([1,1],[1,1]),
120 b: [1,1],
121 0);
122 0;
124 fun(A,b,2,f,[1,1],.01);
125 0.01*f(0.01*f([1,1])+[1,1])+0.01*f([1,1])+[1,1]$
127 (translate_or_lose (fun), fun(A,b,2,f,[1,1],.01));
128 0.01*f(0.01*f([1,1])+[1,1])+0.01*f([1,1])+[1,1]$
130 /* incorrect code emitted for call from translated function to untranslated
131 * SF bug # 2934064 "problem loading ezunits"
132 */
134 (f0001 (x) := [f0002 (x), f0003 (x)],
135 f0002 (x) := x,
136 f0003 (x) := x,
137 translate_or_lose (f0002, f0001),
138 f0001 (1));
139 [1, 1];
141 (translate_or_lose (f0003), f0001 (1));
142 [1, 1];
144 (compile_or_lose (f0003), f0001 (1));
145 [1, 1];
147 (compile_or_lose (f0003, f0002, f0001), f0001 (1));
148 [1, 1];
150 /* SF bug # 2938716 "too much evaluation in translated code"
151 */
153 (g0001 (x) := [g0002 (x), g0003 (x)],
154 g0002 (x) := x,
155 g0003 (x) := x,
156 translate_or_lose (g0002, g0001),
157 kill (aa, bb, cc),
158 aa : 'bb,
159 bb : 'cc,
160 g0001 (aa));
161 [bb, bb];
163 (translate_or_lose (g0003), g0001 (aa));
164 [bb, bb];
166 (compile_or_lose (g0003), g0001 (aa));
167 [bb, bb];
169 (compile_or_lose (g0003, g0002, g0001), g0001 (aa));
170 [bb, bb];
172 /* SF bug # 3035313 "some array references translated incorrectly"
173 */
175 (kill (aa1, aa3, bb1, bb3, cc1, cc3),
176 array (aa1, 15),
177 array (aa3, 12, 4, 6),
178 array (bb1, flonum, 15),
179 array (bb3, flonum, 5, 6, 7),
180 array (cc1, fixnum, 8),
181 array (cc3, fixnum, 6, 10, 4),
182 0);
183 0;
185 (kill (faa, gaa, fbb, gbb, fcc, gcc),
186 faa (n) := aa1[n] + aa3[n, n - 1, n - 2],
187 gaa (n) := (aa1[n] : 123, aa3[n, n - 1, n - 2] : 321),
188 fbb (n) := bb1[n] + bb3[n, n - 1, n - 2],
189 gbb (n) := (bb1[n] : 123, bb3[n, n - 1, n - 2] : 321),
190 fcc (n) := cc1[n] + cc3[n, n - 1, n - 2],
191 gcc (n) := (cc1[n] : 123, cc3[n, n - 1, n - 2] : 321),
192 0);
193 0;
195 [gaa (4), gbb (4), gcc (4)];
196 [321, 321, 321];
198 [faa (4), fbb (4), fcc (4)];
199 [444, 444, 444];
201 translate_or_lose (faa, gaa, fbb, gbb, fcc, gcc);
202 [faa, gaa, fbb, gbb, fcc, gcc];
204 [gaa (4), gbb (4), gcc (4)];
205 [321, 321, 321];
207 [faa (4), fbb (4), fcc (4)];
208 [444, 444, 444];
210 compile_or_lose (faa, gaa, fbb, gbb, fcc, gcc);
211 [faa, gaa, fbb, gbb, fcc, gcc];
213 [gaa (4), gbb (4), gcc (4)];
214 [321, 321, 321];
216 [faa (4), fbb (4), fcc (4)];
217 [444, 444, 444];
219 /* try same stuff again w/ undeclared arrays ...
220 * no type spec => only one kind of array
221 */
223 (kill (aa1, aa3, bb1, bb3, cc1, cc3),
224 ?fmakunbound (faa),
225 ?fmakunbound (fbb),
226 [gaa (4), faa (4)]);
227 [321, 444];
229 (translate_or_lose (faa, gaa), [gaa (4), faa (4)]);
230 [321, 444];
232 (compile_or_lose (faa, gaa), [gaa (4), faa (4)]);
233 [321, 444];
235 /* try same stuff again w/ Lisp arrays */
237 (kill (aa1, aa3, bb1, bb3, cc1, cc3),
238 map (?fmakunbound, [faa, fbb, fcc, gaa, gbb, gcc]),
239 aa1 : make_array (any, 15),
240 aa3 : make_array (any, 12, 4, 6),
241 bb1 : make_array (flonum, 15),
242 bb3 : make_array (flonum, 5, 6, 7),
243 cc1 : make_array (fixnum, 8),
244 cc3 : make_array (fixnum, 6, 10, 4),
245 0);
246 0;
248 [gaa (4), gbb (4), gcc (4)];
249 [321, 321, 321];
251 [faa (4), fbb (4), fcc (4)];
252 [444, 444, 444];
254 translate_or_lose (faa, gaa, fbb, gbb, fcc, gcc);
255 [faa, gaa, fbb, gbb, fcc, gcc];
257 [gaa (4), gbb (4), gcc (4)];
258 [321, 321, 321];
260 [faa (4), fbb (4), fcc (4)];
261 [444, 444, 444];
263 compile_or_lose (faa, gaa, fbb, gbb, fcc, gcc);
264 [faa, gaa, fbb, gbb, fcc, gcc];
266 [gaa (4), gbb (4), gcc (4)];
267 [321, 321, 321];
269 [faa (4), fbb (4), fcc (4)];
270 [444, 444, 444];
272 /* SF bug # 2569: "translate rat(1,x) and rat([1]) incorrect" */
274 (kill (f), f () := rat (x, x), translate_or_lose (f), f ());
275 ''(rat (x, x));
277 (kill (f), f () := rat ([1]), translate_or_lose (f), f ());
278 ''(rat ([1]));
280 (kill (foo, y1a, y1b, y2a, y2b),
281 foo(x) := block (mode_declare (x, float),
282 [tanh (x), tan (x), sech (x), sec (x), acos (x), acot (x), sin (x),
283 acsc (x), asinh (x), acsch (x), cosh (x), coth (x), realpart (x),
284 asec (x), asin (x), erf (x), log (x), cos (x), cot (x), csc (x),
285 sinh (x), csch (x), sqrt (x), exp (x)]),
286 0);
287 0;
289 y1a : foo (0.5);
290 [.4621171572600097,.5463024898437905,0.886818883970074,1.139493927324549,
291 1.047197551196597,1.107148717794091,0.479425538604203,
292 1.570796326794897-1.316957896924817*%i,.4812118250596035,1.44363547517881,
293 1.127625965206381,2.163953413738653,0.5,1.316957896924817*%i,
294 0.523598775598299,.5204998778130465,-.6931471805599453,.8775825618903728,
295 1.830487721712452,2.085829642933488,.5210953054937474,1.919034751334944,
296 .7071067811865476,1.648721270700128]$
298 y1b : foo (1.5);
299 [.9051482536448664,14.10141994717172,.4250960349422805,14.1368329029699,
300 .9624236501192069*%i,.5880026035475675,.9974949866040544,.7297276562269662,
301 1.194763217287109,.6251451172504168,2.352409615243247,1.104791392982512,1.5,
302 .8410686705679303,1.570796326794897-.9624236501192069*%i,.9661051464753108,
303 .4054651081081644,0.0707372016677029,.07091484430265245,1.002511304246725,
304 2.129279455094817,.4696424405952246,1.224744871391589,4.481689070338065]$
306 y1c : foo (1.0);
307 [0.7615941559557649,1.557407724654902,0.6480542736638855,
308 1.850815717680925,0.0,0.7853981633974483,0.8414709848078965,
309 1.570796326794897,0.881373587019543,0.881373587019543,
310 1.543080634815244,1.313035285499331,1.0,0.0,1.570796326794897,
311 0.8427007929497148,0.0,0.5403023058681398,0.6420926159343306,
312 1.188395105778121,1.175201193643801,0.8509181282393216,1.0,
313 2.718281828459045]$
315 (translate_or_lose (foo), y2a : foo (0.5), y2b : foo (1.5), 0);
316 0;
318 is (y1a = y2a);
319 true;
321 is (y1b = y2b);
322 true;
324 block ([tr_float_can_branch_complex : false],
325 translate_or_lose (foo),
326 y2c : foo (1.0),
327 0);
328 0;
330 is (y1c = y2c);
331 true;
333 /* verify that save/compfile/compile_file/translate_file preserves upper/lower case in symbol names */
335 /* save */
337 (kill (all),
338 foo (x) := my_foo * x,
339 Foo (x) := my_Foo * x,
340 FOO (x) := my_FOO * x,
341 [my_foo, my_Foo, my_FOO] : [123, 456, 789],
342 results : [foo (2), Foo (3), FOO (4)],
343 my_test () := is (results = [2*123, 3*456, 4*789]),
344 lisp_name : ssubst ("_", " ", build_info()@lisp_name),
345 lisp_filename : sconcat (maxima_tempdir, "/tmp-rtest_translator-save-", lisp_name, ".lisp"),
346 save (lisp_filename, values, functions),
347 kill (allbut (lisp_filename)),
348 load (lisp_filename),
349 my_test ());
350 true;
352 /* compfile */
354 (kill (all),
355 foo (x) := my_foo * x,
356 Foo (x) := my_Foo * x,
357 FOO (x) := my_FOO * x,
358 lisp_name : ssubst ("_", " ", build_info()@lisp_name),
359 lisp_filename : sconcat (maxima_tempdir, "/tmp-rtest_translator-compfile-", lisp_name, ".lisp"),
360 compfile (lisp_filename, functions),
361 kill (functions),
362 load (lisp_filename),
363 [my_foo, my_Foo, my_FOO] : [123, 456, 789],
364 results : [foo (2), Foo (3), FOO (4)],
365 my_test () := is (results = [2*123, 3*456, 4*789]),
366 my_test ());
367 true;
369 /* compile_file */
371 /* skip this test (and fail) if Lisp = ECL because stream i/o causes "stack smashing" error
372 * see: https://sourceforge.net/p/maxima/bugs/3291/
373 */
374 if build_info()@lisp_name # "ECL" then
375 (kill (all),
376 lisp_name : ssubst ("_", " ", build_info()@lisp_name),
377 maxima_filename : sconcat (maxima_tempdir, "/tmp-rtest_translator-compile_file-", lisp_name, ".mac"),
378 fasl_filename : sconcat (maxima_tempdir, "/tmp-rtest_translator-compile_file-", lisp_name, ".fasl"),
379 lisp_filename : sconcat (maxima_tempdir, "/tmp-rtest_translator-compile_file-", lisp_name, ".LISP"),
380 maxima_output : openw (maxima_filename),
381 maxima_content :
382 "foo (x) := my_foo * x;
383 Foo (x) := my_Foo * x;
384 FOO (x) := my_FOO * x;
385 [my_foo, my_Foo, my_FOO] : [123, 456, 789];
386 results : [foo (2), Foo (3), FOO (4)];
387 my_test () := is (results = [2*123, 3*456, 4*789]);",
388 printf (maxima_output, maxima_content),
389 close (maxima_output),
390 compile_file (maxima_filename, fasl_filename, lisp_filename),
391 kill (allbut (lisp_filename)),
392 load (lisp_filename),
393 my_test ());
394 true;
396 /* translate_file */
398 /* skip this test (and fail) if Lisp = ECL because stream i/o causes "stack smashing" error
399 * see: https://sourceforge.net/p/maxima/bugs/3291/
400 */
401 if build_info()@lisp_name # "ECL" then
402 (kill (all),
403 lisp_name : ssubst ("_", " ", build_info()@lisp_name),
404 maxima_filename : sconcat (maxima_tempdir, "/tmp-rtest_translator-translate_file-", lisp_name, ".mac"),
405 lisp_filename : sconcat (maxima_tempdir, "/tmp-rtest_translator-translate_file-", lisp_name, ".LISP"),
406 maxima_output : openw (maxima_filename),
407 maxima_content :
408 "foo (x) := my_foo * x;
409 Foo (x) := my_Foo * x;
410 FOO (x) := my_FOO * x;
411 [my_foo, my_Foo, my_FOO] : [123, 456, 789];
412 results : [foo (2), Foo (3), FOO (4)];
413 my_test () := is (results = [2*123, 3*456, 4*789]);",
414 printf (maxima_output, maxima_content),
415 close (maxima_output),
416 translate_file (maxima_filename, lisp_filename),
417 kill (allbut (lisp_filename)),
418 load (lisp_filename),
419 my_test ());
420 true;
422 /* Bug 2934:
424 Translating a literal exponent that comes out as a float shouldn't
425 produce assigned type any. This test runs the translation for a
426 trivial function that triggered the bug then looks in the unlisp
427 file (which contains messages from the translator) and checks that
428 there aren't any warnings.
429 */
430 /* skip this test (and fail) if Lisp = ECL because stream i/o causes "stack smashing" error
431 * see: https://sourceforge.net/p/maxima/bugs/3291/
432 */
433 if build_info()@lisp_name # "ECL" then
434 (kill (all),
435 lisp_name : ssubst ("_", " ", build_info()@lisp_name),
436 basename: sconcat (maxima_tempdir, "/tmp-rtest_translator-2934-", lisp_name),
437 maxima_filename : sconcat (basename, ".mac"),
438 lisp_filename : sconcat (basename, ".LISP"),
439 maxima_output : openw (maxima_filename),
440 maxima_content : "f () := block([y], mode_declare(y,float), y: 3^0.33, y)$",
441 printf (maxima_output, maxima_content),
442 close (maxima_output),
443 translate_file (maxima_filename, lisp_filename),
444 kill (allbut(basename)),
445 /* Any warning messages end up at .UNLISP */
446 block ([unlisp: openr (sconcat (basename, ".UNLISP")),
447 line, acc: []],
448 while stringp (line: readline(unlisp)) do
449 if is ("warning" = split(line, ":")[1]) then push(line, acc),
450 acc));
451 []$
453 /* makelist translated incorrectly
454 * SF bug #3083: "Error on compiling a working maxima function"
455 */
457 (kill(all),
458 f1(n) := makelist (1, n),
459 f2(n) := makelist (i^2, i, n),
460 f3(l) := makelist (i^3, i, l),
461 f4(n) := makelist (i^4, i, 1, n),
462 f5(m, n) := makelist (i^5, i, 1, n, m),
463 translate_or_lose(f1, f2, f3, f4, f5),
464 0);
465 0;
467 f1(5);
468 [1,1,1,1,1];
470 f2(5);
471 [1, 4, 9, 16, 25];
473 f3([1,2,3]);
474 [1, 8, 27];
476 f4(4);
477 [1, 16, 81, 256];
479 f5(2, 10);
480 [1, 243, 3125, 16807, 59049];
482 /* original function from bug report */
484 (ordersort(lis,vars,oper):=block([negsumdispflag:false,liss:lis,varlist:vars,temp], /*Does lexicographical sort */
485 for i:1 thru length(varlist) do (
486 for j:1 thru i do (
487 liss:sort(liss,lambda([x,y],apply("and",map(oper,makelist(part(x,2)[k],k,1,i)
488 ,makelist(part(y,2)[k],k,1,i)))))
489 )),liss),
490 translate_or_lose (ordersort),
491 [member ('transfun, properties (ordersort)),
492 ordersort([[-7,[0,2,1]],[3,[1,2,1]],[1,[0,4,1]],[6,[4,3,3]],[6,[4,4,3]],
493 [-7,[3,5,4]],[2,[0,0,5]],[-10,[2,2,5]],[-10,[3,4,7]],[7,[3,8,9]]],
494 [x,y,z],
495 ">=")]);
496 [true,
497 [[6,[4,4,3]],[6,[4,3,3]],[7,[3,8,9]],[-7,[3,5,4]],[-10,[3,4,7]],
498 [-10,[2,2,5]],[3,[1,2,1]],[1,[0,4,1]],[-7,[0,2,1]],[2,[0,0,5]]]];
500 /* 'define' translated incorrectly, reported to mailing list circa 2017-01-24 */
502 (kill(foo, bar, baz, quux, mumble, blurf, umm, f, x, y),
503 foo(y) := define(bar(x), x + y),
504 baz(f, y) := define(funmake(f, [x]), x + y),
505 quux() := (mumble(x) := 1 + x),
506 [foo(10), baz(blurf, 20), quux()]);
507 /* note that results match because rhs of ":=" isn't simplified */
508 [bar(x) := 10 + x, blurf(x) := 20 + x, mumble(x) := 1 + x];
510 [bar(5), blurf(5), mumble(5)];
511 [15, 25, 6];
513 (kill(bar, blurf, mumble),
514 translate_or_lose(foo, baz, quux),
515 [foo(11), baz(umm, 21), quux()]);
516 /* note that results match because rhs of ":=" isn't simplified */
517 [bar(x) := 11 + x, umm(x) := 21 + x, mumble(x) := 1 + x];
519 makelist (is (x # false), x, map (?fboundp, [foo, baz, quux])); /* test for generalized Boolean value */
520 [true, true, true];
522 [bar(5), umm(5), mumble(5)];
523 [16, 26, 6];
525 /* mailing list 2017-03-04: "An example that is broken by compile()"
526 * translated code tickles a bug elsewhere (bug not in translator)
527 */
529 (kill(fun, trigfunc, t1),
530 fun():=block([trigfunc],
531 trigfunc:lambda([cur],cur>t1),
532 apply('trigfunc,[1])),
533 0);
534 0;
536 /* I (Robert Dodier) believe this result should be trigfunc(1),
537 * but, in any event, interpreted and compiled code should agree.
538 * But if MAPPLY1 is ever changed, we can adjust these results.
539 */
540 fun();
541 1 > t1;
543 (compile_or_lose(fun), fun());
544 1 > t1;
546 (kill(fun, trigfunc, t1),
547 fun():=block([trigfunc],
548 trigfunc:lambda([cur],cur>t1),
549 apply(trigfunc,[1])),
550 0);
551 0;
553 fun();
554 1 > t1;
556 (compile_or_lose(fun), fun());
557 1 > t1;
559 /* Verify that we catch malformed lambda expressions during translation.
560 * More checks need to be added to the translator and more tests need to
561 * be added here.
562 */
564 /* no parameter list */
565 (kill (f),
566 f () := lambda (),
567 translate (f))$
568 [];
570 /* empty body */
571 (kill (f),
572 f () := lambda ([x]),
573 translate (f))$
574 [];
576 /* non-symbol in parameter list */
577 (kill (f),
578 f () := lambda ([42], 'foo),
579 translate (f))$
580 [];
582 /* misplaced "rest" parameter */
583 (kill (f),
584 f () := lambda ([[l], x], 'foo),
585 translate (f))$
586 [];
588 /* invalid "rest" parameter */
589 (kill (f),
590 f () := lambda ([[l1, l2]], 'foo),
591 translate (f))$
592 [];
594 /* attempting to bind a constant;
595 * now OK, after commit 0517895
596 */
597 block ([c, f],
598 local (c, f),
599 declare (c, constant),
600 f () := lambda ([c], c),
601 translate_or_lose (f))$
602 [f];
604 /* Verify that parameter/variable lists cannot contain duplicate variables.
605 *
606 * We only test a couple of cases here. Many more tests for non-translated
607 * code are in rtest2. Do we want to test them all here as well?
608 */
610 (kill(f),
611 f () := lambda ([x, [x]], x),
612 translate (f))$
613 [];
615 (kill(f),
616 f () := block ([x, x:'foo], x),
617 translate (f))$
618 [];
620 /* ensure that a null OPERATORS property doesn't interfere with
621 * translation of local variable used as a function name.
622 * This is the bug that caused failures in rtest_fractals when executed after run_testsuite.
623 */
625 (kill(aa, foobarbaz, mumbleblurf, hhh),
626 matchdeclare (aa, all),
627 tellsimp (mumbleblurf(aa), 1 - aa),
628 kill (mumbleblurf), /* as of 2018-01-28, this leaves (OPERATORS NIL) in property list */
629 hhh(mumbleblurf, u) := mumbleblurf(u),
630 foobarbaz(x) := 100 + x,
631 translate_or_lose (hhh),
632 hhh (foobarbaz, 11));
633 111;
635 /* SF bug report #3402: "Unbinding defined variable generates error in compiled functions" */
637 define_variable (zorble, 0, fixnum);
638 0;
640 (kill(f), f() := block ([zorble], 42), f());
641 42;
643 (translate_or_lose(f), f());
644 42;
646 /* bug reported to mailing list 2018-12-03: "error in compiling function with global variable" */
648 (test_f():= block( [a,b,c,d], niceindicespref:[a,b,c,d], disp("ciao"), return() ),
649 0);
650 0;
652 (test_f (), niceindicespref);
653 [a,b,c,d];
655 (reset (niceindicespref),
656 niceindicespref);
657 [i,j,k,l,m,n];
659 (translate_or_lose (test_f),
660 test_f (),
661 niceindicespref);
662 [a,b,c,d];
664 (reset (niceindicespref), 0);
665 0;
667 /* additional tests with variables which have ASSIGN property */
669 (set_error_stuff_permanently () :=
670 block (error_syms : '[myerr1, myerr2, myerr3], error_size : 40),
671 set_error_stuff_temporarily() :=
672 block([error_syms : '[myerror1, myerror2, myerror3], error_size : 55],
673 [error_syms, error_size]),
674 0);
675 0;
677 (reset (error_syms, error_size),
678 set_error_stuff_permanently (),
679 [error_syms, error_size]);
680 [[myerr1, myerr2, myerr3], 40];
682 (reset (error_syms, error_size),
683 translate_or_lose (set_error_stuff_permanently),
684 set_error_stuff_permanently (),
685 [error_syms, error_size]);
686 [[myerr1, myerr2, myerr3], 40];
688 (reset (error_syms, error_size),
689 set_error_stuff_temporarily());
690 [[myerror1, myerror2, myerror3], 55];
692 [error_syms, error_size];
693 [[errexp1, errexp2, errexp3], 60];
695 (translate_or_lose (set_error_stuff_temporarily),
696 set_error_stuff_temporarily());
697 [[myerror1, myerror2, myerror3], 55];
699 [error_syms, error_size];
700 [[errexp1, errexp2, errexp3], 60];
702 (kill(all), reset(), 0);
703 0;
705 /* SF bug #3412: "Bug when translating functions that contain an \"if\" (in my case an implicit if)" */
707 (f(x):=if cabs(1/(x+1)) < 1 then 1/(x+1) else 1,
708 f(x + %i*y));
709 if 1/sqrt(y^2+(x+1)^2) < 1 then 1/(%i*y+x+1) else 1;
711 makelist (f(xy[1] + %i*xy[2]), xy, [[0, 0], [0, 1], [1, 1], [1, 0], [0, 2], [2, 2], [2, 0]]);
712 [1, 1/(%i+1), 1/(%i+2), 1/2, 1/(2*%i+1), 1/(2*%i+3), 1/3]$
714 (compile_or_lose (f),
715 errcatch (f(x + %i*y)));
716 [];
718 '(f(x + %i*y));
719 f(x + %i*y);
721 makelist (f(xy[1] + %i*xy[2]), xy, [[0, 0], [0, 1], [1, 1], [1, 0], [0, 2], [2, 2], [2, 0]]);
722 [1, 1/(%i+1), 1/(%i+2), 1/2, 1/(2*%i+1), 1/(2*%i+3), 1/3]$
724 (if draw_version = 'draw_version then load (draw),
725 draw3d(contour='map,
726 proportional_axes=xy,
727 nticks=100,
728 contour_levels=20,
729 explicit('(f(x+%i*y)),x,-2,2,y,-2,2)),
730 0);
731 0;
733 /* nested if example -- note top-level "if" doesn't have an "else" clause, so the result is sometimes 'false' */
735 (g(a, b, c) := if a + b > c
736 then (if a > c
737 then (if b > c
738 then (a + b + c)
739 elseif b > c/2
740 then (a - b - c)
741 else (b - a - c))
742 else (a/2)),
743 0);
744 0;
746 (aa: [3,9/4,5/4,11/4,1,0,9/4,1/4,5/2,9/4,3,5/2],
747 bb: [3/2,3,1/4,3/4,5/2,7/4,5/2,3/4,1/2,3,13/4,7/2],
748 cc: [7/2,15/4,5/2,5/4,15/4,1,1/4,7/4,2,11/4,1/4,7/4],
749 map (g, aa, bb, cc));
750 [3/2,9/8,false,3/4,false,0,5,false,-4,9/8,13/2,31/4]$
752 (translate_or_lose (g),
753 map (g, aa, bb, cc));
754 [3/2,9/8,false,3/4,false,0,5,false,-4,9/8,13/2,31/4]$
756 errcatch (g(1, 1, z));
757 [];
759 /* SF bug #3556: "5.43.0 translate / compile error"
760 * Ensure that "if" within lambda is translated correctly.
761 * The fix for #3412 tickled this bug.
762 */
764 (kill (f),
765 f(x, m) := map (lambda ([u], if m > 0 then u^m), [x, 2*x, 3*x]),
766 0);
767 0;
769 is (?fboundp (f) # false);
770 false;
772 (kill (y),
773 [f(y, 2), f(y, -2)]);
774 [[y^2, 4*y^2, 9*y^2], [false, false, false]];
776 (kill (n),
777 errcatch (f(10, n)));
778 /* ensure that conditional expressions get simplified to expunge $FALSE ... sigh. */
779 ''([[if n > 0 then 10^n, if n > 0 then 20^n, if n > 0 then 30^n]]);
781 (translate_or_lose (f),
782 is (?fboundp (f) # false)); /* test for generalized Boolean value */
783 true;
785 [f(y, 2), f(y, -2)];
786 [[y^2, 4*y^2, 9*y^2], [false, false, false]];
788 errcatch (f(10, n));
789 [];
791 /* apply2 was translated incorrectly for several years. applyb2
792 * was translated incorrectly for decades.
793 */
795 (defrule (foorule, foo (), 1),
796 f () := apply2 ('(foo ()), foorule),
797 translate_or_lose (f),
798 f ());
799 1;
801 (defrule (barrule, bar (), 2),
802 g () := applyb2 ('(bar ()), barrule),
803 translate_or_lose (g),
804 g ());
805 2;
807 (kill (foorule, f, barrule, g), 0);
808 0;
810 /* atan and atan2 calls with float arguments were translated
811 * incorrectly for over a decade. atan always caused a lisp error
812 * and atan2 had a range between 0 and 2*%pi that was inconsistent
813 * with the interpreted and non-float cases (where the range is
814 * between -%pi and %pi).
815 */
817 (foo () := [atan2 (-1.0, -1.0), atan2 (-1.0, 1.0)],
818 translate_or_lose (foo),
819 foo ());
820 [-2.356194490192345, -0.7853981633974483];
822 (bar () := atan (-1.0),
823 translate_or_lose (bar),
824 bar ());
825 -0.7853981633974483;
827 (kill (foo, bar), 0);
828 0;
830 /* The translation of a signum call with a float argument was
831 * inconsistent when compared to the interpreted case and other
832 * translated cases. signum should return an integer or a float
833 * when given an integer or a float argument, respectively.
834 */
836 (foo () := [signum (0), signum (0.0),
837 signum (2), signum (2.0),
838 signum (-3), signum (-3.0)],
839 translate_or_lose (foo),
840 foo ());
841 [0, 0.0, 1, 1.0, -1, -1.0];
843 (kill (foo), 0);
844 0;
846 /* The translation of declare was broken for decades. It worked
847 * under Maclisp, but it had never worked under Common Lisp.
848 */
850 (foo () := declare (n, integer, [x, y], noninteger),
851 translate_or_lose (foo),
852 foo (),
853 [?kindp (n, integer),
854 ?kindp (n, noninteger),
855 ?kindp (x, integer),
856 ?kindp (x, noninteger),
857 ?kindp (y, integer),
858 ?kindp (y, noninteger)]);
859 [true, false, false, true, false, true];
861 (kill (foo, n, x, y), 0);
862 0;
864 /* If a variable was declared to be of mode rational, then a lisp
865 * error could occur during translation when attempting to convert
866 * it to a float.
867 */
869 (foo (x) := (mode_declare (x, rational), float (x)),
870 bar (y) := (mode_declare (y, rational), 1.0 + y),
871 translate_or_lose (foo, bar),
872 [foo (1/4), bar (1/2)]);
873 [0.25, 1.5];
875 (kill (foo, bar, x, y), 0);
876 0;
878 /* The translation of an atan2 call with one float and one rational
879 * argument was broken because the rational was not converted to a
880 * float before calling ATAN.
881 */
883 (foo () :=
884 [atan2 (0.0, -1/2),
885 atan2 (-1/2, 0.0),
886 atan2 (0.0, -1),
887 atan2 (1, 0.0)],
888 bar (y, x) := (mode_declare (x, float, y, rational), atan2 (y, x)),
889 l1 : [foo (), bar (1/3, 0.0)],
890 translate_or_lose (foo, bar),
891 l2 : [foo (), bar (1/3, 0.0)],
892 is (l1 = l2));
893 true;
895 (kill (foo, bar, x, y, l1, l2), 0);
896 0;
898 /* When attempting to apply float contagion to the arguments, some
899 * translations of max and min with mixed float and rational arguments
900 * were broken because the rationals were not converted to floats before
901 * calling MAX or MIN (like atan2 above). Also, due to implementation-
902 * dependent behavior in the underlying lisp regarding what to return
903 * from MAX and MIN, the wrong mode could be used during translation and
904 * some of the translations were possibly inconsistent with interpreted
905 * cases.
906 */
908 (foo (x) :=
909 (mode_declare (x, rational),
910 [max (), min (),
911 max (1), min (1),
912 max (1.0), min (1.0),
913 max (9/10), min (9/10),
914 max (x) , min (x),
915 max (0.0, 1), min (0.0, 1),
916 max (0, 1), min (0, 1),
917 max (1.0, 1), min (1.0, 1),
918 max (1, 1.0), min (1, 1.0),
919 max (2.0, 3.0), min (2.0, 3.0),
920 max (-1, 1/2), min (-1, 1/2),
921 max (3/4, 1/2), min (3/4, 1/2),
922 max (0.0, 1/2), min (0.0, 1/2),
923 max (0, x), min (0, x),
924 max (-1.0, x), min (-1.0, x),
925 max (5/6, x), min (5/6, x),
926 max (x, 1), min (x, 1)]),
927 l1 : foo (2/3),
928 translate_or_lose (foo),
929 l2 : foo (2/3),
930 is (l1 = l2));
931 true;
933 (kill (foo, x, l1, l2), 0);
934 0;
936 /* log and sqrt did not honor tr_float_can_branch_complex */
938 (foo (x) :=
939 (mode_declare (x, float),
940 [log (-1.0), log (x),
941 sqrt (-1.0), sqrt (x)]),
942 /* l1 is a list of Maxima complex numbers */
943 l1 : foo (-2.0),
944 some (lambda ([x], freeof (%i, x)), l1));
945 false;
947 block ([tr_float_can_branch_complex : false],
948 translate_or_lose (foo),
949 /* l2 is a list of lisp complex numbers because we told the
950 * translator to assume the return values of log and sqrt
951 * would not be complex, and it correctly returned the complex
952 * numbers returned by LOG and SQRT directly.
953 */
954 l2 : foo (-2.0),
955 [every (?complexp, l2),
956 every ("#", l1, l2)]);
957 [true,
958 true];
960 block ([tr_float_can_branch_complex : true],
961 translate_or_lose (foo),
962 /* l3 is a list of Maxima complex numbers because we told the
963 * translator to assume the return values of log and sqrt
964 * could be complex, and it converted the lisp complex numbers
965 * returned by LOG and SQRT to Maxima complex numbers.
966 */
967 l3 : foo (-2.0),
968 every (lambda ([x, y], cabs (x - y) < 1e-15), l1, l3));
969 true;
971 (kill (foo, x, l1, l2, l3), 0);
972 0;
974 /* The translations for evaluating = and # expressions to boolean
975 * values with one float argument and a different numerical argument
976 * (e.g. a fixnum) gave bogus results because the translator was
977 * incorrectly applying float contagion to the arguments.
978 */
980 (foo (s, w, x, y, z) :=
981 (mode_declare (w, number, x, fixnum, y, flonum),
982 [/* These translate to EQL comparisons */
983 is (1 = 1), is (1 # 1),
984 is (1 = 1.0), is (1 # 1.0),
985 is (1 = float (1)), is (1 # float (1)),
986 is (1.0 = float (1)), is (1.0 # float (1)),
987 is (w = 2), is (w # 2),
988 is (w = 2.0), is (w # 2.0),
989 is (x = 3), is (x # 3),
990 is (x = 3.0), is (x # 3.0),
991 is (x = float (3)), is (x # float (3)),
992 is (x = float (x)), is (x # float (x)),
993 is (y = 4), is (y # 4),
994 is (y = 4.0), is (y # 4.0),
995 is (y = float (4)), is (y # float (4)),
996 is (y = float (y)), is (y # float (y)),
997 /* These translate to LIKE comparisons */
998 is (z = 5), is (z # 5),
999 is (z = 5.0), is (z # 5.0),
1000 is (z = float (5)), is (z # float (5)),
1001 is (z = float (z)), is (z # float (z)),
1002 is (1/2 = 1/2), is (1/2 # 1/2),
1003 is (1/2 = rat (1/2)), is (1/2 # rat (1/2)),
1004 is (rat (1/2) = rat (1/2)), is (rat (1/2) # rat (1/2)),
1005 is (1/2 = 0.5), is (1/2 # 0.5),
1006 is (1/2 = float (1/2)), is (1/2 # float (1/2)),
1007 is (%i = %i), is (%i # %i),
1008 is (1 + %i = 1 + %i), is (1 + %i # 1 + %i),
1009 is (s = s), is (s # s),
1010 is (s = 'bar), is (s # 'bar),
1011 is (s = 1), is (s # 1),
1012 is (s = 1.0), is (s # 1.0),
1013 is (s = 1/2), is (s # 1/2),
1014 is ('f (0) = 'f (0)), is ('f (0) # 'f (0)),
1015 is ('g (s) = 'g (s)), is ('g (s) # 'g (s)),
1016 is ('h (w) = 'h (w)), is ('h (w) # 'h (w)),
1017 is ('i (x) = 'i (x)), is ('i (x) # 'i (x)),
1018 is ('j (y) = 'j (y)), is ('j (y) # 'j (y)),
1019 is ('k (z) = 'k (z)), is ('k (z) # 'k (z))]),
1020 l1 : foo ('bar, 2, 3, 4.0, 5),
1021 translate_or_lose (foo),
1022 l2 : foo ('bar, 2, 3, 4.0, 5),
1023 [every (lambda ([x], ?typep (x, ?boolean)), l2),
1024 is (l1 = l2)]);
1025 [true,
1026 true];
1028 (kill (foo, w, x, y, l1, l2), 0);
1029 0;
1031 /* Bug #3048: notequal is not translated properly
1032 *
1033 * notequal expressions were only generically translated like user
1034 * function calls and the use of notequal in translated code caused
1035 * a runtime warning about it being totally undefined. Also the
1036 * evaluation of notequal expressions to boolean values (via is, if,
1037 * etc.) were translated like the evaluation of an unknown predicate.
1038 */
1040 (assume (equal (a, b), notequal (c, d)),
1041 foo () :=
1042 [is (equal (1, 1)),
1043 is (notequal (1, 1)),
1044 is (equal (1, 1.0)),
1045 is (notequal (1, 1.0)),
1046 is (equal (1, 1.0b0)),
1047 is (notequal (1, 1.0b0)),
1048 is (equal (1/2, 0.5)),
1049 is (notequal (1/2, 0.5)),
1050 is (equal (1/2, 0.5b0)),
1051 is (notequal (1/2, 0.5b0)),
1052 is (equal (1, 2)),
1053 is (notequal (1, 2)),
1054 is (equal ('ind, 'ind)),
1055 is (notequal ('ind, 'ind)),
1056 is (equal ('und, 'und)),
1057 is (notequal ('und, 'und)),
1058 is (equal ('a, 'b)),
1059 is (notequal ('a, 'b)),
1060 is (equal ('c, 'd)),
1061 is (notequal ('c, 'd)),
1062 is (equal (x^2 - 1, (x + 1) * (x - 1))),
1063 is (notequal (x^2 - 1, (x + 1) * (x - 1)))],
1064 l1 : foo (),
1065 translate_or_lose (foo),
1066 l2 : foo (),
1067 [every (lambda ([x], ?typep (x, ?boolean)), l2),
1068 is (l1 = l2)]);
1069 [true,
1070 true];
1072 (kill (foo, l1, l2),
1073 forget (equal (a, b), notequal (c, d)),
1074 0);
1075 0;
1077 /* The translation of a call to random with a float argument could
1078 * cause the generation of bogus code because this always had the
1079 * mode of fixnum.
1080 */
1082 (foo (w, x, y, z) :=
1083 (mode_declare (w, fixnum, x, float),
1084 [[random (10),
1085 random (w),
1086 random (y)],
1087 [random (1.0),
1088 random (x),
1089 random (z),
1090 random (x) / 2,
1091 random (z) / 2,
1092 1 / (1 + random (x))],
1093 [random (10) / 2,
1094 random (w) / 3,
1095 random (y) / 4,
1096 1 / (1 + random (w)),
1097 1 / (1 + random (y))]]),
1098 translate_or_lose (foo),
1099 l : foo (50, 5.0, 100, 10.0),
1100 [every (integerp, first (l)),
1101 every (floatnump, second (l)),
1102 every (ratnump, third (l))]);
1103 [true,
1104 true,
1105 true];
1107 (kill (foo, w, x, l), 0);
1108 0;
1110 /* acosh, asech, atanh and acoth now have special translations for
1111 * float arguments. These all honor tr_float_can_branch_complex.
1112 */
1114 (foo (x) :=
1115 (mode_declare (x, float),
1116 [acosh (x), asech (x), atanh (x)]),
1117 bar (x) :=
1118 (mode_declare (x, float),
1119 [acoth (x)]),
1120 /* l1 is a list of Maxima complex numbers */
1121 l1 : append (foo (-3.0), foo (-2.0), bar (-0.5), bar (0.5)),
1122 some (lambda ([x], freeof (%i, x)), l1));
1123 false;
1125 block ([tr_float_can_branch_complex : false],
1126 translate_or_lose (foo, bar),
1127 /* l2 is a list of lisp complex numbers because we told the
1128 * translator to assume the return values would not be complex,
1129 * and it correctly returned the lisp complex numbers directly.
1130 */
1131 l2 : append (foo (-3.0), foo (-2.0), bar (-0.5), bar (0.5)),
1132 [every (?complexp, l2),
1133 every ("#", l1, l2),
1134 every ("=", l1, map (?complexify, l2))]);
1135 [true,
1136 true,
1137 true];
1139 block ([tr_float_can_branch_complex : true],
1140 translate_or_lose (foo, bar),
1141 /* l3 is a list of Maxima complex numbers because we told the
1142 * translator to assume the return values could be complex, and
1143 * it converted the lisp complex numbers to Maxima complex numbers.
1144 */
1145 l3 : append (foo (-3.0), foo (-2.0), bar (-0.5), bar (0.5)),
1146 every ("=", l1, l3));
1147 true;
1149 (kill (foo, bar, x, l1, l2, l3), 0);
1150 0;
1152 /* Bug #3642: Lisp error when translating assume
1153 *
1154 * Translating an assume call with an atomic argument would cause a
1155 * lisp error during translation.
1156 */
1158 (foo () :=
1159 block ([ctx : supcontext (),
1160 x : a > 0,
1161 y : b > 0,
1162 r],
1163 assume (x, y, equal (c, 0)),
1164 r : [is (a > 0), is (b < 0), is (equal (c, 0))],
1165 killcontext (ctx),
1166 r),
1167 translate_or_lose (foo),
1168 foo ());
1169 [true, false, true];
1171 (kill (foo), 0);
1172 0;
1174 /* The translation of errcatch was broken because the mode of the
1175 * whole form was always assumed to be the same as the mode of the
1176 * last subform. Since errcatch always yields a list, lisp errors
1177 * could easily occur.
1178 */
1180 (foo () :=
1181 block ([listarith : true],
1182 [errcatch (1),
1183 1 + errcatch (2),
1184 1.0 * errcatch (2.0),
1185 errcatch (error ("oops")),
1186 errcatch (?error ("oops")),
1187 errcatch (1 / 0)]),
1188 translate_or_lose (foo),
1189 foo ());
1190 [[1],
1191 [3],
1192 [2.0],
1193 [],
1194 [],
1195 []];
1197 (kill (foo), 0);
1198 0;
1200 /* Attempting to translate multiple functions containing local would
1201 * cause an error. Similarly, translating the same function multiple
1202 * times would cause an error if that function contained local.
1203 */
1205 (foo () := local (), /* just something with local (not within a block) */
1206 bar () := local (), /* something else with local (not within a block) */
1207 translate_or_lose (foo),
1208 translate_or_lose (bar),
1209 translate_or_lose (foo, bar));
1210 [foo, bar];
1212 (kill (foo, bar), 0);
1213 0;
1215 /* Bug #2976: "local" doesn't work in translated code
1216 *
1217 * For decades no attempt was being made to clean up any local
1218 * properties.
1219 */
1221 /* The internal LOCLIST used by local should be empty right now */
1222 ?null (?loclist);
1223 true;
1225 (f0 () := "one",
1226 foo1 () :=
1227 (local (f0),
1228 f0 () := "two",
1229 f0 ()),
1230 translate_or_lose (foo1),
1231 block ([v : foo1 ()],
1232 [f0 (), v]));
1233 ["one", "two"];
1235 (kill (f0, foo1), 0);
1236 0;
1238 (arr1 [0] : "three",
1239 foo2 () :=
1240 block ([g : lambda ([],
1241 local (arr1, arr2),
1242 arr1 [0] : "four",
1243 arr2 [5] : "five",
1244 [arr1 [0],
1245 arr2 [5],
1246 arrayinfo (arr2)])],
1247 apply (g, [])),
1248 translate_or_lose (foo2),
1249 block ([v : foo2 ()],
1250 [arr1 [0],
1251 v,
1252 errcatch (arrayinfo (arr2))]));
1253 ["three",
1254 ["four",
1255 "five",
1256 [hashed, 1, [5]]],
1257 []];
1259 (kill (arr1, foo2), 0);
1260 0;
1262 (foo3 (n) :=
1263 (local (h),
1264 h () := n + 1,
1265 if n = 10 then
1266 n
1267 else
1268 foo3 (h ())),
1269 translate_or_lose (foo3),
1270 foo3 (0));
1271 10;
1273 (kill (foo3), 0);
1274 0;
1276 /* The internal LOCLIST used by local should be empty right now */
1277 ?null (?loclist);
1278 true;
1280 /* The fpprintprec itself is not important in this test. I'm
1281 * just picking something that has an ASSIGN property because
1282 * that's a separate internal case in the translator.
1283 *
1284 * This test is ugly, but it's testing different cases and
1285 * their interactions.
1286 */
1287 block ([v],
1288 local (f1, f2, arr),
1289 f1 () := 0,
1290 f2 () := 123,
1291 arr [1] : "a",
1292 bar (fpprintprec) :=
1293 (local (f1, arr),
1294 fpprintprec : 5,
1295 f1 () := 42,
1296 arr [1] : "b",
1297 [block (
1298 local (f2, arr),
1299 f2 () := 69,
1300 arr [1] : "c",
1301 [f1 (), f2 (), arr [1]]),
1302 [f1 (), f2 (), arr [1]]]),
1303 translate_or_lose (bar),
1304 v : bar (3),
1305 [is (?get ('fpprintprec, '?assign) = false),
1306 v,
1307 [f1 (), f2 (), arr [1]]]);
1308 [false,
1309 [[42, 69, "c"],
1310 [42, 123, "b"]],
1311 [0, 123, "a"]];
1313 (kill (bar), 0);
1314 0;
1316 /* This is testing to make sure there are no bad interactions
1317 * between the usual local cleanup and errcatch cleanup (this
1318 * also mixes the interpreted and translated cases). This test
1319 * is also ugly.
1320 *
1321 * The original implementation of local properties (from decades
1322 * ago) not only failed to clean up local properties at all, but
1323 * it wasn't even setting up the internal state to keep up with
1324 * these properties correctly. An initial attempt at fixing bug
1325 * #2976 made this problem clear because with that it was easy to
1326 * cause an infinite loop during certain things like errcatch
1327 * cleanup.
1328 */
1329 block ([translate : false,
1330 vi, vt],
1331 local (f3),
1332 f3 () := -10,
1333 baz1 () :=
1334 (error ("oops 1"),
1335 local (f4),
1336 f4 () := 0),
1337 baz2 () :=
1338 (local (f5),
1339 f5 () := 1,
1340 error ("oops 2")),
1341 translate_or_lose (baz1, baz2),
1342 baz_test () :=
1343 [block (
1344 local (f3),
1345 f3 () := -1,
1346 errcatch (baz1 ()),
1347 f3 ()),
1348 block (
1349 local (f3),
1350 f3 () := -2,
1351 errcatch (baz2 ()),
1352 f3 ())],
1353 vi : baz_test (),
1354 translate_or_lose (baz_test),
1355 vt : baz_test (),
1356 [vi,
1357 vt,
1358 is (f3 () = -10),
1359 is (f4 () = 0),
1360 is (f5 () = 1)]);
1361 [[-1, -2],
1362 [-1, -2],
1363 true,
1364 false,
1365 false];
1367 /* The internal LOCLIST used by local should be empty right now */
1368 ?null (?loclist);
1369 true;
1371 (kill (baz1, baz2, baz_test), 0);
1372 0;
1374 /***** This ends the bug #2976 tests *****/
1376 /* compile wasn't always compiling the correct function
1377 *
1378 * This test not only depends on the internal details of how certain
1379 * functions are currently translated, but it also depends on internal
1380 * details about how DEFMFUN defines functions. This also doesn't
1381 * really test that the correct function gets compiled because the
1382 * lisp implementation could have just compiled it itself anyway. Ugh.
1383 */
1385 (foo () := 1,
1386 compile_or_lose (foo),
1387 ?compiled\-function\-p (?symbol\-function (?get (foo, ?impl\-name))));
1388 true;
1390 (kill (foo), 0);
1391 0;
1393 /* Some internal function definitions and compiler macros were not
1394 * being cleaned up, and this could cause confusing and bogus results
1395 * when an outdated compiler macro was being used.
1396 *
1397 * Specifically one problem we had involved translating a function,
1398 * redefining it and then translating the new definition. The internal
1399 * function and compiler macro from the original function could be used
1400 * when compiling calls to the new function if they were not overwritten.
1401 *
1402 * This all depended on lisp implementation-dependent behavior because
1403 * implementations are not required to ever use compiler macros. Ugh.
1404 *
1405 * This test also depends on internal details of how certain functions
1406 * are currently translated. Double ugh.
1407 */
1409 (foo () := 0,
1410 translate_or_lose (foo),
1411 kill (foo),
1412 foo ([l]) := l,
1413 translate_or_lose (foo),
1414 test1 () := foo (),
1415 test2 () := foo (1, 2, 3),
1416 compile_or_lose (test1, test2),
1417 /* Previously we observed test1 returning 0 and test2 causing a lisp
1418 * error because the compiler macro and old internal function from
1419 * the first foo were being used.
1420 */
1421 [test1 (), test2 ()]);
1422 [[], [1, 2, 3]];
1424 (kill (foo, test1, test2), 0);
1425 0;
1427 /* https://stackoverflow.com/questions/64631208/compilation-global-variables-with-warning
1428 *
1429 * First verify that error_syms and niceindicespref assignments work as expected.
1430 */
1432 kill (aa, bb, cc);
1433 done;
1435 errcatch (error_syms: 123);
1436 [];
1438 errcatch (error_syms: [aa, bb, 123]);
1439 [];
1441 error_syms: [aa, bb, cc];
1442 [aa, bb, cc];
1444 errcatch (niceindicespref: 123);
1445 [];
1447 errcatch (niceindicespref: []);
1448 [];
1450 niceindicespref: [aa, bb, cc];
1451 [aa, bb, cc];
1453 (reset (error_syms, niceindicespref), 0);
1454 0;
1456 /* now the example from the Stackoverflow question */
1458 (program_content:
1459 "define_variable(foo, true, boolean)$
1460 foo: true$
1462 exprp(that) := if foo = false and listp(that) and not emptyp(that) and member(that[1], [\"+\", \"*\"]) then(foo: true, true)$
1463 matchdeclare(exprm, exprp)$
1464 defrule(rule_1, exprm, subst(exprm[1], \"[\", exprm[2]))$
1466 calc(list) := block([steps: []],
1467 while foo do(
1468 steps: endcons(list, steps),
1469 foo: false,
1470 list: applyb1(list, rule_1)
1471 ),
1472 steps
1473 )$
1475 calc_result: calc([\"+\", [[\"*\", [1, 2, 3]], [\"+\", [3, 4, 6]]]]);",
1476 program_file_name: sconcat (maxima_tempdir, "/tmp_program.mac"),
1477 with_stdout (program_file_name, print (program_content)),
1478 0);
1479 0;
1481 kill (calc_result);
1482 done;
1484 ([file_name_original, file_name_LISP, file_name_UNLISP, file_name_compiled]: compile_file (program_file_name), 0);
1485 0;
1487 stringp (file_name_compiled);
1488 true;
1490 calc_result;
1491 calc_result;
1493 (load (file_name_compiled),
1494 calc_result);
1495 [["+", [["*", [1, 2, 3]], ["+", [3, 4, 6]]]],
1496 ["+", [6, ["+", [3, 4, 6]]]],
1497 ["+", [6, 13]],
1498 19];
1500 (kill (program_content, program_file_name, file_name_original, file_name_LISP, file_name_UNLISP, file_name_compiled, calc_result), 0);
1501 0;
1504 /* Some additional basic tests for functions with rest args */
1506 block ([translate : false],
1507 foo ([r]) := r,
1508 bar (a, b, [c]) := [a, b, c],
1509 test () :=
1510 [foo (),
1511 foo (1),
1512 foo (1, 2, 3),
1513 errcatch (bar ()),
1514 errcatch (bar (1)),
1515 bar (1, 2),
1516 bar (1, 2, 3),
1517 bar (1, 2, 3, 4, 5)],
1519 /* l1: foo, bar and test are interpreted */
1520 l1 : test (),
1522 /* l2: foo and bar are translated, and test is interpreted */
1523 translate_or_lose (foo, bar),
1524 l2 : test (),
1526 /* l3: foo, bar and test are translated */
1527 translate_or_lose (test),
1528 l3 : test (),
1530 [is (l1 = l2),
1531 is (l2 = l3),
1532 l1]);
1533 [true,
1534 true,
1535 [[],
1536 [1],
1537 [1, 2, 3],
1538 [],
1539 [],
1540 [1, 2, []],
1541 [1, 2, [3]],
1542 [1, 2, [3, 4, 5]]]];
1544 (kill (foo, bar, test, l1, l2, l3), 0);
1545 0;
1547 /* Attempting to translate a macro with a rest arg always caused an
1548 * error during translation because the translator was constructing
1549 * bogus Maclisp-style lexpr lambda expressions.
1550 */
1552 block ([translate : false],
1553 foo ([r]) ::=
1554 buildq ([r], ['r, r]),
1555 bar (a, b, [c]) ::=
1556 buildq ([a, b, c], ['a, a, 'b, b, 'c, c]),
1557 test1 () :=
1558 block ([x : 1, z : 3],
1559 [foo (),
1560 foo (x),
1561 foo (x, y, z),
1562 bar (x, y),
1563 bar (x, y, z),
1564 bar (x, y, z, 4, 5, 6)]),
1565 /* test2 cannot be translated due to the WNA error during macro
1566 * expansion, but we can call and test it in the interpreter
1567 */
1568 test2 () :=
1569 [errcatch (bar ()),
1570 errcatch (bar (1))],
1572 /* l1: foo, bar and test1 are interpreted */
1573 l1 : test1 (),
1575 /* l2: foo and bar are translated, and test1 is interpreted */
1576 translate_or_lose (foo, bar),
1577 l2 : test1 (),
1579 /* l3: foo, bar and test1 are translated */
1580 translate_or_lose (test1),
1581 l3 : test1 (),
1583 [test2 (),
1584 is (l1 = l2),
1585 is (l2 = l3),
1586 l1]);
1587 [[[], []],
1588 true,
1589 true,
1590 [[[], []],
1591 [['x], [1]],
1592 [['x, 'y, 'z], [1, 'y, 3]],
1593 ['x, 1, 'y, 'y, [], []],
1594 ['x, 1, 'y, 'y, ['z], [3]],
1595 ['x, 1, 'y, 'y, ['z, 4, 5, 6], [3, 4, 5, 6]]]];
1597 (kill (foo, bar, test1, test2, l1, l2, l3), 0);
1598 0;
1600 /* Some additional basic tests for conditionals.
1601 *
1602 * We test both elseif and else-if ("else if").
1603 */
1605 block ([translate : false],
1606 mysignum1 (x) := if x > 0 then 1 elseif x < 0 then -1 else 0,
1607 mysignum2 (x) := if x > 0 then 1 else if x < 0 then -1 else 0,
1608 foo () :=
1609 [if true then 1,
1610 if false then 1,
1611 if true then 1 else 2,
1612 if false then 1 else 2,
1613 if 1 < 2 then 'y,
1614 if 1 < 2 then 'y else 'n,
1615 if 1 > 2 then 'n,
1616 if 1 > 2 then 'n else 'y,
1617 if 1 > 2 then 'n elseif 1 = 2 then 'n else 'y,
1618 if 1 > 2 then 'n else if 1 = 2 then 'n else 'y,
1619 mysignum1 (-3),
1620 mysignum2 (-3),
1621 mysignum1 (0),
1622 mysignum2 (0),
1623 mysignum1 (2),
1624 mysignum2 (2)],
1625 l1 : foo (),
1626 translate_or_lose (mysignum1, mysignum2, foo),
1627 l2 : foo (),
1628 [is (l1 = l2),
1629 l2]);
1630 [true,
1631 [1, false, 1, 2, 'y, 'y, false, 'y, 'y, 'y, -1, -1, 0, 0, 1, 1]];
1633 (kill (mysignum1, mysignum2, foo, l1, l2), 0);
1634 0;
1636 /* Bogus translations of nested conditionals in elseif clauses
1637 *
1638 * The translation of a conditional with another conditional nested
1639 * directly under an elseif clause was totally wrong. Using else-if
1640 * ("else if") instead of elseif would work fine.
1641 *
1642 *
1643 * We use the with_both_elseifs macro so we can test both elseif and
1644 * else-if without having to duplicate portions of the tests below.
1645 * Give this macro a conditional expression with elseifs and it will
1646 * expand into a list: the first element is the same expression given
1647 * to it (with elseifs), and the second element is that same expression
1648 * rewritten to use else-ifs instead of elseifs.
1649 */
1651 (to_else_if (expr) :=
1652 if mapatom (expr) then
1653 expr
1654 else
1655 block ([op : op (expr), args : args (expr)],
1656 if op = "if" and length (args) > 4 then
1657 funmake (op, map ('to_else_if, append (firstn (args, 2), [true, funmake (op, rest (args, 2))])))
1658 else
1659 funmake (op, map ('to_else_if, args))),
1660 with_both_elseifs (expr) ::=
1661 buildq ([expr, texpr : to_else_if (expr)],
1662 [expr, texpr]),
1663 0);
1664 0;
1666 block ([translate : false],
1667 foo () :=
1668 with_both_elseifs (
1669 if false then
1670 'lose1
1671 elseif false then
1672 'lose2
1673 elseif false then
1674 if true then
1675 'lose3
1676 else
1677 'lose4
1678 else
1679 'win),
1681 /* l1: foo is interpreted */
1682 l1 : foo (),
1684 translate_or_lose (foo),
1686 /* l2: foo is translated
1687 *
1688 * foo used to give lose3 instead of win in the elseif case.
1689 */
1690 l2 : foo (),
1692 [is (l1 = l2),
1693 l2]);
1694 [true,
1695 ['win, 'win]];
1697 block ([translate : false],
1698 /* There is nothing special about bar here. This is just some
1699 * function that has several branches with nested conditionals.
1700 */
1701 bar (x) :=
1702 with_both_elseifs (
1703 if x > 5 then
1704 if x > 7 then
1705 'more_than_seven
1706 elseif x > 6 then
1707 'seven
1708 else
1709 'six
1710 elseif x > 2 then
1711 if x > 4 then
1712 'five
1713 elseif x > 3 then
1714 'four
1715 else
1716 'three
1717 elseif x >= 0 then
1718 if x > 1 then
1719 'two
1720 elseif x > 0 then
1721 'one
1722 else
1723 'zero
1724 else
1725 'negative),
1727 /* We test bar with the integers -2 to 9 */
1728 inputs : makelist (k, k, -2, 9),
1730 /* l1: bar is interpreted */
1731 l1 : map (bar, inputs),
1733 translate_or_lose (bar),
1735 /* l2: bar is translated
1736 *
1737 * bar used to give incorrect results in the elseif case for every
1738 * number less than or equal to 2 (which means we got incorrect
1739 * results for the integers -2 to 2 in this test).
1740 */
1741 l2 : map (bar, inputs),
1743 [is (l2 = l1),
1744 l2]);
1745 [true,
1746 [['negative, 'negative],
1747 ['negative, 'negative],
1748 ['zero, 'zero],
1749 ['one, 'one],
1750 ['two, 'two],
1751 ['three, 'three],
1752 ['four, 'four],
1753 ['five, 'five],
1754 ['six, 'six],
1755 ['seven, 'seven],
1756 ['more_than_seven, 'more_than_seven],
1757 ['more_than_seven, 'more_than_seven]]];
1759 (kill (foo, bar, l1, l2, inputs, to_else_if, with_both_elseifs), 0);
1760 0;
1762 /* Bogus translations of conditionals with tests that translated to T
1763 * and consequents that translated to NIL.
1764 */
1766 block ([translate : false],
1767 foo () :=
1768 [if true then false else 1,
1769 if true then false elseif true then 1 else 2,
1770 if false then true elseif true then false else 1],
1772 /* l1: foo is interpreted */
1773 l1 : foo (),
1775 translate_or_lose (foo),
1777 /* l2: foo is translated
1778 *
1779 * foo used to return [1, 1, 1]
1780 */
1781 l2 : foo (),
1783 [is (l2 = l1),
1784 l2]);
1785 [true,
1786 [false, false, false]];
1788 (kill (foo, l1, l2), 0);
1789 0;
1791 /* Bug #3704: Translator gives internal error
1792 *
1793 * The hyper_to_summand function is from the bug report.
1794 */
1796 (hyper_to_summand(e,k) := subst(hypergeometric = lambda([P,Q,x],
1797 P : xreduce("*", map(lambda([zz], pochhammer(zz,k)),P)),
1798 Q : xreduce("*", map(lambda([zz], pochhammer(zz,k)),Q)),
1799 P*x^k/(k! * Q)),e),
1800 l1 : hyper_to_summand (hypergeometric ([1/2], [2/5], x), 2),
1801 translate_or_lose (hyper_to_summand),
1802 l2 : hyper_to_summand (hypergeometric ([1/2], [2/5], x), 2),
1803 [is (l1 = l2), l2]);
1804 [true, 75 * x^2 / 112];
1806 (foo () := lambda ([], x!),
1807 translate_or_lose (foo),
1808 block ([x : 5], foo () ()));
1809 120;
1811 (kill (hyper_to_summand, foo, l1, l2), 0);
1812 0;
1814 /* go tags can be integers
1815 *
1816 * This has been allowed, but it used to give a warning and an extra
1817 * trivial run through the translator to translate the integer go tags.
1818 * Now we allow integers directly without giving a warning.
1819 *
1820 * We don't actually bother to check for warnings in the test below.
1821 * We're really just verifying that using an integer go tag works.
1822 */
1824 block ([translate : false],
1825 foo () := block ([i : 0], tag, i : i + 1, if i < 5 then go (tag), i),
1826 bar () := block ([i : 0], 123, i : i + 1, if i < 5 then go (123), i),
1827 l1 : [foo (), bar ()],
1828 translate_or_lose (foo, bar),
1829 l2 : [foo (), bar ()],
1830 [is (l1 = l2), l2]);
1831 [true, [5, 5]];
1833 (kill (foo, bar, l1, l2), 0);
1834 0;
1836 /* A bug in MARRAYREF caused things like translated array references
1837 * to yield MQAPPLY expressions with an incorrect header.
1838 */
1840 block ([translate : false],
1841 foo () := 'baz () [1],
1842 bar () := 'baz () [1, 2, 3],
1843 l1 : [foo (), bar ()],
1844 translate_or_lose (foo, bar),
1845 l2 : [foo (), bar ()],
1846 [is (l1 = l2), l2]);
1847 [true, ['baz () [1], 'baz () [1, 2, 3]]];
1849 (kill (foo, bar, l1, l2), 0);
1850 0;
1852 /* A bug in MARRAYREF caused bogus indexing into hash tables and fast
1853 * arrays. This affected things like translated array references.
1854 */
1856 block ([translate : false,
1857 use_fast_arrays : true],
1859 foo () := block ([a],
1860 a[false] : 'wtf,
1861 a[1] : 2,
1862 a[1]),
1864 /* This would correctly yield 2 */
1865 l1 : foo (),
1867 translate_or_lose (foo),
1869 /* This used to incorrectly yield wtf */
1870 l2 : foo (),
1872 [is (l1 = l2), l2]);
1873 [true, 2];
1875 (kill (foo, l1, l2), 0);
1876 0;
1878 /* A bug in MARRAYREF caused things like translated array references
1879 * to yield expressions with an incorrect header.
1880 */
1882 block ([translate : false],
1883 foo () := block ([a],
1884 local (a),
1885 array (a, complete, 5),
1886 a[3]),
1888 /* This would correctly yield a[3] */
1889 l1 : foo(),
1891 translate_or_lose (foo),
1893 /* This would incorrectly yield a(3) */
1894 l2 : foo(),
1896 [is (l1 = l2), l2]);
1897 [true, 'a[3]];
1899 (kill (foo, l1, l2), 0);
1900 0;
1902 /* When translate_fast_arrays:true, a lisp error would occur at runtime
1903 * during an attempted MQAPPLY array assignment
1904 */
1906 block ([translate : false],
1907 foo () := block ([a],
1908 local (a, b),
1909 a : make_array ('fixnum, 5),
1910 b () := a,
1911 b () [3] : 17,
1912 b () [3]),
1914 /* This would correctly yield 17 */
1915 l1 : foo(),
1917 block ([translate_fast_arrays : false],
1918 translate_or_lose (foo)),
1920 /* This would correctly yield 17 */
1921 l2 : foo(),
1923 block ([translate_fast_arrays : true],
1924 translate_or_lose (foo)),
1926 /* This would cause a lisp error */
1927 l3 : foo(),
1929 [is (l1 = l2), is (l2 = l3), l3]);
1930 [true, true, 17];
1932 (kill (foo, l1, l2, l3), 0);
1933 0;
1935 /* The string "**" no longer translates to the string "^".
1936 * This test compares the interpreted and translated results.
1937 */
1939 block ([translate : false],
1940 foo () := ["^", "^" (2, 3), apply ("^", [2, 3]),
1941 "**", "**" (2, 3), apply ("**", [2, 3])],
1942 l1 : foo (),
1943 translate_or_lose (foo),
1944 l2 : foo (),
1945 [l2, is (l1 = l2)]);
1946 [["^", 8, 8, "**", 8, 8], true];
1948 (kill (foo, l1, l2), 0);
1949 0;
1951 /* Attempting to translate some atoms like lisp arrays would
1952 * cause lisp errors during translation.
1953 */
1955 (a : make_array (fixnum, 1),
1956 a[0] : 13,
1957 define (foo (), a),
1958 translate_or_lose (foo),
1959 listarray (foo ()));
1960 [13];
1962 (kill (foo, a), 0);
1963 0;
1965 /* Simple tests for catch and throw */
1967 block ([translate : false, l1, l2],
1968 local (foo, bar, baz),
1970 foo (p) := if p then throw (13) else 2,
1971 bar () := catch (1, foo (false), 3),
1972 baz () := catch (1, foo (true), 3),
1974 l1 : [bar (), baz ()],
1976 translate_or_lose (foo, bar, baz),
1978 l2 : [bar (), baz ()],
1980 [l2, is (l1 = l2)]);
1981 [[3, 13], true];
1983 /* Translating a define_variable form with translate (but not
1984 * translate_file or compfile) used to invoke undefined behavior.
1985 * This would cause a lisp error during translation under some
1986 * (but not all) lisp implementations.
1987 */
1989 block ([translate : false],
1990 local (foo),
1991 foo () := (define_variable (x, 1, fixnum), x),
1992 translate_or_lose (foo),
1993 foo ());
1994 1;
1996 (kill (foo, x), 0);
1997 0;
1999 /* If local was used on a matchdeclared pattern variable, and this
2000 * was all translated with something besides translate_file (e.g.,
2001 * translate, compfile, etc.), then the MATCHDECLARE property would
2002 * not be on the pattern variable.
2003 */
2005 block ([translate : false, l1, l2],
2006 local (foo),
2008 foo () := (local (x), matchdeclare (x, true), let (a * x, x), letsimp (a * q)),
2010 /* This would yield q */
2011 l1 : foo (),
2013 translate_or_lose (foo),
2015 /* This used to yield a*q */
2016 l2 : foo (),
2018 [l2, is (l1 = l2)]);
2019 [q, true];
2021 (kill (foo), 0);
2022 0;
2024 /* Rest args are now allowed in lambda expressions in MQAPPLY
2025 * lambda forms
2026 */
2028 block ([translate : false, l1, l2],
2029 local (foo, bar, baz),
2031 /* foo used to fail to translate due to the rest arg */
2032 foo () :=
2033 block ([x : 1, z : 3],
2034 lambda ([[x]], x) (x, x + 1, z)),
2035 bar () :=
2036 block ([x : 2, z : 4],
2037 apply (lambda ([[x]], x), [x, x + 1, z])),
2038 baz () :=
2039 block ([x : 3, z : 5],
2040 block ([f : lambda ([[x]], x)],
2041 f (x, x + 1, z))),
2043 l1 : [foo (), bar (), baz ()],
2045 translate_or_lose (foo, bar, baz),
2047 l2 : [foo (), bar (), baz ()],
2049 [l1, is (l1 = l2)]);
2050 [[[1, 2, 3],[2, 3, 4],[3, 4, 5]], true];
2052 /* Validation has been improved for lambda expressions in MQAPPLY
2053 * lambda forms
2054 */
2056 block ([translate : false],
2057 local (foo, bar),
2059 /* These should both fail to translate */
2060 foo () := lambda ([]) (),
2061 bar () := lambda ([x, x], x) (1, 2),
2063 translate (foo, bar));
2064 [];
2066 /* The translation of array functions was broken for decades */
2068 block ([translate : false, l1, l2],
2069 local (foo, bar),
2071 foo[x] := x,
2072 bar[n] := if n = 1 then 1 else n * bar[n - 1],
2074 l1 : [foo[0], foo[5], bar[5], bar[10]],
2076 translate_or_lose (foo, bar),
2078 l2 : [foo[0], foo[5], bar[5], bar[10]],
2080 [l1, is (l1 = l2)]);
2081 [[0, 5, 120, 3628800], true];
2083 (kill (foo, bar), 0);
2084 0;
2086 /* The translation of upward funargs (including those created by
2087 * subscripted functions) easily lead to lisp errors.
2088 */
2090 /* Tests involving returned lambdas without free vars that were
2091 * bound during definition
2092 */
2093 block ([l1, l2,
2094 translate : false,
2095 listarith : true],
2096 local (foo, bar, test),
2098 foo () := lambda ([x], 2 * x + q),
2099 bar () := lambda ([x, [y]], x * y + q),
2101 test () :=
2102 block ([f : foo (),
2103 b : bar ()],
2104 [f (3), f (5), b (2, 3, 4), b (5, 6, 7)]),
2106 l1 : test (),
2108 translate_or_lose (foo, bar),
2110 l2 : test (),
2112 [l2, is (l1 = l2)]);
2113 [['q + 6, 'q + 10, ['q + 6, 'q + 8], ['q + 30, 'q + 35]],
2114 true];
2116 (kill (foo, bar), 0);
2117 0;
2119 /* Tests involving returned lambdas with free vars that were
2120 * bound during definition. These do not cause the capture of
2121 * values.
2122 */
2123 block ([l1, l2,
2124 x : 'ux,
2125 translate : false,
2126 listarith : true],
2127 local (foo, bar, baz, test),
2129 foo (x) := lambda ([y], x + y + q),
2130 bar (x) := lambda ([y, [z]], q + x + y * z),
2131 baz (v) := lambda ([], v),
2133 test () :=
2134 block ([f : foo (3),
2135 b : bar (4),
2136 c : baz (5)],
2137 [f (5), b (2, 3, 4), c ()]),
2139 l1 : test (),
2141 translate_or_lose (foo, bar, baz),
2143 l2 : test (),
2145 [l2, is (l1 = l2)]);
2146 [['q + 'ux + 5,
2147 ['q + 'ux + 6, 'q + 'ux + 8],
2148 'v],
2149 true];
2151 (kill (foo, bar, baz), 0);
2152 0;
2154 /* Tests involving subscripted functions. These do cause the capture
2155 * of values.
2156 */
2157 block ([l1, l2,
2158 x : 'ux, y : 'uy,
2159 translate : false],
2160 local (foo, bar, baz, def, test),
2162 def () := (
2163 foo[x, y](a, b) := [x, y, a, b, q],
2164 bar[x, y](a, [b]) := [x, y, a, b, q],
2165 baz[v]() := v),
2167 test () :=
2168 block ([f : foo[1, 2],
2169 b : bar[3, 4],
2170 c : baz[5]],
2171 [f (6, 7), b (8, 9, 10), c ()]),
2173 def (),
2175 l1 : test (),
2177 /* just kill and redefine */
2179 kill (foo, bar, baz),
2181 def (),
2183 translate_or_lose (foo, bar, baz),
2185 l2 : test (),
2187 [l2, is (l1 = l2)]);
2188 [[[1, 2, 6, 7, 'q],
2189 [3, 4, 8, [9, 10], 'q],
2190 5],
2191 true];
2193 (kill (foo, bar, baz), 0);
2194 0;
2196 /* More tests involving multiple nested lambdas */
2197 block ([l1, l2,
2198 x : 'ux, y : 'uy, z : 'uz,
2199 translate : false],
2200 local (foo, bar, baz, quux, def, test),
2202 def () := (
2203 /* nothing should be captured */
2204 foo (x) := lambda ([y], lambda ([z], [x, y, z])),
2205 /* x should be captured and used */
2206 bar[x](y) := lambda ([z], [x, y, z]),
2207 /* x should be captured and used */
2208 baz[x](y) := lambda ([z], lambda ([], [x, y, z])),
2209 /* nothing should be captured since x is bound by the inner lambda */
2210 quux[x](y) := lambda ([x], [x, y])),
2212 test () :=
2213 block ([a : foo (1),
2214 b : bar[2],
2215 c : baz[3],
2216 d : quux[4]],
2217 [a (10) (11), b (12) (13), c (14) (15) (), d (16) (17)]),
2219 def (),
2221 l1 : test (),
2223 /* just kill and redefine */
2225 kill (foo, bar, baz, quux),
2227 def (),
2229 translate_or_lose (foo, bar, baz, quux),
2231 l2 : test (),
2233 [l2, is (l1 = l2)]);
2234 [[['ux, 'uy, 11],
2235 [2, 'uy, 13],
2236 [3, 'uy, 'uz],
2237 [17, 'uy]],
2238 true];
2240 (kill (foo, bar, baz, quux), 0);
2241 0;
2243 /* The translator was not correctly determining the mode of expressions
2244 * when a boolean mode was involved.
2245 *
2246 * It was easy to get lisp errors.
2247 */
2248 block ([translate : false, l1, l2],
2249 local (test),
2251 foo () :=
2252 [ 1 + if true then 0,
2253 1 + if true then 0.0,
2254 1.0 + if true then 0,
2255 1.0 + if true then 0.0,
2257 1 + if false then 0,
2258 1 + if false then 0.0,
2259 1.0 + if false then 0,
2260 1.0 + if false then 0.0],
2262 bar (x) :=
2263 [ 1 + if x then 0,
2264 1 + if x then 0.0,
2265 1.0 + if x then 0,
2266 1.0 + if x then 0.0],
2268 test () :=
2269 block ([res : []],
2270 for prederror in [true, false] do
2271 push (foo (), res),
2272 for x in [true, false] do
2273 push (bar (x), res),
2274 res),
2276 l1 : test (),
2278 translate_or_lose (foo, bar),
2280 l2 : test (),
2282 is (l1 = l2));
2283 true;
2285 (kill (foo, bar), 0);
2286 0;
2288 /*
2289 * Bug #4008: translator and prederror
2290 */
2292 (kill (pred, foo, bar, x, r), 0);
2293 0;
2295 block ([translate : false, l1, l2],
2296 local (test),
2298 foo (n, q, x) :=
2299 [if true then q + r,
2300 if false then q + r,
2302 if x then q,
2303 if not x then q,
2304 if not not x then q,
2305 if not not not x then q,
2307 n + if x then q + r,
2308 n + if not x then q + r,
2309 n + if not not x then q + r,
2310 n + if not not not x then q + r],
2312 test () :=
2313 block ([res : []],
2314 for prederror in [true, false] do
2315 for n in [1, 1.0, %i, 1.0 * %i] do
2316 for q in [1, 1.0, %i, 1.0 * %i, 'z] do
2317 for x in [true, false] do
2318 push (foo (n, q, x), res),
2319 res),
2321 l1 : test (),
2323 translate_or_lose (foo),
2325 l2 : test (),
2327 is (l1 = l2));
2328 true;
2330 (kill (foo), 0);
2331 0;
2333 block ([translate : false, l1, l2],
2334 local (test),
2336 foo (x, y) :=
2337 block ([q : 'z],
2338 [if "and" () then q else r,
2339 if "and" (x) then q else r,
2340 if "and" (y) then q else r,
2341 if x and y then q else r,
2342 if not x and y then q else r,
2343 if x and not y then q else r,
2344 if not x and not y then q else r,
2345 if not (x and y) then q else r,
2346 if not (not x and y) then q else r,
2347 if not (x and not y) then q else r,
2348 if not (not x and not y) then q else r,
2350 if "or" () then q else r,
2351 if "or" (x) then q else r,
2352 if "or" (y) then q else r,
2353 if x or y then q else r,
2354 if not x or y then q else r,
2355 if x or not y then q else r,
2356 if not x or not y then q else r,
2357 if not (x or y) then q else r,
2358 if not (not x or y) then q else r,
2359 if not (x or not y) then q else r,
2360 if not (not x or not y) then q else r]),
2362 test () :=
2363 block ([res : []],
2364 for prederror in [true, false] do
2365 for x in [true, false] do
2366 for y in [true, false] do
2367 push (foo (x, y), res),
2368 res),
2370 l1 : test (),
2372 translate_or_lose (foo),
2374 l2 : test (),
2376 is (l1 = l2));
2377 true;
2379 (kill (foo), 0);
2380 0;
2382 block ([translate : false, l1, l2],
2383 local (test, make_fun),
2385 make_fun (name, pr) ::=
2386 buildq ([name, pr],
2387 name (x, y) :=
2388 block ([q : 'z],
2389 [pr ("and" ()),
2390 pr ("and" (x)),
2391 pr ("and" (y)),
2392 pr (x and y),
2393 pr (not x and y),
2394 pr (x and not y),
2395 pr (not x and not y),
2396 pr (not (x and y)),
2397 pr (not (not x and y)),
2398 pr (not (x and not y)),
2399 pr (not (not x and not y)),
2401 pr ("or" ()),
2402 pr ("or" (x)),
2403 pr ("or" (y)),
2404 pr (x or y),
2405 pr (not x or y),
2406 pr (x or not y),
2407 pr (not x or not y),
2408 pr (not (x or y)),
2409 pr (not (not x or y)),
2410 pr (not (x or not y)),
2411 pr (not (not x or not y))])),
2413 make_fun (foo, is),
2414 make_fun (bar, maybe),
2416 test () :=
2417 block ([res : []],
2418 for prederror in [true, false] do
2419 for x in [true, false] do
2420 for y in [true, false] do (
2421 push (foo (x, y), res),
2422 push (bar (x, y), res)),
2423 res),
2425 l1 : test (),
2427 translate_or_lose (foo, bar),
2429 l2 : test (),
2431 is (l1 = l2));
2432 true;
2434 (kill (foo, bar), 0);
2435 0;
2437 block ([translate : false, l1, l2],
2438 local (test),
2440 pred (a, b) := equal (a, b),
2442 foo (x, y) :=
2443 block ([q : 'z],
2444 [if x < y then q else r,
2445 if not (x < y) then q else r,
2446 if x <= y then q else r,
2447 if not (x <= y) then q else r,
2448 if x > y then q else r,
2449 if not (x > y) then q else r,
2450 if x >= y then q else r,
2451 if not (x >= y) then q else r,
2453 if x = y then q else r,
2454 if x # y then q else r,
2455 if not (x = y) then q else r,
2456 if not (x # y) then q else r,
2457 if not not (x = y) then q else r,
2458 if not not (x # y) then q else r,
2459 if not not not (x = y) then q else r,
2460 if not not not (x # y) then q else r,
2462 if equal (x, y) then q else r,
2463 if notequal (x, y) then q else r,
2464 if not equal (x, y) then q else r,
2465 if not not equal (x, y) then q else r,
2466 if not notequal (x, y) then q else r,
2467 if not not not equal (x, y) then q else r,
2468 if not not notequal (x, y) then q else r,
2470 if pred (x, y) then q else r,
2471 if not pred (x, y) then q else r,
2472 if not not pred (x, y) then q else r,
2473 if not not not pred (x, y) then q else r]),
2475 test () :=
2476 block ([res : []],
2477 for prederror in [true, false] do
2478 for x in [1, 2] do
2479 for y in [1, 2] do
2480 push (foo (x, y), res),
2481 res),
2483 l1 : test (),
2485 translate_or_lose (pred, foo),
2487 l2 : test (),
2489 is (l1 = l2));
2490 true;
2492 (kill (pred, foo), 0);
2493 0;
2495 block ([translate : false, l1, l2],
2496 local (test, make_fun),
2498 pred (a, b) := equal (a, b),
2500 make_fun (name, pr) ::=
2501 buildq ([name, pr],
2502 name (x, y) :=
2503 block ([q : 'z],
2504 [pr (x = y),
2505 pr (x # y),
2506 pr (not (x = y)),
2507 pr (not (x # y)),
2508 pr (not not (x = y)),
2509 pr (not not (x # y)),
2510 pr (not not not (x = y)),
2511 pr (not not not (x # y)),
2513 pr (equal (x, y)),
2514 pr (not equal (x, y)),
2515 pr (notequal (x, y)),
2516 pr (not not equal (x, y)),
2517 pr (not notequal (x, y)),
2518 pr (not not not equal (x, y)),
2519 pr (not not notequal (x, y)),
2521 pr (pred (x, y)),
2522 pr (not pred (x, y)),
2523 pr (not not pred (x, y)),
2524 pr (not not not pred (x, y))])),
2526 make_fun (foo, is),
2527 make_fun (bar, maybe),
2529 test () :=
2530 block ([res : []],
2531 for prederror in [true, false] do
2532 for x in [1, 2] do
2533 for y in [1, 2] do (
2534 push (foo (x, y), res),
2535 push (bar (x, y), res)),
2536 res),
2538 l1 : test (),
2540 translate_or_lose (pred, foo, bar),
2542 l2 : test (),
2544 is (l1 = l2));
2545 true;
2547 (kill (pred, foo, bar), 0);
2548 0;
2550 block ([translate : false, l1, l2],
2551 local (test),
2553 foo (x, q) :=
2554 [if (1, 2, q, x) then q else r,
2555 if not (1, 2, q, x) then q else r,
2556 if (1, 2, q, not x) then q else r],
2558 test () :=
2559 block ([res : []],
2560 for prederror in [true, false] do
2561 for x in [true, false] do
2562 push (foo (x, 17), res),
2563 res),
2565 l1 : test (),
2567 translate_or_lose (foo),
2569 l2 : test (),
2571 is (l1 = l2));
2572 true;
2574 (kill (foo), 0);
2575 0;
2581 /*** KILLING THESE FUNCTIONS SHOULD BE THE LAST TEST IN THIS FILE ***/
2582 (kill (translate_or_lose, compile_or_lose), 0);
2583 0;
2584 /*** THERE SHOULD BE NO TESTS BEYOND THIS POINT ***/