tests/rtest_translator.mac

   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  */
   4
   5 (kill (all), 0);
   6 0;
   7
   8 /* SF [ 1728888 ] translator bugs: no mnot mprogn */
   9
  10 (foo (e,v) := block([vi], for vi in v while not(emptyp(e)) do (print(vi), e : rest(e)), e),
  11  foo ([1, 2, 3], [a, b]));
  12 [3];
  13
  14 (translate (foo), ?funcall (foo, [1, 2, 3], [a, b]));
  15 [3];
  16
  17 /* simpler function featuring mprogn and mnot */
  18
  19 (bar (x) := (x : 2*x, x : 3*x, not (x < 100)), bar (3));
  20 false;
  21
  22 (translate (bar), ?funcall (bar, 3));
  23 false;
  24
  25 /* SF [ 1646525 ] no function mdoin */
  26
  27 (try_me(x) := block([acc : 0], for i in x while i > 5 do acc : acc + i, acc),
  28  try_me ([10, 9, 8, 7, 6, 5, 4, 5, 6, 7, 8, 9, 10]));
  29 40;
  30
  31 (translate (try_me), ?funcall (try_me, [10, 9, 8, 7, 6, 5, 4, 5, 6, 7, 8, 9, 10]));
  32 40;
  33
  34 /* SF [ 1818645 ] Compiled maxima code containing $ARRAY gets a Lisp error. */
  35
  36 (test_array_comp (x) :=
  37   block ([abc, i],
  38     array (abc, 3),
  39     for i thru 3 do (abc[i]: i*i),
  40     abc[3] : x,
  41     [abc, abc[3], abc[2]]),
  42   test_array_comp (100));
  43 [abc, 100, 4];
  44
  45 (translate (test_array_comp), ?funcall (test_array_comp, 100));
  46 [abc, 100, 4];
  47
  48 /* SF [ 545794 ] Local Array does not compile properly */
  49
  50 (trial (a) :=
  51   block ([myvar, i],
  52     local(myvar),
  53     array (myvar, 7),
  54     for i : 0 thru 7 do myvar [i] : a^i,
  55     [member (myvar, arrays), listarray (myvar)]),
  56  trial (2));
  57 [true, [1, 2, 4, 8, 16, 32, 64, 128]];
  58
  59 (translate (trial), ?funcall (trial, 2));
  60 [true, [1, 2, 4, 8, 16, 32, 64, 128]];
  61
  62 /* Next test fails because local(myvar) in translated code doesn't clean up properties ... */
  63
  64 [member (myvar, arrays), errcatch (listarray (myvar))];
  65 [false, []];
  66
  67 /* for loop variable not special
  68  * reported to mailing list 2009-08-13 "Why won't this compile?"
  69  */
  70
  71 (kill (foo1, bar1),
  72  foo1 () := bar1 + 1,
  73  baz1 (n) := block ([S : 0], for bar1:0 thru n - 1 do S : S + foo1 (), S),
  74  translate (baz1),
  75  baz1 (10));
  76 55;
  77
  78 /* original example */
  79
  80 (fun(A,b,s,VF,x,h):= block
  81  ([Y],
  82    Y[1]:  x,
  83    for i:2 thru s do
  84     Y[i]:  x + h*(sum(A[i,j]*VF(Y[j]),j,1,i-1)),
  85    x: expand(x + h*sum(b[i]*VF(Y[i]),i,1,s))),
  86   A: matrix([1,1],[1,1]),
  87   b: [1,1],
  88  0);
  89 0;
  90
  91 fun(A,b,2,f,[1,1],.01);
  92 0.01*f(0.01*f([1,1])+[1,1])+0.01*f([1,1])+[1,1]$
  93
  94 (translate (fun), fun(A,b,2,f,[1,1],.01));
  95 0.01*f(0.01*f([1,1])+[1,1])+0.01*f([1,1])+[1,1]$
  96
  97 /* incorrect code emitted for call from translated function to untranslated
  98  * SF bug # 2934064 "problem loading ezunits"
  99  */
 100
 101 (f0001 (x) := [f0002 (x), f0003 (x)],
 102  f0002 (x) := x,
 103  f0003 (x) := x,
 104  translate (f0002, f0001),
 105  f0001 (1));
 106 [1, 1];
 107
 108 (translate (f0003), f0001 (1));
 109 [1, 1];
 110
 111 (compile (f0003), f0001 (1));
 112 [1, 1];
 113
 114 (compile (f0003, f0002, f0001), f0001 (1));
 115 [1, 1];
 116
 117 /* SF bug # 2938716 "too much evaluation in translated code"
 118  */
 119
 120 (g0001 (x) := [g0002 (x), g0003 (x)],
 121  g0002 (x) := x,
 122  g0003 (x) := x,
 123  translate (g0002, g0001),
 124  kill (aa, bb, cc),
 125  aa : 'bb,
 126  bb : 'cc,
 127  g0001 (aa));
 128 [bb, bb];
 129
 130 (translate (g0003), g0001 (aa));
 131 [bb, bb];
 132
 133 (compile (g0003), g0001 (aa));
 134 [bb, bb];
 135
 136 (compile (g0003, g0002, g0001), g0001 (aa));
 137 [bb, bb];
 138
 139 /* SF bug # 3035313 "some array references translated incorrectly"
 140  */
 141
 142 (kill (aa1, aa3, bb1, bb3, cc1, cc3),
 143  array (aa1, 15),
 144  array (aa3, 12, 4, 6),
 145  array (bb1, flonum, 15),
 146  array (bb3, flonum, 5, 6, 7),
 147  array (cc1, fixnum, 8),
 148  array (cc3, fixnum, 6, 10, 4),
 149  0);
 150 0;
 151
 152 (kill (faa, gaa, fbb, gbb, fcc, gcc),
 153  faa (n) := aa1[n] + aa3[n, n - 1, n - 2],
 154  gaa (n) := (aa1[n] : 123, aa3[n, n - 1, n - 2] : 321),
 155  fbb (n) := bb1[n] + bb3[n, n - 1, n - 2],
 156  gbb (n) := (bb1[n] : 123, bb3[n, n - 1, n - 2] : 321),
 157  fcc (n) := cc1[n] + cc3[n, n - 1, n - 2],
 158  gcc (n) := (cc1[n] : 123, cc3[n, n - 1, n - 2] : 321),
 159  0);
 160 0;
 161
 162 [gaa (4), gbb (4), gcc (4)];
 163 [321, 321, 321];
 164
 165 [faa (4), fbb (4), fcc (4)];
 166 [444, 444, 444];
 167
 168 translate (faa, gaa, fbb, gbb, fcc, gcc);
 169 [faa, gaa, fbb, gbb, fcc, gcc];
 170
 171 [gaa (4), gbb (4), gcc (4)];
 172 [321, 321, 321];
 173
 174 [faa (4), fbb (4), fcc (4)];
 175 [444, 444, 444];
 176
 177 compile (faa, gaa, fbb, gbb, fcc, gcc);
 178 [faa, gaa, fbb, gbb, fcc, gcc];
 179
 180 [gaa (4), gbb (4), gcc (4)];
 181 [321, 321, 321];
 182
 183 [faa (4), fbb (4), fcc (4)];
 184 [444, 444, 444];
 185
 186 /* try same stuff again w/ undeclared arrays ...
 187  * no type spec => only one kind of array
 188  */
 189
 190 (kill (aa1, aa3, bb1, bb3, cc1, cc3),
 191  ?fmakunbound (faa),
 192  ?fmakunbound (fbb),
 193  [gaa (4), faa (4)]);
 194 [321, 444];
 195
 196 (translate (faa, gaa), [gaa (4), faa (4)]);
 197 [321, 444];
 198
 199 (compile (faa, gaa), [gaa (4), faa (4)]);
 200 [321, 444];
 201
 202 /* try same stuff again w/ Lisp arrays */
 203
 204 (kill (aa1, aa3, bb1, bb3, cc1, cc3),
 205  map (?fmakunbound, [faa, fbb, fcc, gaa, gbb, gcc]),
 206  aa1 : make_array (any, 15),
 207  aa3 : make_array (any, 12, 4, 6),
 208  bb1 : make_array (flonum, 15),
 209  bb3 : make_array (flonum, 5, 6, 7),
 210  cc1 : make_array (fixnum, 8),
 211  cc3 : make_array (fixnum, 6, 10, 4),
 212  0);
 213 0;
 214
 215 [gaa (4), gbb (4), gcc (4)];
 216 [321, 321, 321];
 217
 218 [faa (4), fbb (4), fcc (4)];
 219 [444, 444, 444];
 220
 221 translate (faa, gaa, fbb, gbb, fcc, gcc);
 222 [faa, gaa, fbb, gbb, fcc, gcc];
 223
 224 [gaa (4), gbb (4), gcc (4)];
 225 [321, 321, 321];
 226
 227 [faa (4), fbb (4), fcc (4)];
 228 [444, 444, 444];
 229
 230 compile (faa, gaa, fbb, gbb, fcc, gcc);
 231 [faa, gaa, fbb, gbb, fcc, gcc];
 232
 233 [gaa (4), gbb (4), gcc (4)];
 234 [321, 321, 321];
 235
 236 [faa (4), fbb (4), fcc (4)];
 237 [444, 444, 444];
 238
 239 /* SF bug # 2569: "translate rat(1,x) and rat([1]) incorrect" */
 240
 241 (kill (f), f () := rat (x, x), translate (f), f ());
 242 ''(rat (x, x));
 243
 244 (kill (f), f () := rat ([1]), translate (f), f ());
 245 ''(rat ([1]));
 246
 247 (kill (foo, y1a, y1b, y2a, y2b),
 248   foo(x) := block (mode_declare (x, float),
 249      [tanh (x), tan (x), sech (x), sec (x), acos (x), acot (x), sin (x),
 250       acsc (x), asinh (x), acsch (x), cosh (x), coth (x), realpart (x),
 251       asec (x), asin (x), erf (x), log (x), cos (x), cot (x), csc (x),
 252       sinh (x), csch (x), sqrt (x)]),
 253   0);
 254 0;
 255
 256 y1a : foo (0.5);
 257 [.4621171572600097,.5463024898437905,0.886818883970074,1.139493927324549,
 258  1.047197551196597,1.107148717794091,0.479425538604203,
 259  1.570796326794897-1.316957896924817*%i,.4812118250596035,1.44363547517881,
 260  1.127625965206381,2.163953413738653,0.5,1.316957896924817*%i,
 261  0.523598775598299,.5204998778130465,-.6931471805599453,.8775825618903728,
 262  1.830487721712452,2.085829642933488,.5210953054937474,1.919034751334944,
 263  .7071067811865476]$
 264
 265 y1b : foo (1.5);
 266 [.9051482536448664,14.10141994717172,.4250960349422805,14.1368329029699,
 267  .9624236501192069*%i,.5880026035475675,.9974949866040544,.7297276562269662,
 268  1.194763217287109,.6251451172504168,2.352409615243247,1.104791392982512,1.5,
 269  .8410686705679303,1.570796326794897-.9624236501192069*%i,.9661051464753108,
 270  .4054651081081644,0.0707372016677029,.07091484430265245,1.002511304246725,
 271  2.129279455094817,.4696424405952246,1.224744871391589]$
 272
 273 y1c : foo (1.0);
 274 [0.7615941559557649,1.557407724654902,0.6480542736638855,
 275  1.850815717680925,0.0,0.7853981633974483,0.8414709848078965,
 276  1.570796326794897,0.881373587019543,0.881373587019543,
 277  1.543080634815244,1.313035285499331,1.0,0.0,1.570796326794897,
 278  0.8427007929497148,0.0,0.5403023058681398,0.6420926159343306,
 279  1.188395105778121,1.175201193643801,0.8509181282393216,1.0]$
 280
 281 (translate (foo), y2a : foo (0.5), y2b : foo (1.5), 0);
 282 0;
 283
 284 is (y1a = y2a);
 285 true;
 286
 287 is (y1b = y2b);
 288 true;
 289
 290 block ([tr_float_can_branch_complex : false],
 291   translate (foo),
 292   y2c : foo (1.0),
 293   0);
 294 0;
 295
 296 is (y1c = y2c);
 297 true;
 298
 299 /* verify that save/compfile/compile_file/translate_file preserves upper/lower case in symbol names */
 300
 301 /* save */
 302
 303 (kill (all),
 304  foo (x) := my_foo * x,
 305  Foo (x) := my_Foo * x,
 306  FOO (x) := my_FOO * x,
 307  [my_foo, my_Foo, my_FOO] : [123, 456, 789],
 308  results : [foo (2), Foo (3), FOO (4)],
 309  my_test () := is (results = [2*123, 3*456, 4*789]),
 310  lisp_name : ssubst ("_", " ", build_info()@lisp_name),
 311  lisp_filename : sconcat (maxima_tempdir, "/tmp-rtest_translator-save-", lisp_name, ".lisp"),
 312  save (lisp_filename, values, functions),
 313  kill (allbut (lisp_filename)),
 314  load (lisp_filename),
 315  my_test ());
 316 true;
 317
 318 /* compfile */
 319
 320 (kill (all),
 321  foo (x) := my_foo * x,
 322  Foo (x) := my_Foo * x,
 323  FOO (x) := my_FOO * x,
 324  lisp_name : ssubst ("_", " ", build_info()@lisp_name),
 325  lisp_filename : sconcat (maxima_tempdir, "/tmp-rtest_translator-compfile-", lisp_name, ".lisp"),
 326  compfile (lisp_filename, functions),
 327  kill (functions),
 328  load (lisp_filename),
 329  [my_foo, my_Foo, my_FOO] : [123, 456, 789],
 330  results : [foo (2), Foo (3), FOO (4)],
 331  my_test () := is (results = [2*123, 3*456, 4*789]),
 332  my_test ());
 333 true;
 334
 335 /* compile_file */
 336
 337 /* skip this test (and fail) if Lisp = ECL because stream i/o causes "stack smashing" error
 338  * see: https://sourceforge.net/p/maxima/bugs/3291/
 339  */
 340 if build_info()@lisp_name # "ECL" then
 341 (kill (all),
 342  lisp_name : ssubst ("_", " ", build_info()@lisp_name),
 343  maxima_filename : sconcat (maxima_tempdir, "/tmp-rtest_translator-compile_file-", lisp_name, ".mac"),
 344  fasl_filename : sconcat (maxima_tempdir, "/tmp-rtest_translator-compile_file-", lisp_name, ".fasl"),
 345  lisp_filename : sconcat (maxima_tempdir, "/tmp-rtest_translator-compile_file-", lisp_name, ".LISP"),
 346  maxima_output : openw (maxima_filename),
 347  maxima_content :
 348 "foo (x) := my_foo * x;
 349 Foo (x) := my_Foo * x;
 350 FOO (x) := my_FOO * x;
 351 [my_foo, my_Foo, my_FOO] : [123, 456, 789];
 352 results : [foo (2), Foo (3), FOO (4)];
 353 my_test () := is (results = [2*123, 3*456, 4*789]);",
 354  printf (maxima_output, maxima_content),
 355  close (maxima_output),
 356  compile_file (maxima_filename, fasl_filename, lisp_filename),
 357  kill (allbut (lisp_filename)),
 358  load (lisp_filename),
 359  my_test ());
 360 true;
 361
 362 /* translate_file */
 363
 364 /* skip this test (and fail) if Lisp = ECL because stream i/o causes "stack smashing" error
 365  * see: https://sourceforge.net/p/maxima/bugs/3291/
 366  */
 367 if build_info()@lisp_name # "ECL" then
 368 (kill (all),
 369  lisp_name : ssubst ("_", " ", build_info()@lisp_name),
 370  maxima_filename : sconcat (maxima_tempdir, "/tmp-rtest_translator-translate_file-", lisp_name, ".mac"),
 371  lisp_filename : sconcat (maxima_tempdir, "/tmp-rtest_translator-translate_file-", lisp_name, ".LISP"),
 372  maxima_output : openw (maxima_filename),
 373  maxima_content :
 374 "foo (x) := my_foo * x;
 375 Foo (x) := my_Foo * x;
 376 FOO (x) := my_FOO * x;
 377 [my_foo, my_Foo, my_FOO] : [123, 456, 789];
 378 results : [foo (2), Foo (3), FOO (4)];
 379 my_test () := is (results = [2*123, 3*456, 4*789]);",
 380  printf (maxima_output, maxima_content),
 381  close (maxima_output),
 382  translate_file (maxima_filename, lisp_filename),
 383  kill (allbut (lisp_filename)),
 384  load (lisp_filename),
 385  my_test ());
 386 true;
 387
 388 /* Bug 2934:
 389
 390    Translating a literal exponent that comes out as a float shouldn't
 391    produce assigned type any. This test runs the translation for a
 392    trivial function that triggered the bug then looks in the unlisp
 393    file (which contains messages from the translator) and checks that
 394    there aren't any warnings.
 395 */
 396 /* skip this test (and fail) if Lisp = ECL because stream i/o causes "stack smashing" error
 397  * see: https://sourceforge.net/p/maxima/bugs/3291/
 398  */
 399 if build_info()@lisp_name # "ECL" then
 400 (kill (all),
 401  lisp_name : ssubst ("_", " ", build_info()@lisp_name),
 402  basename: sconcat (maxima_tempdir, "/tmp-rtest_translator-2934-", lisp_name),
 403  maxima_filename : sconcat (basename, ".mac"),
 404  lisp_filename : sconcat (basename, ".LISP"),
 405  maxima_output : openw (maxima_filename),
 406  maxima_content : "f () := block([y], mode_declare(y,float), y: 3^0.33, y)$",
 407  printf (maxima_output, maxima_content),
 408  close (maxima_output),
 409  translate_file (maxima_filename, lisp_filename),
 410  kill (allbut(basename)),
 411  /* Any warning messages end up at .UNLISP */
 412  block ([unlisp: openr (sconcat (basename, ".UNLISP")),
 413          line, acc: []],
 414    while stringp (line: readline(unlisp)) do
 415      if is ("warning" = split(line, ":")[1]) then push(line, acc),
 416    acc));
 417 []$
 418
 419 /* makelist translated incorrectly
 420  * SF bug #3083: "Error on compiling a working maxima function"
 421  */
 422
 423 (kill(all),
 424  f1(n) := makelist (1, n),
 425  f2(n) := makelist (i^2, i, n),
 426  f3(l) := makelist (i^3, i, l),
 427  f4(n) := makelist (i^4, i, 1, n),
 428  f5(m, n) := makelist (i^5, i, 1, n, m),
 429  translate(f1, f2, f3, f4, f5),
 430  0);
 431 0;
 432
 433 f1(5);
 434 [1,1,1,1,1];
 435
 436 f2(5);
 437 [1, 4, 9, 16, 25];
 438
 439 f3([1,2,3]);
 440 [1, 8, 27];
 441
 442 f4(4);
 443 [1, 16, 81, 256];
 444
 445 f5(2, 10);
 446 [1, 243, 3125, 16807, 59049];
 447
 448 /* original function from bug report */
 449
 450 (ordersort(lis,vars,oper):=block([negsumdispflag:false,liss:lis,varlist:vars,temp], /*Does lexicographical sort */
 451  for i:1 thru length(varlist) do (
 452      for j:1 thru i do (
 453          liss:sort(liss,lambda([x,y],apply("and",map(oper,makelist(part(x,2)[k],k,1,i)
 454                              ,makelist(part(y,2)[k],k,1,i)))))
 455      )),liss),
 456  translate (ordersort)); /* 'translate' doesn't trigger an error, so check return value */
 457 [ordersort];
 458
 459 [member ('transfun, properties(ordersort)),
 460  ordersort([[-7,[0,2,1]],[3,[1,2,1]],[1,[0,4,1]],[6,[4,3,3]],[6,[4,4,3]],[-7,[3,5,4]],[2,[0,0,5]],[-10,[2,2,5]],[-10,[3,4,7]],[7,[3,8,9]]],[x,y,z],">=")];
 461 [true, [[6,[4,4,3]],[6,[4,3,3]],[7,[3,8,9]],[-7,[3,5,4]],[-10,[3,4,7]],[-10,[2,2,5]],[3,[1,2,1]],[1,[0,4,1]],[-7,[0,2,1]],[2,[0,0,5]]]];
 462
 463 /* 'define' translated incorrectly, reported to mailing list circa 2017-01-24 */
 464
 465 (kill(foo, bar, baz, quux, mumble, blurf, umm, f, x, y),
 466  foo(y) := define(bar(x), x + y),
 467  baz(f, y) := define(funmake(f, [x]), x + y),
 468  quux() := (mumble(x) := 1 + x),
 469  [foo(10), baz(blurf, 20), quux()]);
 470 /* note that results match because rhs of ":=" isn't simplified */
 471 [bar(x) := 10 + x, blurf(x) := 20 + x, mumble(x) := 1 + x];
 472
 473 [bar(5), blurf(5), mumble(5)];
 474 [15, 25, 6];
 475
 476 (kill(bar, blurf, mumble),
 477  translate(foo, baz, quux),
 478  [foo(11), baz(umm, 21), quux()]);
 479 /* note that results match because rhs of ":=" isn't simplified */
 480 [bar(x) := 11 + x, umm(x) := 21 + x, mumble(x) := 1 + x];
 481
 482 makelist (is (x # false), x, map (?fboundp, [foo, baz, quux])); /* test for generalized Boolean value */
 483 [true, true, true];
 484
 485 [bar(5), umm(5), mumble(5)];
 486 [16, 26, 6];
 487
 488 /* mailing list 2017-03-04: "An example that is broken by compile()"
 489  * translated code tickles a bug elsewhere (bug not in translator)
 490  */
 491
 492 (kill(fun, trigfunc, t1),
 493  fun():=block([trigfunc],
 494         trigfunc:lambda([cur],cur>t1),
 495         apply('trigfunc,[1])),
 496  0);
 497 0;
 498
 499 /* I (Robert Dodier) believe this result should be trigfunc(1),
 500  * but, in any event, interpreted and compiled code should agree.
 501  * But if MAPPLY1 is ever changed, we can adjust these results.
 502  */
 503 fun();
 504 1 > t1;
 505
 506 (compile(fun), fun());
 507 1 > t1;
 508
 509 (kill(fun, trigfunc, t1),
 510  fun():=block([trigfunc],
 511         trigfunc:lambda([cur],cur>t1),
 512         apply(trigfunc,[1])),
 513  0);
 514 0;
 515
 516 fun();
 517 1 > t1;
 518
 519 (compile(fun), fun());
 520 1 > t1;
 521
 522 /* Verify that we catch malformed lambda expressions during translation.
 523  * More checks need to be added to the translator and more tests need to
 524  * be added here.
 525  */
 526
 527 /* no parameter list */
 528 (kill (f),
 529  f () := lambda (),
 530  translate (f))$
 531 [];
 532
 533 /* empty body */
 534 (kill (f),
 535  f () := lambda ([x]),
 536  translate (f))$
 537 [];
 538
 539 /* non-symbol in parameter list */
 540 (kill (f),
 541  f () := lambda ([42], 'foo),
 542  translate (f))$
 543 [];
 544
 545 /* misplaced "rest" parameter */
 546 (kill (f),
 547  f () := lambda ([[l], x], 'foo),
 548  translate (f))$
 549 [];
 550
 551 /* invalid "rest" parameter */
 552 (kill (f),
 553  f () := lambda ([[l1, l2]], 'foo),
 554  translate (f))$
 555 [];
 556
 557 /* attempting to bind a constant;
 558  * now OK, after commit 0517895
 559  */
 560 block ([c, f],
 561   local (c, f),
 562   declare (c, constant),
 563   f () := lambda ([c], c),
 564   translate (f))$
 565 [f];
 566
 567 /* Verify that parameter/variable lists cannot contain duplicate variables.
 568  *
 569  * We only test a couple of cases here.  Many more tests for non-translated
 570  * code are in rtest2.  Do we want to test them all here as well?
 571  */
 572
 573 (kill(f),
 574  f () := lambda ([x, [x]], x),
 575  translate (f))$
 576 [];
 577
 578 (kill(f),
 579  f () := block ([x, x:'foo], x),
 580  translate (f))$
 581 [];
 582
 583 /* ensure that a null OPERATORS property doesn't interfere with
 584  * translation of local variable used as a function name.
 585  * This is the bug that caused failures in rtest_fractals when executed after run_testsuite.
 586  */
 587
 588 (kill(aa, foobarbaz, mumbleblurf, hhh),
 589  matchdeclare (aa, all),
 590  tellsimp (mumbleblurf(aa), 1 - aa),
 591  kill (mumbleblurf), /* as of 2018-01-28, this leaves (OPERATORS NIL) in property list */
 592  hhh(mumbleblurf, u) := mumbleblurf(u),
 593  foobarbaz(x) := 100 + x,
 594  translate (hhh),
 595  hhh (foobarbaz, 11));
 596 111;
 597
 598 /* SF bug report #3402: "Unbinding defined variable generates error in compiled functions" */
 599
 600 define_variable (zorble, 0, fixnum);
 601 0;
 602
 603 (kill(f), f() := block ([zorble], 42), f());
 604 42;
 605
 606 translate(f);
 607 [f];
 608
 609 f();
 610 42;
 611
 612 /* bug reported to mailing list 2018-12-03: "error in compiling function with global variable" */
 613
 614 (test_f():= block( [a,b,c,d], niceindicespref:[a,b,c,d], disp("ciao"), return() ),
 615  0);
 616 0;
 617
 618 (test_f (), niceindicespref);
 619 [a,b,c,d];
 620
 621 (reset (niceindicespref),
 622  niceindicespref);
 623 [i,j,k,l,m,n];
 624
 625 (translate (test_f),
 626  test_f (),
 627  niceindicespref);
 628 [a,b,c,d];
 629
 630 (reset (niceindicespref), 0);
 631 0;
 632
 633 /* additional tests with variables which have ASSIGN property */
 634
 635 (set_error_stuff_permanently () :=
 636   block (error_syms : '[myerr1, myerr2, myerr3], error_size : 40),
 637  set_error_stuff_temporarily() :=
 638    block([error_syms : '[myerror1, myerror2, myerror3], error_size : 55],
 639          [error_syms, error_size]),
 640  0);
 641 0;
 642
 643 (reset (error_syms, error_size),
 644  set_error_stuff_permanently (),
 645  [error_syms, error_size]);
 646 [[myerr1, myerr2, myerr3], 40];
 647
 648 (reset (error_syms, error_size),
 649  translate (set_error_stuff_permanently),
 650  set_error_stuff_permanently (),
 651  [error_syms, error_size]);
 652 [[myerr1, myerr2, myerr3], 40];
 653
 654 (reset (error_syms, error_size),
 655  set_error_stuff_temporarily());
 656 [[myerror1, myerror2, myerror3], 55];
 657
 658 [error_syms, error_size];
 659 [[errexp1, errexp2, errexp3], 60];
 660
 661 (translate (set_error_stuff_temporarily),
 662  set_error_stuff_temporarily());
 663 [[myerror1, myerror2, myerror3], 55];
 664
 665 [error_syms, error_size];
 666 [[errexp1, errexp2, errexp3], 60];
 667
 668 (kill(all), reset(), 0);
 669 0;
 670
 671 /* SF bug #3412: "Bug when translating functions that contain an \"if\" (in my case an implicit if)" */
 672
 673 (f(x):=if cabs(1/(x+1)) < 1 then 1/(x+1) else 1,
 674  f(x + %i*y));
 675 if 1/sqrt(y^2+(x+1)^2) < 1 then 1/(%i*y+x+1) else 1;
 676
 677 makelist (f(xy[1] + %i*xy[2]), xy, [[0, 0], [0, 1], [1, 1], [1, 0], [0, 2], [2, 2], [2, 0]]);
 678 [1, 1/(%i+1), 1/(%i+2), 1/2, 1/(2*%i+1), 1/(2*%i+3), 1/3]$
 679
 680 (compile (f),
 681  errcatch (f(x + %i*y)));
 682 [];
 683
 684 '(f(x + %i*y));
 685 f(x + %i*y);
 686
 687 makelist (f(xy[1] + %i*xy[2]), xy, [[0, 0], [0, 1], [1, 1], [1, 0], [0, 2], [2, 2], [2, 0]]);
 688 [1, 1/(%i+1), 1/(%i+2), 1/2, 1/(2*%i+1), 1/(2*%i+3), 1/3]$
 689
 690 (if draw_version = 'draw_version then load (draw),
 691  draw3d(contour='map,
 692         proportional_axes=xy,
 693         nticks=100,
 694         contour_levels=20,
 695         explicit('(f(x+%i*y)),x,-2,2,y,-2,2)),
 696  0);
 697 0;
 698
 699 /* nested if example -- note top-level "if" doesn't have an "else" clause, so the result is sometimes 'false' */
 700
 701 (g(a, b, c) := if a + b > c
 702                  then (if a > c
 703                          then (if b > c
 704                                  then (a + b + c)
 705                                  elseif b > c/2
 706                                    then (a - b - c)
 707                                    else (b - a - c))
 708                          else (a/2)),
 709  0);
 710 0;
 711
 712 (aa: [3,9/4,5/4,11/4,1,0,9/4,1/4,5/2,9/4,3,5/2],
 713  bb: [3/2,3,1/4,3/4,5/2,7/4,5/2,3/4,1/2,3,13/4,7/2],
 714  cc: [7/2,15/4,5/2,5/4,15/4,1,1/4,7/4,2,11/4,1/4,7/4],
 715  map (g, aa, bb, cc));
 716 [3/2,9/8,false,3/4,false,0,5,false,-4,9/8,13/2,31/4]$
 717
 718 (translate (g),
 719  map (g, aa, bb, cc));
 720 [3/2,9/8,false,3/4,false,0,5,false,-4,9/8,13/2,31/4]$
 721
 722 errcatch (g(1, 1, z));
 723 [];
 724
 725 /* SF bug #3556: "5.43.0 translate / compile error"
 726  * Ensure that "if" within lambda is translated correctly.
 727  * The fix for #3412 tickled this bug.
 728  */
 729
 730 (kill (f),
 731  f(x, m) := map (lambda ([u], if m > 0 then u^m), [x, 2*x, 3*x]),
 732  0);
 733 0;
 734
 735 is (?fboundp (f) # false);
 736 false;
 737
 738 (kill (y),
 739  [f(y, 2), f(y, -2)]);
 740 [[y^2, 4*y^2, 9*y^2], [false, false, false]];
 741
 742 (kill (n),
 743  errcatch (f(10, n)));
 744 /* ensure that conditional expressions get simplified to expunge $FALSE ... sigh. */
 745 ''([[if n > 0 then 10^n, if n > 0 then 20^n, if n > 0 then 30^n]]);
 746
 747 translate (f);
 748 [f];
 749
 750 is (?fboundp (f) # false); /* test for generalized Boolean value */
 751 true;
 752
 753 [f(y, 2), f(y, -2)];
 754 [[y^2, 4*y^2, 9*y^2], [false, false, false]];
 755
 756 errcatch (f(10, n));
 757 [];
 758
 759 /* apply2 was translated incorrectly for several years.  applyb2
 760  * was translated incorrectly for decades.
 761  */
 762
 763 (defrule (foorule, foo (), 1),
 764  f () := apply2 ('(foo ()), foorule),
 765  translate (f),
 766  f ());
 767 1;
 768
 769 (defrule (barrule, bar (), 2),
 770  g () := applyb2 ('(bar ()), barrule),
 771  translate (g),
 772  g ());
 773 2;
 774
 775 (kill (foorule, f, barrule, g), 0);
 776 0;
 777
 778 /* atan and atan2 calls with float arguments were translated
 779  * incorrectly for over a decade.  atan always caused a lisp error
 780  * and atan2 had a range between 0 and 2*%pi that was inconsistent
 781  * with the interpreted and non-float cases (where the range is
 782  * between -%pi and %pi).
 783  */
 784
 785 (foo () := [atan2 (-1.0, -1.0), atan2 (-1.0, 1.0)],
 786  translate (foo),
 787  foo ());
 788 [-2.356194490192345, -0.7853981633974483];
 789
 790 (bar () := atan (-1.0),
 791  translate (bar),
 792  bar ());
 793 -0.7853981633974483;
 794
 795 (kill (foo, bar), 0);
 796 0;
 797
 798 /* The translation of a signum call with a float argument was
 799  * inconsistent when compared to the interpreted case and other
 800  * translated cases.  signum should return an integer or a float
 801  * when given an integer or a float argument, respectively.
 802  */
 803
 804 (foo () := [signum (0),  signum (0.0),
 805             signum (2),  signum (2.0),
 806             signum (-3), signum (-3.0)],
 807  translate (foo),
 808  foo ());
 809 [0, 0.0, 1, 1.0, -1, -1.0];
 810
 811 (kill (foo), 0);
 812 0;
 813
 814 /* The translation of declare was broken for decades.  It worked
 815  * under Maclisp, but it had never worked under Common Lisp.
 816  */
 817
 818 (foo () := declare (n, integer, [x, y], noninteger),
 819  translate (foo),
 820  foo (),
 821  [?kindp (n, integer),
 822   ?kindp (n, noninteger),
 823   ?kindp (x, integer),
 824   ?kindp (x, noninteger),
 825   ?kindp (y, integer),
 826   ?kindp (y, noninteger)]);
 827 [true, false, false, true, false, true];
 828
 829 (kill (foo, n, x, y), 0);
 830 0;
 831
 832 /* If a variable was declared to be of mode rational, then a lisp
 833  * error could occur during translation when attempting to convert
 834  * it to a float.
 835  */
 836
 837 (foo (x) := (mode_declare (x, rational), float (x)),
 838  bar (y) := (mode_declare (y, rational), 1.0 + y),
 839  translate (foo, bar),
 840  [foo (1/4), bar (1/2)]);
 841 [0.25, 1.5];
 842
 843 (kill (foo, bar, x, y), 0);
 844 0;
 845
 846 /* The translation of an atan2 call with one float and one rational
 847  * argument was broken because the rational was not converted to a
 848  * float before calling ATAN.
 849  */
 850
 851 (foo () :=
 852    [atan2 (0.0, -1/2),
 853     atan2 (-1/2, 0.0),
 854     atan2 (0.0, -1),
 855     atan2 (1, 0.0)],
 856  bar (y, x) := (mode_declare (x, float, y, rational), atan2 (y, x)),
 857  l1 : [foo (), bar (1/3, 0.0)],
 858  translate (foo, bar),
 859  l2 : [foo (), bar (1/3, 0.0)],
 860  is (l1 = l2));
 861 true;
 862
 863 (kill (foo, bar, x, y, l1, l2), 0);
 864 0;
 865
 866 /* When attempting to apply float contagion to the arguments, some
 867  * translations of max and min with mixed float and rational arguments
 868  * were broken because the rationals were not converted to floats before
 869  * calling MAX or MIN (like atan2 above).  Also, due to implementation-
 870  * dependent behavior in the underlying lisp regarding what to return
 871  * from MAX and MIN, the wrong mode could be used during translation and
 872  * some of the translations were possibly inconsistent with interpreted
 873  * cases.
 874  */
 875
 876 (foo (x) :=
 877    (mode_declare (x, rational),
 878     [max (),         min (),
 879      max (1),        min (1),
 880      max (1.0),      min (1.0),
 881      max (9/10),     min (9/10),
 882      max (x)   ,     min (x),
 883      max (0.0, 1),   min (0.0, 1),
 884      max (0, 1),     min (0, 1),
 885      max (1.0, 1),   min (1.0, 1),
 886      max (1, 1.0),   min (1, 1.0),
 887      max (2.0, 3.0), min (2.0, 3.0),
 888      max (-1, 1/2),  min (-1, 1/2),
 889      max (3/4, 1/2), min (3/4, 1/2),
 890      max (0.0, 1/2), min (0.0, 1/2),
 891      max (0, x),     min (0, x),
 892      max (-1.0, x),  min (-1.0, x),
 893      max (5/6, x),   min (5/6, x),
 894      max (x, 1),     min (x, 1)]),
 895  l1 : foo (2/3),
 896  translate (foo),
 897  l2 : foo (2/3),
 898  is (l1 = l2));
 899 true;
 900
 901 (kill (foo, x, l1, l2), 0);
 902 0;
 903
 904 /* log and sqrt did not honor tr_float_can_branch_complex */
 905
 906 (foo (x) :=
 907    (mode_declare (x, float),
 908     [log  (-1.0), log  (x),
 909      sqrt (-1.0), sqrt (x)]),
 910  /* l1 is a list of Maxima complex numbers */
 911  l1 : foo (-2.0),
 912  some (lambda ([x], freeof (%i, x)), l1));
 913 false;
 914
 915 block ([tr_float_can_branch_complex : false],
 916   translate (foo),
 917   /* l2 is a list of lisp complex numbers because we told the
 918    * translator to assume the return values of log and sqrt
 919    * would not be complex, and it correctly returned the complex
 920    * numbers returned by LOG and SQRT directly.
 921    */
 922   l2 : foo (-2.0),
 923   [every (?complexp, l2),
 924    every ("#", l1, l2)]);
 925 [true,
 926  true];
 927
 928 block ([tr_float_can_branch_complex : true],
 929   translate (foo),
 930   /* l3 is a list of Maxima complex numbers because we told the
 931    * translator to assume the return values of log and sqrt
 932    * could be complex, and it converted the lisp complex numbers
 933    * returned by LOG and SQRT to Maxima complex numbers.
 934    */
 935   l3 : foo (-2.0),
 936   every ("=", l1, l3));
 937 true;
 938
 939 (kill (foo, x, l1, l2, l3), 0);
 940 0;