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 /* 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;
  37
  38 /* SF [ 1728888 ] translator bugs: no mnot mprogn */
  39
  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];
  43
  44 (translate_or_lose (foo), foo ([1, 2, 3], [a, b]));
  45 [3];
  46
  47 /* simpler function featuring mprogn and mnot */
  48
  49 (bar (x) := (x : 2*x, x : 3*x, not (x < 100)), bar (3));
  50 false;
  51
  52 (translate_or_lose (bar), bar (3));
  53 false;
  54
  55 /* SF [ 1646525 ] no function mdoin */
  56
  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;
  60
  61 (translate_or_lose (try_me), try_me ([10, 9, 8, 7, 6, 5, 4, 5, 6, 7, 8, 9, 10]));
  62 40;
  63
  64 /* SF [ 1818645 ] Compiled maxima code containing $ARRAY gets a Lisp error. */
  65
  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];
  74
  75 (translate_or_lose (test_array_comp), test_array_comp (100));
  76 [abc, 100, 4];
  77
  78 /* SF [ 545794 ] Local Array does not compile properly */
  79
  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]];
  88
  89 (translate_or_lose (trial), trial (2));
  90 [true, [1, 2, 4, 8, 16, 32, 64, 128]];
  91
  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  */
  96
  97 [member (myvar, arrays), errcatch (listarray (myvar))];
  98 [false, []];
  99
 100 /* for loop variable not special
 101  * reported to mailing list 2009-08-13 "Why won't this compile?"
 102  */
 103
 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;
 110
 111 /* original example */
 112
 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;
 123
 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]$
 126
 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]$
 129
 130 /* incorrect code emitted for call from translated function to untranslated
 131  * SF bug # 2934064 "problem loading ezunits"
 132  */
 133
 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];
 140
 141 (translate_or_lose (f0003), f0001 (1));
 142 [1, 1];
 143
 144 (compile_or_lose (f0003), f0001 (1));
 145 [1, 1];
 146
 147 (compile_or_lose (f0003, f0002, f0001), f0001 (1));
 148 [1, 1];
 149
 150 /* SF bug # 2938716 "too much evaluation in translated code"
 151  */
 152
 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];
 162
 163 (translate_or_lose (g0003), g0001 (aa));
 164 [bb, bb];
 165
 166 (compile_or_lose (g0003), g0001 (aa));
 167 [bb, bb];
 168
 169 (compile_or_lose (g0003, g0002, g0001), g0001 (aa));
 170 [bb, bb];
 171
 172 /* SF bug # 3035313 "some array references translated incorrectly"
 173  */
 174
 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;
 184
 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;
 194
 195 [gaa (4), gbb (4), gcc (4)];
 196 [321, 321, 321];
 197
 198 [faa (4), fbb (4), fcc (4)];
 199 [444, 444, 444];
 200
 201 translate_or_lose (faa, gaa, fbb, gbb, fcc, gcc);
 202 [faa, gaa, fbb, gbb, fcc, gcc];
 203
 204 [gaa (4), gbb (4), gcc (4)];
 205 [321, 321, 321];
 206
 207 [faa (4), fbb (4), fcc (4)];
 208 [444, 444, 444];
 209
 210 compile_or_lose (faa, gaa, fbb, gbb, fcc, gcc);
 211 [faa, gaa, fbb, gbb, fcc, gcc];
 212
 213 [gaa (4), gbb (4), gcc (4)];
 214 [321, 321, 321];
 215
 216 [faa (4), fbb (4), fcc (4)];
 217 [444, 444, 444];
 218
 219 /* try same stuff again w/ undeclared arrays ...
 220  * no type spec => only one kind of array
 221  */
 222
 223 (kill (aa1, aa3, bb1, bb3, cc1, cc3),
 224  ?fmakunbound (faa),
 225  ?fmakunbound (fbb),
 226  [gaa (4), faa (4)]);
 227 [321, 444];
 228
 229 (translate_or_lose (faa, gaa), [gaa (4), faa (4)]);
 230 [321, 444];
 231
 232 (compile_or_lose (faa, gaa), [gaa (4), faa (4)]);
 233 [321, 444];
 234
 235 /* try same stuff again w/ Lisp arrays */
 236
 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;
 247
 248 [gaa (4), gbb (4), gcc (4)];
 249 [321, 321, 321];
 250
 251 [faa (4), fbb (4), fcc (4)];
 252 [444, 444, 444];
 253
 254 translate_or_lose (faa, gaa, fbb, gbb, fcc, gcc);
 255 [faa, gaa, fbb, gbb, fcc, gcc];
 256
 257 [gaa (4), gbb (4), gcc (4)];
 258 [321, 321, 321];
 259
 260 [faa (4), fbb (4), fcc (4)];
 261 [444, 444, 444];
 262
 263 compile_or_lose (faa, gaa, fbb, gbb, fcc, gcc);
 264 [faa, gaa, fbb, gbb, fcc, gcc];
 265
 266 [gaa (4), gbb (4), gcc (4)];
 267 [321, 321, 321];
 268
 269 [faa (4), fbb (4), fcc (4)];
 270 [444, 444, 444];
 271
 272 /* SF bug # 2569: "translate rat(1,x) and rat([1]) incorrect" */
 273
 274 (kill (f), f () := rat (x, x), translate_or_lose (f), f ());
 275 ''(rat (x, x));
 276
 277 (kill (f), f () := rat ([1]), translate_or_lose (f), f ());
 278 ''(rat ([1]));
 279
 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;
 288
 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]$
 297
 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]$
 305
 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]$
 314
 315 (translate_or_lose (foo), y2a : foo (0.5), y2b : foo (1.5), 0);
 316 0;
 317
 318 is (y1a = y2a);
 319 true;
 320
 321 is (y1b = y2b);
 322 true;
 323
 324 block ([tr_float_can_branch_complex : false],
 325   translate_or_lose (foo),
 326   y2c : foo (1.0),
 327   0);
 328 0;
 329
 330 is (y1c = y2c);
 331 true;
 332
 333 /* verify that save/compfile/compile_file/translate_file preserves upper/lower case in symbol names */
 334
 335 /* save */
 336
 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;
 351
 352 /* compfile */
 353
 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;
 368
 369 /* compile_file */
 370
 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;
 395
 396 /* translate_file */
 397
 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;
 421
 422 /* Bug 2934:
 423
 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 []$
 452
 453 /* makelist translated incorrectly
 454  * SF bug #3083: "Error on compiling a working maxima function"
 455  */
 456
 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;
 466
 467 f1(5);
 468 [1,1,1,1,1];
 469
 470 f2(5);
 471 [1, 4, 9, 16, 25];
 472
 473 f3([1,2,3]);
 474 [1, 8, 27];
 475
 476 f4(4);
 477 [1, 16, 81, 256];
 478
 479 f5(2, 10);
 480 [1, 243, 3125, 16807, 59049];
 481
 482 /* original function from bug report */
 483
 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]]]];
 499
 500 /* 'define' translated incorrectly, reported to mailing list circa 2017-01-24 */
 501
 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];
 509
 510 [bar(5), blurf(5), mumble(5)];
 511 [15, 25, 6];
 512
 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];
 518
 519 makelist (is (x # false), x, map (?fboundp, [foo, baz, quux])); /* test for generalized Boolean value */
 520 [true, true, true];
 521
 522 [bar(5), umm(5), mumble(5)];
 523 [16, 26, 6];
 524
 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  */
 528
 529 (kill(fun, trigfunc, t1),
 530  fun():=block([trigfunc],
 531         trigfunc:lambda([cur],cur>t1),
 532         apply('trigfunc,[1])),
 533  0);
 534 0;
 535
 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;
 542
 543 (compile_or_lose(fun), fun());
 544 1 > t1;
 545
 546 (kill(fun, trigfunc, t1),
 547  fun():=block([trigfunc],
 548         trigfunc:lambda([cur],cur>t1),
 549         apply(trigfunc,[1])),
 550  0);
 551 0;
 552
 553 fun();
 554 1 > t1;
 555
 556 (compile_or_lose(fun), fun());
 557 1 > t1;
 558
 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  */
 563
 564 /* no parameter list */
 565 (kill (f),
 566  f () := lambda (),
 567  translate (f))$
 568 [];
 569
 570 /* empty body */
 571 (kill (f),
 572  f () := lambda ([x]),
 573  translate (f))$
 574 [];
 575
 576 /* non-symbol in parameter list */
 577 (kill (f),
 578  f () := lambda ([42], 'foo),
 579  translate (f))$
 580 [];
 581
 582 /* misplaced "rest" parameter */
 583 (kill (f),
 584  f () := lambda ([[l], x], 'foo),
 585  translate (f))$
 586 [];
 587
 588 /* invalid "rest" parameter */
 589 (kill (f),
 590  f () := lambda ([[l1, l2]], 'foo),
 591  translate (f))$
 592 [];
 593
 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];
 603
 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  */
 609
 610 (kill(f),
 611  f () := lambda ([x, [x]], x),
 612  translate (f))$
 613 [];
 614
 615 (kill(f),
 616  f () := block ([x, x:'foo], x),
 617  translate (f))$
 618 [];
 619
 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  */
 624
 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;
 634
 635 /* SF bug report #3402: "Unbinding defined variable generates error in compiled functions" */
 636
 637 define_variable (zorble, 0, fixnum);
 638 0;
 639
 640 (kill(f), f() := block ([zorble], 42), f());
 641 42;
 642
 643 (translate_or_lose(f), f());
 644 42;
 645
 646 /* bug reported to mailing list 2018-12-03: "error in compiling function with global variable" */
 647
 648 (test_f():= block( [a,b,c,d], niceindicespref:[a,b,c,d], disp("ciao"), return() ),
 649  0);
 650 0;
 651
 652 (test_f (), niceindicespref);
 653 [a,b,c,d];
 654
 655 (reset (niceindicespref),
 656  niceindicespref);
 657 [i,j,k,l,m,n];
 658
 659 (translate_or_lose (test_f),
 660  test_f (),
 661  niceindicespref);
 662 [a,b,c,d];
 663
 664 (reset (niceindicespref), 0);
 665 0;
 666
 667 /* additional tests with variables which have ASSIGN property */
 668
 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;
 676
 677 (reset (error_syms, error_size),
 678  set_error_stuff_permanently (),
 679  [error_syms, error_size]);
 680 [[myerr1, myerr2, myerr3], 40];
 681
 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];
 687
 688 (reset (error_syms, error_size),
 689  set_error_stuff_temporarily());
 690 [[myerror1, myerror2, myerror3], 55];
 691
 692 [error_syms, error_size];
 693 [[errexp1, errexp2, errexp3], 60];
 694
 695 (translate_or_lose (set_error_stuff_temporarily),
 696  set_error_stuff_temporarily());
 697 [[myerror1, myerror2, myerror3], 55];
 698
 699 [error_syms, error_size];
 700 [[errexp1, errexp2, errexp3], 60];
 701
 702 (kill(all), reset(), 0);
 703 0;
 704
 705 /* SF bug #3412: "Bug when translating functions that contain an \"if\" (in my case an implicit if)" */
 706 /* Bug #4008: translator and prederror */
 707
 708 (f(x):=if cabs(1/(x+1)) < 1 then 1/(x+1) else 1,
 709  f(x + %i*y));
 710 if 1/sqrt(y^2+(x+1)^2) < 1 then 1/(%i*y+x+1) else 1;
 711
 712 makelist (f(xy[1] + %i*xy[2]), xy, [[0, 0], [0, 1], [1, 1], [1, 0], [0, 2], [2, 2], [2, 0]]);
 713 [1, 1/(%i+1), 1/(%i+2), 1/2, 1/(2*%i+1), 1/(2*%i+3), 1/3]$
 714
 715 compile_or_lose (f);
 716 [f];
 717
 718 block ([prederror : false],
 719   f(x + %i*y));
 720 if 1 - 1/sqrt(y^2+(x+1)^2) > 0 then 1/(%i*y+x+1) else 1;
 721
 722 block ([prederror : true],
 723   errcatch (f(x + %i*y)));
 724 [];
 725
 726 '(f(x + %i*y));
 727 f(x + %i*y);
 728
 729 makelist (f(xy[1] + %i*xy[2]), xy, [[0, 0], [0, 1], [1, 1], [1, 0], [0, 2], [2, 2], [2, 0]]);
 730 [1, 1/(%i+1), 1/(%i+2), 1/2, 1/(2*%i+1), 1/(2*%i+3), 1/3]$
 731
 732 (if draw_version = 'draw_version then load (draw),
 733  draw3d(contour='map,
 734         proportional_axes=xy,
 735         nticks=100,
 736         contour_levels=20,
 737         explicit('(f(x+%i*y)),x,-2,2,y,-2,2)),
 738  0);
 739 0;
 740
 741 /* nested if example -- note top-level "if" doesn't have an "else" clause, so the result is sometimes 'false' */
 742
 743 (g(a, b, c) := if a + b > c
 744                  then (if a > c
 745                          then (if b > c
 746                                  then (a + b + c)
 747                                  elseif b > c/2
 748                                    then (a - b - c)
 749                                    else (b - a - c))
 750                          else (a/2)),
 751  0);
 752 0;
 753
 754 (aa: [3,9/4,5/4,11/4,1,0,9/4,1/4,5/2,9/4,3,5/2],
 755  bb: [3/2,3,1/4,3/4,5/2,7/4,5/2,3/4,1/2,3,13/4,7/2],
 756  cc: [7/2,15/4,5/2,5/4,15/4,1,1/4,7/4,2,11/4,1/4,7/4],
 757  map (g, aa, bb, cc));
 758 [3/2,9/8,false,3/4,false,0,5,false,-4,9/8,13/2,31/4]$
 759
 760 (translate_or_lose (g),
 761  map (g, aa, bb, cc));
 762 [3/2,9/8,false,3/4,false,0,5,false,-4,9/8,13/2,31/4]$
 763
 764 block ([prederror : false],
 765   g (1, 1, z));
 766 ''(if 2 - z > 0 then (if 1 > z then (if 1 > z then z + 2 elseif 1 > z / 2 then -z else -z) else 1/2));
 767
 768 block ([prederror : true],
 769   errcatch (g (1, 1, z)));
 770 [];
 771
 772 /* SF bug #3556: "5.43.0 translate / compile error"
 773  * Ensure that "if" within lambda is translated correctly.
 774  * The fix for #3412 tickled this bug.
 775  */
 776
 777 (kill (f),
 778  f(x, m) := map (lambda ([u], if m > 0 then u^m), [x, 2*x, 3*x]),
 779  0);
 780 0;
 781
 782 is (?fboundp (f) # false);
 783 false;
 784
 785 (kill (y),
 786  [f(y, 2), f(y, -2)]);
 787 [[y^2, 4*y^2, 9*y^2], [false, false, false]];
 788
 789 (kill (n),
 790  errcatch (f(10, n)));
 791 /* ensure that conditional expressions get simplified to expunge $FALSE ... sigh. */
 792 ''([[if n > 0 then 10^n, if n > 0 then 20^n, if n > 0 then 30^n]]);
 793
 794 (translate_or_lose (f),
 795  is (?fboundp (f) # false)); /* test for generalized Boolean value */
 796 true;
 797
 798 [f(y, 2), f(y, -2)];
 799 [[y^2, 4*y^2, 9*y^2], [false, false, false]];
 800
 801 block ([prederror : false],
 802   f(10, n));
 803 ''([if n > 0 then 10^n, if n > 0 then 20^n, if n > 0 then 30^n]);
 804
 805 block ([prederror : true],
 806   errcatch (f(10, n)));
 807 [];
 808
 809 /* apply2 was translated incorrectly for several years.  applyb2
 810  * was translated incorrectly for decades.
 811  */
 812
 813 (defrule (foorule, foo (), 1),
 814  f () := apply2 ('(foo ()), foorule),
 815  translate_or_lose (f),
 816  f ());
 817 1;
 818
 819 (defrule (barrule, bar (), 2),
 820  g () := applyb2 ('(bar ()), barrule),
 821  translate_or_lose (g),
 822  g ());
 823 2;
 824
 825 (kill (foorule, f, barrule, g), 0);
 826 0;
 827
 828 /* atan and atan2 calls with float arguments were translated
 829  * incorrectly for over a decade.  atan always caused a lisp error
 830  * and atan2 had a range between 0 and 2*%pi that was inconsistent
 831  * with the interpreted and non-float cases (where the range is
 832  * between -%pi and %pi).
 833  */
 834
 835 (foo () := [atan2 (-1.0, -1.0), atan2 (-1.0, 1.0)],
 836  translate_or_lose (foo),
 837  foo ());
 838 [-2.356194490192345, -0.7853981633974483];
 839
 840 (bar () := atan (-1.0),
 841  translate_or_lose (bar),
 842  bar ());
 843 -0.7853981633974483;
 844
 845 (kill (foo, bar), 0);
 846 0;
 847
 848 /* The translation of a signum call with a float argument was
 849  * inconsistent when compared to the interpreted case and other
 850  * translated cases.  signum should return an integer or a float
 851  * when given an integer or a float argument, respectively.
 852  */
 853
 854 (foo () := [signum (0),  signum (0.0),
 855             signum (2),  signum (2.0),
 856             signum (-3), signum (-3.0)],
 857  translate_or_lose (foo),
 858  foo ());
 859 [0, 0.0, 1, 1.0, -1, -1.0];
 860
 861 (kill (foo), 0);
 862 0;
 863
 864 /* The translation of declare was broken for decades.  It worked
 865  * under Maclisp, but it had never worked under Common Lisp.
 866  */
 867
 868 (foo () := declare (n, integer, [x, y], noninteger),
 869  translate_or_lose (foo),
 870  foo (),
 871  [?kindp (n, integer),
 872   ?kindp (n, noninteger),
 873   ?kindp (x, integer),
 874   ?kindp (x, noninteger),
 875   ?kindp (y, integer),
 876   ?kindp (y, noninteger)]);
 877 [true, false, false, true, false, true];
 878
 879 (kill (foo, n, x, y), 0);
 880 0;
 881
 882 /* If a variable was declared to be of mode rational, then a lisp
 883  * error could occur during translation when attempting to convert
 884  * it to a float.
 885  */
 886
 887 (foo (x) := (mode_declare (x, rational), float (x)),
 888  bar (y) := (mode_declare (y, rational), 1.0 + y),
 889  translate_or_lose (foo, bar),
 890  [foo (1/4), bar (1/2)]);
 891 [0.25, 1.5];
 892
 893 (kill (foo, bar, x, y), 0);
 894 0;
 895
 896 /* The translation of an atan2 call with one float and one rational
 897  * argument was broken because the rational was not converted to a
 898  * float before calling ATAN.
 899  */
 900
 901 (foo () :=
 902    [atan2 (0.0, -1/2),
 903     atan2 (-1/2, 0.0),
 904     atan2 (0.0, -1),
 905     atan2 (1, 0.0)],
 906  bar (y, x) := (mode_declare (x, float, y, rational), atan2 (y, x)),
 907  l1 : [foo (), bar (1/3, 0.0)],
 908  translate_or_lose (foo, bar),
 909  l2 : [foo (), bar (1/3, 0.0)],
 910  is (l1 = l2));
 911 true;
 912
 913 (kill (foo, bar, x, y, l1, l2), 0);
 914 0;
 915
 916 /* When attempting to apply float contagion to the arguments, some
 917  * translations of max and min with mixed float and rational arguments
 918  * were broken because the rationals were not converted to floats before
 919  * calling MAX or MIN (like atan2 above).  Also, due to implementation-
 920  * dependent behavior in the underlying lisp regarding what to return
 921  * from MAX and MIN, the wrong mode could be used during translation and
 922  * some of the translations were possibly inconsistent with interpreted
 923  * cases.
 924  */
 925
 926 (foo (x) :=
 927    (mode_declare (x, rational),
 928     [max (),         min (),
 929      max (1),        min (1),
 930      max (1.0),      min (1.0),
 931      max (9/10),     min (9/10),
 932      max (x)   ,     min (x),
 933      max (0.0, 1),   min (0.0, 1),
 934      max (0, 1),     min (0, 1),
 935      max (1.0, 1),   min (1.0, 1),
 936      max (1, 1.0),   min (1, 1.0),
 937      max (2.0, 3.0), min (2.0, 3.0),
 938      max (-1, 1/2),  min (-1, 1/2),
 939      max (3/4, 1/2), min (3/4, 1/2),
 940      max (0.0, 1/2), min (0.0, 1/2),
 941      max (0, x),     min (0, x),
 942      max (-1.0, x),  min (-1.0, x),
 943      max (5/6, x),   min (5/6, x),
 944      max (x, 1),     min (x, 1)]),
 945  l1 : foo (2/3),
 946  translate_or_lose (foo),
 947  l2 : foo (2/3),
 948  is (l1 = l2));
 949 true;
 950
 951 (kill (foo, x, l1, l2), 0);
 952 0;
 953
 954 /* log and sqrt did not honor tr_float_can_branch_complex */
 955
 956 (foo (x) :=
 957    (mode_declare (x, float),
 958     [log  (-1.0), log  (x),
 959      sqrt (-1.0), sqrt (x)]),
 960  /* l1 is a list of Maxima complex numbers */
 961  l1 : foo (-2.0),
 962  some (lambda ([x], freeof (%i, x)), l1));
 963 false;
 964
 965 block ([tr_float_can_branch_complex : false],
 966   translate_or_lose (foo),
 967   /* l2 is a list of lisp complex numbers because we told the
 968    * translator to assume the return values of log and sqrt
 969    * would not be complex, and it correctly returned the complex
 970    * numbers returned by LOG and SQRT directly.
 971    */
 972   l2 : foo (-2.0),
 973   [every (?complexp, l2),
 974    every ("#", l1, l2)]);
 975 [true,
 976  true];
 977
 978 block ([tr_float_can_branch_complex : true],
 979   translate_or_lose (foo),
 980   /* l3 is a list of Maxima complex numbers because we told the
 981    * translator to assume the return values of log and sqrt
 982    * could be complex, and it converted the lisp complex numbers
 983    * returned by LOG and SQRT to Maxima complex numbers.
 984    */
 985   l3 : foo (-2.0),
 986   every (lambda ([x, y], cabs (x - y) < 1e-15), l1, l3));
 987 true;
 988
 989 (kill (foo, x, l1, l2, l3), 0);
 990 0;
 991
 992 /* The translations for evaluating = and # expressions to boolean
 993  * values with one float argument and a different numerical argument
 994  * (e.g. a fixnum) gave bogus results because the translator was
 995  * incorrectly applying float contagion to the arguments.
 996  */
 997
 998 (foo (s, w, x, y, z) :=
 999   (mode_declare (w, number, x, fixnum, y, flonum),
1000    [/* These translate to EQL comparisons */
1001     is (1 = 1),                 is (1 # 1),
1002     is (1 = 1.0),               is (1 # 1.0),
1003     is (1 = float (1)),         is (1 # float (1)),
1004     is (1.0 = float (1)),       is (1.0 # float (1)),
1005     is (w = 2),                 is (w # 2),
1006     is (w = 2.0),               is (w # 2.0),
1007     is (x = 3),                 is (x # 3),
1008     is (x = 3.0),               is (x # 3.0),
1009     is (x = float (3)),         is (x # float (3)),
1010     is (x = float (x)),         is (x # float (x)),
1011     is (y = 4),                 is (y # 4),
1012     is (y = 4.0),               is (y # 4.0),
1013     is (y = float (4)),         is (y # float (4)),
1014     is (y = float (y)),         is (y # float (y)),
1015     /* These translate to LIKE comparisons */
1016     is (z = 5),                 is (z # 5),
1017     is (z = 5.0),               is (z # 5.0),
1018     is (z = float (5)),         is (z # float (5)),
1019     is (z = float (z)),         is (z # float (z)),
1020     is (1/2 = 1/2),             is (1/2 # 1/2),
1021     is (1/2 = rat (1/2)),       is (1/2 # rat (1/2)),
1022     is (rat (1/2) = rat (1/2)), is (rat (1/2) # rat (1/2)),
1023     is (1/2 = 0.5),             is (1/2 # 0.5),
1024     is (1/2 = float (1/2)),     is (1/2 # float (1/2)),
1025     is (%i = %i),               is (%i # %i),
1026     is (1 + %i = 1 + %i),       is (1 + %i # 1 + %i),
1027     is (s = s),                 is (s # s),
1028     is (s = 'bar),              is (s # 'bar),
1029     is (s = 1),                 is (s # 1),
1030     is (s = 1.0),               is (s # 1.0),
1031     is (s = 1/2),               is (s # 1/2),
1032     is ('f (0) = 'f (0)),       is ('f (0) # 'f (0)),
1033     is ('g (s) = 'g (s)),       is ('g (s) # 'g (s)),
1034     is ('h (w) = 'h (w)),       is ('h (w) # 'h (w)),
1035     is ('i (x) = 'i (x)),       is ('i (x) # 'i (x)),
1036     is ('j (y) = 'j (y)),       is ('j (y) # 'j (y)),
1037     is ('k (z) = 'k (z)),       is ('k (z) # 'k (z))]),
1038  l1 : foo ('bar, 2, 3, 4.0, 5),
1039  translate_or_lose (foo),
1040  l2 : foo ('bar, 2, 3, 4.0, 5),
1041  [every (lambda ([x], ?typep (x, ?boolean)), l2),
1042   is (l1 = l2)]);
1043 [true,
1044  true];
1045
1046 (kill (foo, w, x, y, l1, l2), 0);
1047 0;
1048
1049 /* Bug #3048: notequal is not translated properly
1050  *
1051  * notequal expressions were only generically translated like user
1052  * function calls and the use of notequal in translated code caused
1053  * a runtime warning about it being totally undefined.  Also the
1054  * evaluation of notequal expressions to boolean values (via is, if,
1055  * etc.) were translated like the evaluation of an unknown predicate.
1056  */
1057
1058 (assume (equal (a, b), notequal (c, d)),
1059  foo () :=
1060   [is (equal (1, 1)),
1061    is (notequal (1, 1)),
1062    is (equal (1, 1.0)),
1063    is (notequal (1, 1.0)),
1064    is (equal (1, 1.0b0)),
1065    is (notequal (1, 1.0b0)),
1066    is (equal (1/2, 0.5)),
1067    is (notequal (1/2, 0.5)),
1068    is (equal (1/2, 0.5b0)),
1069    is (notequal (1/2, 0.5b0)),
1070    is (equal (1, 2)),
1071    is (notequal (1, 2)),
1072    is (equal ('ind, 'ind)),
1073    is (notequal ('ind, 'ind)),
1074    is (equal ('und, 'und)),
1075    is (notequal ('und, 'und)),
1076    is (equal ('a, 'b)),
1077    is (notequal ('a, 'b)),
1078    is (equal ('c, 'd)),
1079    is (notequal ('c, 'd)),
1080    is (equal (x^2 - 1, (x + 1) * (x - 1))),
1081    is (notequal (x^2 - 1, (x + 1) * (x - 1)))],
1082  l1 : foo (),
1083  translate_or_lose (foo),
1084  l2 : foo (),
1085  [every (lambda ([x], ?typep (x, ?boolean)), l2),
1086   is (l1 = l2)]);
1087 [true,
1088  true];
1089
1090 (kill (foo, l1, l2),
1091  forget (equal (a, b), notequal (c, d)),
1092  0);
1093 0;
1094
1095 /* The translation of a call to random with a float argument could
1096  * cause the generation of bogus code because this always had the
1097  * mode of fixnum.
1098  */
1099
1100 (foo (w, x, y, z) :=
1101   (mode_declare (w, fixnum, x, float),
1102    [[random (10),
1103      random (w),
1104      random (y)],
1105     [random (1.0),
1106      random (x),
1107      random (z),
1108      random (x) / 2,
1109      random (z) / 2,
1110      1 / (1 + random (x))],
1111     [random (10) / 2,
1112      random (w) / 3,
1113      random (y) / 4,
1114      1 / (1 + random (w)),
1115      1 / (1 + random (y))]]),
1116  translate_or_lose (foo),
1117  l : foo (50, 5.0, 100, 10.0),
1118  [every (integerp, first (l)),
1119   every (floatnump, second (l)),
1120   every (ratnump, third (l))]);
1121 [true,
1122  true,
1123  true];
1124
1125 (kill (foo, w, x, l), 0);
1126 0;
1127
1128 /* acosh, asech, atanh and acoth now have special translations for
1129  * float arguments.  These all honor tr_float_can_branch_complex.
1130  */
1131
1132 (foo (x) :=
1133    (mode_declare (x, float),
1134     [acosh (x), asech (x), atanh (x)]),
1135  bar (x) :=
1136    (mode_declare (x, float),
1137     [acoth (x)]),
1138  /* l1 is a list of Maxima complex numbers */
1139  l1 : append (foo (-3.0), foo (-2.0), bar (-0.5), bar (0.5)),
1140  some (lambda ([x], freeof (%i, x)), l1));
1141 false;
1142
1143 block ([tr_float_can_branch_complex : false],
1144   translate_or_lose (foo, bar),
1145   /* l2 is a list of lisp complex numbers because we told the
1146    * translator to assume the return values would not be complex,
1147    * and it correctly returned the lisp complex numbers directly.
1148    */
1149   l2 : append (foo (-3.0), foo (-2.0), bar (-0.5), bar (0.5)),
1150   [every (?complexp, l2),
1151    every ("#", l1, l2),
1152    every ("=", l1, map (?complexify, l2))]);
1153 [true,
1154  true,
1155  true];
1156
1157 block ([tr_float_can_branch_complex : true],
1158   translate_or_lose (foo, bar),
1159   /* l3 is a list of Maxima complex numbers because we told the
1160    * translator to assume the return values could be complex, and
1161    * it converted the lisp complex numbers to Maxima complex numbers.
1162    */
1163   l3 : append (foo (-3.0), foo (-2.0), bar (-0.5), bar (0.5)),
1164   every ("=", l1, l3));
1165 true;
1166
1167 (kill (foo, bar, x, l1, l2, l3), 0);
1168 0;
1169
1170 /* Bug #3642: Lisp error when translating assume
1171  *
1172  * Translating an assume call with an atomic argument would cause a
1173  * lisp error during translation.
1174  */
1175
1176 (foo () :=
1177    block ([ctx : supcontext (),
1178            x : a > 0,
1179            y : b > 0,
1180            r],
1181      assume (x, y, equal (c, 0)),
1182      r : [is (a > 0), is (b < 0), is (equal (c, 0))],
1183      killcontext (ctx),
1184      r),
1185  translate_or_lose (foo),
1186  foo ());
1187 [true, false, true];
1188
1189 (kill (foo), 0);
1190 0;
1191
1192 /* The translation of errcatch was broken because the mode of the
1193  * whole form was always assumed to be the same as the mode of the
1194  * last subform.  Since errcatch always yields a list, lisp errors
1195  * could easily occur.
1196  */
1197
1198 (foo () :=
1199    block ([listarith : true],
1200      [errcatch (1),
1201       1 + errcatch (2),
1202       1.0 * errcatch (2.0),
1203       errcatch (error ("oops")),
1204       errcatch (?error ("oops")),
1205       errcatch (1 / 0)]),
1206  translate_or_lose (foo),
1207  foo ());
1208 [[1],
1209  [3],
1210  [2.0],
1211  [],
1212  [],
1213  []];
1214
1215 (kill (foo), 0);
1216 0;
1217
1218 /* Attempting to translate multiple functions containing local would
1219  * cause an error.  Similarly, translating the same function multiple
1220  * times would cause an error if that function contained local.
1221  */
1222
1223 (foo () := local (), /* just something with local (not within a block) */
1224  bar () := local (), /* something else with local (not within a block) */
1225  translate_or_lose (foo),
1226  translate_or_lose (bar),
1227  translate_or_lose (foo, bar));
1228 [foo, bar];
1229
1230 (kill (foo, bar), 0);
1231 0;
1232
1233 /* Bug #2976: "local" doesn't work in translated code
1234  *
1235  * For decades no attempt was being made to clean up any local
1236  * properties.
1237  */
1238
1239 /* The internal LOCLIST used by local should be empty right now */
1240 ?null (?loclist);
1241 true;
1242
1243 (f0 () := "one",
1244  foo1 () :=
1245    (local (f0),
1246     f0 () := "two",
1247     f0 ()),
1248  translate_or_lose (foo1),
1249  block ([v : foo1 ()],
1250    [f0 (), v]));
1251 ["one", "two"];
1252
1253 (kill (f0, foo1), 0);
1254 0;
1255
1256 (arr1 [0] : "three",
1257  foo2 () :=
1258    block ([g : lambda ([],
1259                  local (arr1, arr2),
1260                  arr1 [0] : "four",
1261                  arr2 [5] : "five",
1262                  [arr1 [0],
1263                   arr2 [5],
1264                   arrayinfo (arr2)])],
1265      apply (g, [])),
1266  translate_or_lose (foo2),
1267  block ([v : foo2 ()],
1268    [arr1 [0],
1269     v,
1270     errcatch (arrayinfo (arr2))]));
1271 ["three",
1272  ["four",
1273   "five",
1274   [hashed, 1, [5]]],
1275  []];
1276
1277 (kill (arr1, foo2), 0);
1278 0;
1279
1280 (foo3 (n) :=
1281    (local (h),
1282     h () := n + 1,
1283     if n = 10 then
1284       n
1285     else
1286       foo3 (h ())),
1287  translate_or_lose (foo3),
1288  foo3 (0));
1289 10;
1290
1291 (kill (foo3), 0);
1292 0;
1293
1294 /* The internal LOCLIST used by local should be empty right now */
1295 ?null (?loclist);
1296 true;
1297
1298 /* The fpprintprec itself is not important in this test.  I'm
1299  * just picking something that has an ASSIGN property because
1300  * that's a separate internal case in the translator.
1301  *
1302  * This test is ugly, but it's testing different cases and
1303  * their interactions.
1304  */
1305 block ([v],
1306   local (f1, f2, arr),
1307   f1 () := 0,
1308   f2 () := 123,
1309   arr [1] : "a",
1310   bar (fpprintprec) :=
1311     (local (f1, arr),
1312      fpprintprec : 5,
1313      f1 () := 42,
1314      arr [1] : "b",
1315      [block (
1316         local (f2, arr),
1317         f2 () := 69,
1318         arr [1] : "c",
1319         [f1 (), f2 (), arr [1]]),
1320       [f1 (), f2 (), arr [1]]]),
1321   translate_or_lose (bar),
1322   v : bar (3),
1323   [is (?get ('fpprintprec, '?assign) = false),
1324    v,
1325    [f1 (), f2 (), arr [1]]]);
1326 [false,
1327  [[42, 69, "c"],
1328   [42, 123, "b"]],
1329  [0, 123, "a"]];
1330
1331 (kill (bar), 0);
1332 0;
1333
1334 /* This is testing to make sure there are no bad interactions
1335  * between the usual local cleanup and errcatch cleanup (this
1336  * also mixes the interpreted and translated cases).  This test
1337  * is also ugly.
1338  *
1339  * The original implementation of local properties (from decades
1340  * ago) not only failed to clean up local properties at all, but
1341  * it wasn't even setting up the internal state to keep up with
1342  * these properties correctly.  An initial attempt at fixing bug
1343  * #2976 made this problem clear because with that it was easy to
1344  * cause an infinite loop during certain things like errcatch
1345  * cleanup.
1346  */
1347 block ([translate : false,
1348         vi, vt],
1349   local (f3),
1350   f3 () := -10,
1351   baz1 () :=
1352     (error ("oops 1"),
1353      local (f4),
1354      f4 () := 0),
1355   baz2 () :=
1356     (local (f5),
1357      f5 () := 1,
1358      error ("oops 2")),
1359   translate_or_lose (baz1, baz2),
1360   baz_test () :=
1361     [block (
1362        local (f3),
1363        f3 () := -1,
1364        errcatch (baz1 ()),
1365        f3 ()),
1366      block (
1367        local (f3),
1368        f3 () := -2,
1369        errcatch (baz2 ()),
1370        f3 ())],
1371   vi : baz_test (),
1372   translate_or_lose (baz_test),
1373   vt : baz_test (),
1374   [vi,
1375    vt,
1376    is (f3 () = -10),
1377    is (f4 () = 0),
1378    is (f5 () = 1)]);
1379 [[-1, -2],
1380  [-1, -2],
1381  true,
1382  false,
1383  false];
1384
1385 /* The internal LOCLIST used by local should be empty right now */
1386 ?null (?loclist);
1387 true;
1388
1389 (kill (baz1, baz2, baz_test), 0);
1390 0;
1391
1392 /***** This ends the bug #2976 tests *****/
1393
1394 /* compile wasn't always compiling the correct function
1395  *
1396  * This test not only depends on the internal details of how certain
1397  * functions are currently translated, but it also depends on internal
1398  * details about how DEFMFUN defines functions.  This also doesn't
1399  * really test that the correct function gets compiled because the
1400  * lisp implementation could have just compiled it itself anyway.  Ugh.
1401  */
1402
1403 (foo () := 1,
1404  compile_or_lose (foo),
1405  ?compiled\-function\-p (?symbol\-function (?get (foo, ?impl\-name))));
1406 true;
1407
1408 (kill (foo), 0);
1409 0;
1410
1411 /* Some internal function definitions and compiler macros were not
1412  * being cleaned up, and this could cause confusing and bogus results
1413  * when an outdated compiler macro was being used.
1414  *
1415  * Specifically one problem we had involved translating a function,
1416  * redefining it and then translating the new definition.  The internal
1417  * function and compiler macro from the original function could be used
1418  * when compiling calls to the new function if they were not overwritten.
1419  *
1420  * This all depended on lisp implementation-dependent behavior because
1421  * implementations are not required to ever use compiler macros.  Ugh.
1422  *
1423  * This test also depends on internal details of how certain functions
1424  * are currently translated.  Double ugh.
1425  */
1426
1427 (foo () := 0,
1428  translate_or_lose (foo),
1429  kill (foo),
1430  foo ([l]) := l,
1431  translate_or_lose (foo),
1432  test1 () := foo (),
1433  test2 () := foo (1, 2, 3),
1434  compile_or_lose (test1, test2),
1435  /* Previously we observed test1 returning 0 and test2 causing a lisp
1436   * error because the compiler macro and old internal function from
1437   * the first foo were being used.
1438   */
1439  [test1 (), test2 ()]);
1440 [[], [1, 2, 3]];
1441
1442 (kill (foo, test1, test2), 0);
1443 0;
1444
1445 /* https://stackoverflow.com/questions/64631208/compilation-global-variables-with-warning
1446  *
1447  * First verify that error_syms and niceindicespref assignments work as expected.
1448  */
1449
1450 kill (aa, bb, cc);
1451 done;
1452
1453 errcatch (error_syms: 123);
1454 [];
1455
1456 errcatch (error_syms: [aa, bb, 123]);
1457 [];
1458
1459 error_syms: [aa, bb, cc];
1460 [aa, bb, cc];
1461
1462 errcatch (niceindicespref: 123);
1463 [];
1464
1465 errcatch (niceindicespref: []);
1466 [];
1467
1468 niceindicespref: [aa, bb, cc];
1469 [aa, bb, cc];
1470
1471 (reset (error_syms, niceindicespref), 0);
1472 0;
1473
1474 /* now the example from the Stackoverflow question */
1475
1476 (program_content:
1477 "define_variable(foo, true, boolean)$
1478 foo: true$
1479
1480 exprp(that) := if foo = false and listp(that) and not emptyp(that) and member(that[1], [\"+\", \"*\"]) then(foo: true, true)$
1481 matchdeclare(exprm, exprp)$
1482 defrule(rule_1, exprm, subst(exprm[1], \"[\", exprm[2]))$
1483
1484 calc(list) := block([steps: []],
1485 while foo do(
1486     steps: endcons(list, steps),
1487     foo: false,
1488     list: applyb1(list, rule_1)
1489 ),
1490 steps
1491 )$
1492
1493 calc_result: calc([\"+\", [[\"*\", [1, 2, 3]], [\"+\", [3, 4, 6]]]]);",
1494 program_file_name: sconcat (maxima_tempdir, "/tmp_program.mac"),
1495 with_stdout (program_file_name, print (program_content)),
1496 0);
1497 0;
1498
1499 kill (calc_result);
1500 done;
1501
1502 ([file_name_original, file_name_LISP, file_name_UNLISP, file_name_compiled]: compile_file (program_file_name), 0);
1503 0;
1504
1505 stringp (file_name_compiled);
1506 true;
1507
1508 calc_result;
1509 calc_result;
1510
1511 (load (file_name_compiled),
1512  calc_result);
1513 [["+", [["*", [1, 2, 3]], ["+", [3, 4, 6]]]],
1514  ["+", [6, ["+", [3, 4, 6]]]],
1515  ["+", [6, 13]],
1516  19];
1517
1518 (kill (program_content, program_file_name, file_name_original, file_name_LISP, file_name_UNLISP, file_name_compiled, calc_result), 0);
1519 0;
1520
1521
1522 /* Some additional basic tests for functions with rest args */
1523
1524 block ([translate : false],
1525   foo ([r]) := r,
1526   bar (a, b, [c]) := [a, b, c],
1527   test () :=
1528     [foo (),
1529      foo (1),
1530      foo (1, 2, 3),
1531      errcatch (bar ()),
1532      errcatch (bar (1)),
1533      bar (1, 2),
1534      bar (1, 2, 3),
1535      bar (1, 2, 3, 4, 5)],
1536
1537   /* l1: foo, bar and test are interpreted */
1538   l1 : test (),
1539
1540   /* l2: foo and bar are translated, and test is interpreted */
1541   translate_or_lose (foo, bar),
1542   l2 : test (),
1543
1544   /* l3: foo, bar and test are translated */
1545   translate_or_lose (test),
1546   l3 : test (),
1547
1548   [is (l1 = l2),
1549    is (l2 = l3),
1550    l1]);
1551 [true,
1552  true,
1553  [[],
1554   [1],
1555   [1, 2, 3],
1556   [],
1557   [],
1558   [1, 2, []],
1559   [1, 2, [3]],
1560   [1, 2, [3, 4, 5]]]];
1561
1562 (kill (foo, bar, test, l1, l2, l3), 0);
1563 0;
1564
1565 /* Attempting to translate a macro with a rest arg always caused an
1566  * error during translation because the translator was constructing
1567  * bogus Maclisp-style lexpr lambda expressions.
1568  */
1569
1570 block ([translate : false],
1571   foo ([r]) ::=
1572     buildq ([r], ['r, r]),
1573   bar (a, b, [c]) ::=
1574     buildq ([a, b, c], ['a, a, 'b, b, 'c, c]),
1575   test1 () :=
1576     block ([x : 1, z : 3],
1577       [foo (),
1578        foo (x),
1579        foo (x, y, z),
1580        bar (x, y),
1581        bar (x, y, z),
1582        bar (x, y, z, 4, 5, 6)]),
1583   /* test2 cannot be translated due to the WNA error during macro
1584    * expansion, but we can call and test it in the interpreter
1585    */
1586   test2 () :=
1587     [errcatch (bar ()),
1588      errcatch (bar (1))],
1589
1590   /* l1: foo, bar and test1 are interpreted */
1591   l1 : test1 (),
1592
1593   /* l2: foo and bar are translated, and test1 is interpreted */
1594   translate_or_lose (foo, bar),
1595   l2 : test1 (),
1596
1597   /* l3: foo, bar and test1 are translated */
1598   translate_or_lose (test1),
1599   l3 : test1 (),
1600
1601   [test2 (),
1602    is (l1 = l2),
1603    is (l2 = l3),
1604    l1]);
1605 [[[], []],
1606  true,
1607  true,
1608  [[[], []],
1609   [['x], [1]],
1610   [['x, 'y, 'z], [1, 'y, 3]],
1611   ['x, 1, 'y, 'y, [], []],
1612   ['x, 1, 'y, 'y, ['z], [3]],
1613   ['x, 1, 'y, 'y, ['z, 4, 5, 6], [3, 4, 5, 6]]]];
1614
1615 (kill (foo, bar, test1, test2, l1, l2, l3), 0);
1616 0;
1617
1618 /* Some additional basic tests for conditionals.
1619  *
1620  * We test both elseif and else-if ("else if").
1621  */
1622
1623 block ([translate : false],
1624   mysignum1 (x) := if x > 0 then 1 elseif  x < 0 then -1 else 0,
1625   mysignum2 (x) := if x > 0 then 1 else if x < 0 then -1 else 0,
1626   foo () :=
1627     [if true then 1,
1628      if false then 1,
1629      if true then 1 else 2,
1630      if false then 1 else 2,
1631      if 1 < 2 then 'y,
1632      if 1 < 2 then 'y else 'n,
1633      if 1 > 2 then 'n,
1634      if 1 > 2 then 'n else 'y,
1635      if 1 > 2 then 'n elseif  1 = 2 then 'n else 'y,
1636      if 1 > 2 then 'n else if 1 = 2 then 'n else 'y,
1637      mysignum1 (-3),
1638      mysignum2 (-3),
1639      mysignum1 (0),
1640      mysignum2 (0),
1641      mysignum1 (2),
1642      mysignum2 (2)],
1643   l1 : foo (),
1644   translate_or_lose (mysignum1, mysignum2, foo),
1645   l2 : foo (),
1646   [is (l1 = l2),
1647    l2]);
1648 [true,
1649  [1, false, 1, 2, 'y, 'y, false, 'y, 'y, 'y, -1, -1, 0, 0, 1, 1]];
1650
1651 (kill (mysignum1, mysignum2, foo, l1, l2), 0);
1652 0;
1653
1654 /* Bogus translations of nested conditionals in elseif clauses
1655  *
1656  * The translation of a conditional with another conditional nested
1657  * directly under an elseif clause was totally wrong.  Using else-if
1658  * ("else if") instead of elseif would work fine.
1659  *
1660  *
1661  * We use the with_both_elseifs macro so we can test both elseif and
1662  * else-if without having to duplicate portions of the tests below.
1663  * Give this macro a conditional expression with elseifs and it will
1664  * expand into a list: the first element is the same expression given
1665  * to it (with elseifs), and the second element is that same expression
1666  * rewritten to use else-ifs instead of elseifs.
1667  */
1668
1669 (to_else_if (expr) :=
1670    if mapatom (expr) then
1671      expr
1672    else
1673      block ([op : op (expr), args : args (expr)],
1674        if op = "if" and length (args) > 4 then
1675          funmake (op, map ('to_else_if, append (firstn (args, 2), [true, funmake (op, rest (args, 2))])))
1676        else
1677          funmake (op, map ('to_else_if, args))),
1678  with_both_elseifs (expr) ::=
1679    buildq ([expr, texpr : to_else_if (expr)],
1680      [expr, texpr]),
1681   0);
1682 0;
1683
1684 block ([translate : false],
1685   foo () :=
1686     with_both_elseifs (
1687       if false then
1688         'lose1
1689       elseif false then
1690         'lose2
1691       elseif false then
1692         if true then
1693           'lose3
1694         else
1695           'lose4
1696       else
1697         'win),
1698
1699   /* l1: foo is interpreted */
1700   l1 : foo (),
1701
1702   translate_or_lose (foo),
1703
1704   /* l2: foo is translated
1705    *
1706    * foo used to give lose3 instead of win in the elseif case.
1707    */
1708   l2 : foo (),
1709
1710   [is (l1 = l2),
1711    l2]);
1712 [true,
1713  ['win, 'win]];
1714
1715 block ([translate : false],
1716   /* There is nothing special about bar here.  This is just some
1717    * function that has several branches with nested conditionals.
1718    */
1719   bar (x) :=
1720     with_both_elseifs (
1721       if x > 5 then
1722         if x > 7 then
1723           'more_than_seven
1724         elseif x > 6 then
1725           'seven
1726         else
1727           'six
1728       elseif x > 2 then
1729         if x > 4 then
1730           'five
1731         elseif x > 3 then
1732           'four
1733         else
1734           'three
1735       elseif x >= 0 then
1736         if x > 1 then
1737           'two
1738         elseif x > 0 then
1739           'one
1740         else
1741           'zero
1742       else
1743         'negative),
1744
1745   /* We test bar with the integers -2 to 9 */
1746   inputs : makelist (k, k, -2, 9),
1747
1748   /* l1: bar is interpreted */
1749   l1 : map (bar, inputs),
1750
1751   translate_or_lose (bar),
1752
1753   /* l2: bar is translated
1754    *
1755    * bar used to give incorrect results in the elseif case for every
1756    * number less than or equal to 2 (which means we got incorrect
1757    * results for the integers -2 to 2 in this test).
1758    */
1759   l2 : map (bar, inputs),
1760
1761   [is (l2 = l1),
1762    l2]);
1763 [true,
1764  [['negative, 'negative],
1765   ['negative, 'negative],
1766   ['zero, 'zero],
1767   ['one, 'one],
1768   ['two, 'two],
1769   ['three, 'three],
1770   ['four, 'four],
1771   ['five, 'five],
1772   ['six, 'six],
1773   ['seven, 'seven],
1774   ['more_than_seven, 'more_than_seven],
1775   ['more_than_seven, 'more_than_seven]]];
1776
1777 (kill (foo, bar, l1, l2, inputs, to_else_if, with_both_elseifs), 0);
1778 0;
1779
1780 /* Bogus translations of conditionals with tests that translated to T
1781  * and consequents that translated to NIL.
1782  */
1783
1784 block ([translate : false],
1785   foo () :=
1786     [if true then false else 1,
1787      if true then false elseif true then 1 else 2,
1788      if false then true elseif true then false else 1],
1789
1790   /* l1: foo is interpreted */
1791   l1 : foo (),
1792
1793   translate_or_lose (foo),
1794
1795   /* l2: foo is translated
1796    *
1797    * foo used to return [1, 1, 1]
1798    */
1799   l2 : foo (),
1800
1801   [is (l2 = l1),
1802    l2]);
1803 [true,
1804  [false, false, false]];
1805
1806 (kill (foo, l1, l2), 0);
1807 0;
1808
1809 /* Bug #3704: Translator gives internal error
1810  *
1811  * The hyper_to_summand function is from the bug report.
1812  */
1813
1814 (hyper_to_summand(e,k) := subst(hypergeometric = lambda([P,Q,x],
1815     P : xreduce("*", map(lambda([zz], pochhammer(zz,k)),P)),
1816     Q : xreduce("*", map(lambda([zz], pochhammer(zz,k)),Q)),
1817     P*x^k/(k! * Q)),e),
1818  l1 : hyper_to_summand (hypergeometric ([1/2], [2/5], x), 2),
1819  translate_or_lose (hyper_to_summand),
1820  l2 : hyper_to_summand (hypergeometric ([1/2], [2/5], x), 2),
1821  [is (l1 = l2), l2]);
1822 [true, 75 * x^2 / 112];
1823
1824 (foo () := lambda ([], x!),
1825  translate_or_lose (foo),
1826  block ([x : 5], foo () ()));
1827 120;
1828
1829 (kill (hyper_to_summand, foo, l1, l2), 0);
1830 0;
1831
1832 /* go tags can be integers
1833  *
1834  * This has been allowed, but it used to give a warning and an extra
1835  * trivial run through the translator to translate the integer go tags.
1836  * Now we allow integers directly without giving a warning.
1837  *
1838  * We don't actually bother to check for warnings in the test below.
1839  * We're really just verifying that using an integer go tag works.
1840  */
1841
1842 block ([translate : false],
1843   foo () := block ([i : 0], tag, i : i + 1, if i < 5 then go (tag), i),
1844   bar () := block ([i : 0], 123, i : i + 1, if i < 5 then go (123), i),
1845   l1 : [foo (), bar ()],
1846   translate_or_lose (foo, bar),
1847   l2 : [foo (), bar ()],
1848   [is (l1 = l2), l2]);
1849 [true, [5, 5]];
1850
1851 (kill (foo, bar, l1, l2), 0);
1852 0;
1853
1854 /* A bug in MARRAYREF caused things like translated array references
1855  * to yield MQAPPLY expressions with an incorrect header.
1856  */
1857
1858 block ([translate : false],
1859   foo () := 'baz () [1],
1860   bar () := 'baz () [1, 2, 3],
1861   l1 : [foo (), bar ()],
1862   translate_or_lose (foo, bar),
1863   l2 : [foo (), bar ()],
1864   [is (l1 = l2), l2]);
1865 [true, ['baz () [1], 'baz () [1, 2, 3]]];
1866
1867 (kill (foo, bar, l1, l2), 0);
1868 0;
1869
1870 /* A bug in MARRAYREF caused bogus indexing into hash tables and fast
1871  * arrays.  This affected things like translated array references.
1872  */
1873
1874 block ([translate : false,
1875         use_fast_arrays : true],
1876
1877   foo () := block ([a],
1878               a[false] : 'wtf,
1879               a[1] : 2,
1880               a[1]),
1881
1882   /* This would correctly yield 2 */
1883   l1 : foo (),
1884
1885   translate_or_lose (foo),
1886
1887   /* This used to incorrectly yield wtf */
1888   l2 : foo (),
1889
1890   [is (l1 = l2), l2]);
1891 [true, 2];
1892
1893 (kill (foo, l1, l2), 0);
1894 0;
1895
1896 /* A bug in MARRAYREF caused things like translated array references
1897  * to yield expressions with an incorrect header.
1898  */
1899
1900 block ([translate : false],
1901   foo () := block ([a],
1902               local (a),
1903               array (a, complete, 5),
1904               a[3]),
1905
1906   /* This would correctly yield a[3] */
1907   l1 : foo(),
1908
1909   translate_or_lose (foo),
1910
1911   /* This would incorrectly yield a(3) */
1912   l2 : foo(),
1913
1914   [is (l1 = l2), l2]);
1915 [true, 'a[3]];
1916
1917 (kill (foo, l1, l2), 0);
1918 0;
1919
1920 /* When translate_fast_arrays:true, a lisp error would occur at runtime
1921  * during an attempted MQAPPLY array assignment
1922  */
1923
1924 block ([translate : false],
1925   foo () := block ([a],
1926               local (a, b),
1927               a : make_array ('fixnum, 5),
1928               b () := a,
1929               b () [3] : 17,
1930               b () [3]),
1931
1932   /* This would correctly yield 17 */
1933   l1 : foo(),
1934
1935   block ([translate_fast_arrays : false],
1936     translate_or_lose (foo)),
1937
1938   /* This would correctly yield 17 */
1939   l2 : foo(),
1940
1941   block ([translate_fast_arrays : true],
1942     translate_or_lose (foo)),
1943
1944   /* This would cause a lisp error */
1945   l3 : foo(),
1946
1947   [is (l1 = l2), is (l2 = l3), l3]);
1948 [true, true, 17];
1949
1950 (kill (foo, l1, l2, l3), 0);
1951 0;
1952
1953 /* The string "**" no longer translates to the string "^".
1954  * This test compares the interpreted and translated results.
1955  */
1956
1957 block ([translate : false],
1958   foo () := ["^", "^" (2, 3), apply ("^", [2, 3]),
1959              "**", "**" (2, 3), apply ("**", [2, 3])],
1960   l1 : foo (),
1961   translate_or_lose (foo),
1962   l2 : foo (),
1963   [l2, is (l1 = l2)]);
1964 [["^", 8, 8, "**", 8, 8], true];
1965
1966 (kill (foo, l1, l2), 0);
1967 0;
1968
1969 /* Attempting to translate some atoms like lisp arrays would
1970  * cause lisp errors during translation.
1971  */
1972
1973 (a : make_array (fixnum, 1),
1974  a[0] : 13,
1975  define (foo (), a),
1976  translate_or_lose (foo),
1977  listarray (foo ()));
1978 [13];
1979
1980 (kill (foo, a), 0);
1981 0;
1982
1983 /* Simple tests for catch and throw */
1984
1985 block ([translate : false, l1, l2],
1986   local (foo, bar, baz),
1987
1988   foo (p) := if p then throw (13) else 2,
1989   bar () := catch (1, foo (false), 3),
1990   baz () := catch (1, foo (true), 3),
1991
1992   l1 : [bar (), baz ()],
1993
1994   translate_or_lose (foo, bar, baz),
1995
1996   l2 : [bar (), baz ()],
1997
1998   [l2, is (l1 = l2)]);
1999 [[3, 13], true];
2000
2001 /* Translating a define_variable form with translate (but not
2002  * translate_file or compfile) used to invoke undefined behavior.
2003  * This would cause a lisp error during translation under some
2004  * (but not all) lisp implementations.
2005  */
2006
2007 block ([translate : false],
2008   local (foo),
2009   foo () := (define_variable (x, 1, fixnum), x),
2010   translate_or_lose (foo),
2011   foo ());
2012 1;
2013
2014 (kill (foo, x), 0);
2015 0;
2016
2017 /* If local was used on a matchdeclared pattern variable, and this
2018  * was all translated with something besides translate_file (e.g.,
2019  * translate, compfile, etc.), then the MATCHDECLARE property would
2020  * not be on the pattern variable.
2021  */
2022
2023 block ([translate : false, l1, l2],
2024   local (foo),
2025
2026   foo () := (local (x), matchdeclare (x, true), let (a * x, x), letsimp (a * q)),
2027
2028   /* This would yield q */
2029   l1 : foo (),
2030
2031   translate_or_lose (foo),
2032
2033   /* This used to yield a*q */
2034   l2 : foo (),
2035
2036   [l2, is (l1 = l2)]);
2037 [q, true];
2038
2039 (kill (foo), 0);
2040 0;
2041
2042 /* Rest args are now allowed in lambda expressions in MQAPPLY
2043  * lambda forms
2044  */
2045
2046 block ([translate : false, l1, l2],
2047   local (foo, bar, baz),
2048
2049   /* foo used to fail to translate due to the rest arg */
2050   foo () :=
2051     block ([x : 1, z : 3],
2052       lambda ([[x]], x) (x, x + 1, z)),
2053   bar () :=
2054     block ([x : 2, z : 4],
2055       apply (lambda ([[x]], x), [x, x + 1, z])),
2056   baz () :=
2057     block ([x : 3, z : 5],
2058       block ([f : lambda ([[x]], x)],
2059         f (x, x + 1, z))),
2060
2061   l1 : [foo (), bar (), baz ()],
2062
2063   translate_or_lose (foo, bar, baz),
2064
2065   l2 : [foo (), bar (), baz ()],
2066
2067   [l1, is (l1 = l2)]);
2068 [[[1, 2, 3],[2, 3, 4],[3, 4, 5]], true];
2069
2070 /* Validation has been improved for lambda expressions in MQAPPLY
2071  * lambda forms
2072  */
2073
2074 block ([translate : false],
2075   local (foo, bar),
2076
2077   /* These should both fail to translate */
2078   foo () := lambda ([]) (),
2079   bar () := lambda ([x, x], x) (1, 2),
2080
2081   translate (foo, bar));
2082 [];
2083
2084 /* The translation of array functions was broken for decades */
2085
2086 block ([translate : false, l1, l2],
2087   local (foo, bar),
2088
2089   foo[x] := x,
2090   bar[n] := if n = 1 then 1 else n * bar[n - 1],
2091
2092   l1 : [foo[0], foo[5], bar[5], bar[10]],
2093
2094   translate_or_lose (foo, bar),
2095
2096   l2 : [foo[0], foo[5], bar[5], bar[10]],
2097
2098   [l1, is (l1 = l2)]);
2099 [[0, 5, 120, 3628800], true];
2100
2101 (kill (foo, bar), 0);
2102 0;
2103
2104 /* The translation of upward funargs (including those created by
2105  * subscripted functions) easily lead to lisp errors.
2106  */
2107
2108 /* Tests involving returned lambdas without free vars that were
2109  * bound during definition
2110  */
2111 block ([l1, l2,
2112         translate : false,
2113         listarith : true],
2114   local (foo, bar, test),
2115
2116   foo () := lambda ([x], 2 * x + q),
2117   bar () := lambda ([x, [y]], x * y + q),
2118
2119   test () :=
2120     block ([f : foo (),
2121             b : bar ()],
2122       [f (3), f (5), b (2, 3, 4), b (5, 6, 7)]),
2123
2124   l1 : test (),
2125
2126   translate_or_lose (foo, bar),
2127
2128   l2 : test (),
2129
2130   [l2, is (l1 = l2)]);
2131 [['q + 6, 'q + 10, ['q + 6, 'q + 8], ['q + 30, 'q + 35]],
2132  true];
2133
2134 (kill (foo, bar), 0);
2135 0;
2136
2137 /* Tests involving returned lambdas with free vars that were
2138  * bound during definition.  These do not cause the capture of
2139  * values.
2140  */
2141 block ([l1, l2,
2142         x : 'ux,
2143         translate : false,
2144         listarith : true],
2145   local (foo, bar, baz, test),
2146
2147   foo (x) := lambda ([y], x + y + q),
2148   bar (x) := lambda ([y, [z]], q + x + y * z),
2149   baz (v) := lambda ([], v),
2150
2151   test () :=
2152     block ([f : foo (3),
2153             b : bar (4),
2154             c : baz (5)],
2155       [f (5), b (2, 3, 4), c ()]),
2156
2157   l1 : test (),
2158
2159   translate_or_lose (foo, bar, baz),
2160
2161   l2 : test (),
2162
2163   [l2, is (l1 = l2)]);
2164 [['q + 'ux + 5,
2165   ['q + 'ux + 6, 'q + 'ux + 8],
2166   'v],
2167  true];
2168
2169 (kill (foo, bar, baz), 0);
2170 0;
2171
2172 /* Tests involving subscripted functions.  These do cause the capture
2173  * of values.
2174  */
2175 block ([l1, l2,
2176         x : 'ux, y : 'uy,
2177         translate : false],
2178   local (foo, bar, baz, def, test),
2179
2180   def () := (
2181     foo[x, y](a, b) := [x, y, a, b, q],
2182     bar[x, y](a, [b]) := [x, y, a, b, q],
2183     baz[v]() := v),
2184
2185   test () :=
2186     block ([f : foo[1, 2],
2187             b : bar[3, 4],
2188             c : baz[5]],
2189       [f (6, 7), b (8, 9, 10), c ()]),
2190
2191   def (),
2192
2193   l1 : test (),
2194
2195   /* just kill and redefine */
2196
2197   kill (foo, bar, baz),
2198
2199   def (),
2200
2201   translate_or_lose (foo, bar, baz),
2202
2203   l2 : test (),
2204
2205   [l2, is (l1 = l2)]);
2206 [[[1, 2, 6, 7, 'q],
2207   [3, 4, 8, [9, 10], 'q],
2208   5],
2209  true];
2210
2211 (kill (foo, bar, baz), 0);
2212 0;
2213
2214 /* More tests involving multiple nested lambdas */
2215 block ([l1, l2,
2216         x : 'ux, y : 'uy, z : 'uz,
2217         translate : false],
2218   local (foo, bar, baz, quux, def, test),
2219
2220   def () := (
2221     /* nothing should be captured */
2222     foo (x) := lambda ([y], lambda ([z], [x, y, z])),
2223     /* x should be captured and used */
2224     bar[x](y) := lambda ([z], [x, y, z]),
2225     /* x should be captured and used */
2226     baz[x](y) := lambda ([z], lambda ([], [x, y, z])),
2227     /* nothing should be captured since x is bound by the inner lambda */
2228     quux[x](y) := lambda ([x], [x, y])),
2229
2230   test () :=
2231     block ([a : foo (1),
2232             b : bar[2],
2233             c : baz[3],
2234             d : quux[4]],
2235       [a (10) (11), b (12) (13), c (14) (15) (), d (16) (17)]),
2236
2237   def (),
2238
2239   l1 : test (),
2240
2241   /* just kill and redefine */
2242
2243   kill (foo, bar, baz, quux),
2244
2245   def (),
2246
2247   translate_or_lose (foo, bar, baz, quux),
2248
2249   l2 : test (),
2250
2251   [l2, is (l1 = l2)]);
2252 [[['ux, 'uy, 11],
2253   [2, 'uy, 13],
2254   [3, 'uy, 'uz],
2255   [17, 'uy]],
2256  true];
2257
2258 (kill (foo, bar, baz, quux), 0);
2259 0;
2260
2261 /* The translator was not correctly determining the mode of expressions
2262  * when a boolean mode was involved.
2263  *
2264  * It was easy to get lisp errors.
2265  */
2266 block ([translate : false, l1, l2],
2267   local (test),
2268
2269   foo () :=
2270     [  1 + if true then 0,
2271        1 + if true then 0.0,
2272      1.0 + if true then 0,
2273      1.0 + if true then 0.0,
2274
2275        1 + if false then 0,
2276        1 + if false then 0.0,
2277      1.0 + if false then 0,
2278      1.0 + if false then 0.0],
2279
2280   bar (x) :=
2281     [  1 + if x then 0,
2282        1 + if x then 0.0,
2283      1.0 + if x then 0,
2284      1.0 + if x then 0.0],
2285
2286   test () :=
2287     block ([res : []],
2288       for prederror in [true, false] do
2289         push (foo (), res),
2290         for x in [true, false] do
2291           push (bar (x), res),
2292       res),
2293
2294   l1 : test (),
2295
2296   translate_or_lose (foo, bar),
2297
2298   l2 : test (),
2299
2300   is (l1 = l2));
2301 true;
2302
2303 (kill (foo, bar), 0);
2304 0;
2305
2306 /*
2307  * Bug #4008: translator and prederror
2308  */
2309
2310 (kill (pred, foo, bar, x, r), 0);
2311 0;
2312
2313 block ([translate : false, l1, l2],
2314   local (test),
2315
2316   foo (n, q, x) :=
2317     [if true then q + r,
2318      if false then q + r,
2319
2320      if x then q,
2321      if not x then q,
2322      if not not x then q,
2323      if not not not x then q,
2324
2325      n + if x then q + r,
2326      n + if not x then q + r,
2327      n + if not not x then q + r,
2328      n + if not not not x then q + r],
2329
2330   test () :=
2331     block ([res : []],
2332       for prederror in [true, false] do
2333         for n in [1, 1.0, %i, 1.0 * %i] do
2334           for q in [1, 1.0, %i, 1.0 * %i, 'z] do
2335             for x in [true, false] do
2336               push (foo (n, q, x), res),
2337       res),
2338
2339   l1 : test (),
2340
2341   translate_or_lose (foo),
2342
2343   l2 : test (),
2344
2345   is (l1 = l2));
2346 true;
2347
2348 (kill (foo), 0);
2349 0;
2350
2351 block ([translate : false, l1, l2],
2352   local (test),
2353
2354   foo (x, y) :=
2355     block ([q : 'z],
2356       [if "and" () then q else r,
2357        if "and" (x) then q else r,
2358        if "and" (y) then q else r,
2359        if x and y then q else r,
2360        if not x and y then q else r,
2361        if x and not y then q else r,
2362        if not x and not y then q else r,
2363        if not (x and y) then q else r,
2364        if not (not x and y) then q else r,
2365        if not (x and not y) then q else r,
2366        if not (not x and not y) then q else r,
2367
2368        if "or" () then q else r,
2369        if "or" (x) then q else r,
2370        if "or" (y) then q else r,
2371        if x or y then q else r,
2372        if not x or y then q else r,
2373        if x or not y then q else r,
2374        if not x or not y then q else r,
2375        if not (x or y) then q else r,
2376        if not (not x or y) then q else r,
2377        if not (x or not y) then q else r,
2378        if not (not x or not y) then q else r]),
2379
2380   test () :=
2381     block ([res : []],
2382       for prederror in [true, false] do
2383         for x in [true, false] do
2384           for y in [true, false] do
2385             push (foo (x, y), res),
2386       res),
2387
2388   l1 : test (),
2389
2390   translate_or_lose (foo),
2391
2392   l2 : test (),
2393
2394   is (l1 = l2));
2395 true;
2396
2397 (kill (foo), 0);
2398 0;
2399
2400 block ([translate : false, l1, l2],
2401   local (test, make_fun),
2402
2403   make_fun (name, pr) ::=
2404     buildq ([name, pr],
2405       name (x, y) :=
2406         block ([q : 'z],
2407           [pr ("and" ()),
2408            pr ("and" (x)),
2409            pr ("and" (y)),
2410            pr (x and y),
2411            pr (not x and y),
2412            pr (x and not y),
2413            pr (not x and not y),
2414            pr (not (x and y)),
2415            pr (not (not x and y)),
2416            pr (not (x and not y)),
2417            pr (not (not x and not y)),
2418
2419            pr ("or" ()),
2420            pr ("or" (x)),
2421            pr ("or" (y)),
2422            pr (x or y),
2423            pr (not x or y),
2424            pr (x or not y),
2425            pr (not x or not y),
2426            pr (not (x or y)),
2427            pr (not (not x or y)),
2428            pr (not (x or not y)),
2429            pr (not (not x or not y))])),
2430
2431   make_fun (foo, is),
2432   make_fun (bar, maybe),
2433
2434   test () :=
2435     block ([res : []],
2436       for prederror in [true, false] do
2437         for x in [true, false] do
2438           for y in [true, false] do (
2439             push (foo (x, y), res),
2440             push (bar (x, y), res)),
2441       res),
2442
2443   l1 : test (),
2444
2445   translate_or_lose (foo, bar),
2446
2447   l2 : test (),
2448
2449   is (l1 = l2));
2450 true;
2451
2452 (kill (foo, bar), 0);
2453 0;
2454
2455 block ([translate : false, l1, l2],
2456   local (test),
2457
2458   pred (a, b) := equal (a, b),
2459
2460   foo (x, y) :=
2461     block ([q : 'z],
2462       [if x < y then q else r,
2463        if not (x < y) then q else r,
2464        if x <= y then q else r,
2465        if not (x <= y) then q else r,
2466        if x > y then q else r,
2467        if not (x > y) then q else r,
2468        if x >= y then q else r,
2469        if not (x >= y) then q else r,
2470
2471        if x = y then q else r,
2472        if x # y then q else r,
2473        if not (x = y) then q else r,
2474        if not (x # y) then q else r,
2475        if not not (x = y) then q else r,
2476        if not not (x # y) then q else r,
2477        if not not not (x = y) then q else r,
2478        if not not not (x # y) then q else r,
2479
2480        if equal (x, y) then q else r,
2481        if notequal (x, y) then q else r,
2482        if not equal (x, y) then q else r,
2483        if not not equal (x, y) then q else r,
2484        if not notequal (x, y) then q else r,
2485        if not not not equal (x, y) then q else r,
2486        if not not notequal (x, y) then q else r,
2487
2488        if pred (x, y) then q else r,
2489        if not pred (x, y) then q else r,
2490        if not not pred (x, y) then q else r,
2491        if not not not pred (x, y) then q else r]),
2492
2493   test () :=
2494     block ([res : []],
2495       for prederror in [true, false] do
2496         for x in [1, 2] do
2497           for y in [1, 2] do
2498             push (foo (x, y), res),
2499       res),
2500
2501   l1 : test (),
2502
2503   translate_or_lose (pred, foo),
2504
2505   l2 : test (),
2506
2507   is (l1 = l2));
2508 true;
2509
2510 (kill (pred, foo), 0);
2511 0;
2512
2513 block ([translate : false, l1, l2],
2514   local (test, make_fun),
2515
2516   pred (a, b) := equal (a, b),
2517
2518   make_fun (name, pr) ::=
2519     buildq ([name, pr],
2520       name (x, y) :=
2521         block ([q : 'z],
2522           [pr (x = y),
2523            pr (x # y),
2524            pr (not (x = y)),
2525            pr (not (x # y)),
2526            pr (not not (x = y)),
2527            pr (not not (x # y)),
2528            pr (not not not (x = y)),
2529            pr (not not not (x # y)),
2530
2531            pr (equal (x, y)),
2532            pr (not equal (x, y)),
2533            pr (notequal (x, y)),
2534            pr (not not equal (x, y)),
2535            pr (not notequal (x, y)),
2536            pr (not not not equal (x, y)),
2537            pr (not not notequal (x, y)),
2538
2539            pr (pred (x, y)),
2540            pr (not pred (x, y)),
2541            pr (not not pred (x, y)),
2542            pr (not not not pred (x, y))])),
2543
2544   make_fun (foo, is),
2545   make_fun (bar, maybe),
2546
2547   test () :=
2548     block ([res : []],
2549       for prederror in [true, false] do
2550         for x in [1, 2] do
2551           for y in [1, 2] do (
2552             push (foo (x, y), res),
2553             push (bar (x, y), res)),
2554       res),
2555
2556   l1 : test (),
2557
2558   translate_or_lose (pred, foo, bar),
2559
2560   l2 : test (),
2561
2562   is (l1 = l2));
2563 true;
2564
2565 (kill (pred, foo, bar), 0);
2566 0;
2567
2568 block ([translate : false, l1, l2],
2569   local (test),
2570
2571   foo (x, q) :=
2572     [if (1, 2, q, x) then q else r,
2573      if not (1, 2, q, x) then q else r,
2574      if (1, 2, q, not x) then q else r],
2575
2576   test () :=
2577     block ([res : []],
2578       for prederror in [true, false] do
2579         for x in [true, false] do
2580           push (foo (x, 17), res),
2581       res),
2582
2583   l1 : test (),
2584
2585   translate_or_lose (foo),
2586
2587   l2 : test (),
2588
2589   is (l1 = l2));
2590 true;
2591
2592 (kill (foo), 0);
2593 0;
2594
2595 block ([translate : false, l1, l2],
2596   local (test, make_fun),
2597
2598   make_fun (name, pr) ::=
2599     buildq ([name, pr],
2600       name (x, y) :=
2601         [pr (x),
2602          pr (not x),
2603          pr (not not x),
2604          pr (not not not x),
2605
2606          pr (y),
2607          pr (not y),
2608          pr (not not y),
2609          pr (not not not y),
2610
2611          pr (x and y),
2612          pr (x or y),
2613          pr (not (x and y)),
2614          pr (not (x or y)),
2615          pr (not not (x and y)),
2616          pr (not not (x or y)),
2617          pr (not not not (x and y)),
2618          pr (not not not (x or y)),
2619
2620          pr (x and not y),
2621          pr (x or not y),
2622          pr (x and not not y),
2623          pr (x or not not y),
2624          pr (not (x and not y)),
2625          pr (not (x or not y)),
2626          pr (not (x and not not y)),
2627          pr (not (x or not not y)),
2628
2629          pr (not x and y),
2630          pr (not x or y),
2631          pr (not not x and y),
2632          pr (not not x or y),
2633          pr (not (not x and y)),
2634          pr (not (not x or y)),
2635          pr (not (not not x and y)),
2636          pr (not (not not x or y)),
2637
2638          pr (not x and not y),
2639          pr (not x or not y),
2640          pr (not (not x and not y)),
2641          pr (not (not x or not y)),
2642
2643          pr (x > 1),
2644          pr (not x > 1),
2645          pr (x > 1 and y),
2646          pr (x > 1 or y),
2647          pr (x > 1 and not y),
2648          pr (x > 1 or not y),
2649          pr (not x > 1 and y),
2650          pr (not x > 1 or y),
2651          pr (not x > 1 and not y),
2652          pr (not x > 1 or not y),
2653
2654          pr (y <= 1),
2655          pr (not y <= 1),
2656          pr (x and y <= 1),
2657          pr (x or y <= 1),
2658          pr (x and not y <= 1),
2659          pr (x or not y <= 1),
2660          pr (not x and y <= 1),
2661          pr (not x or y <= 1),
2662          pr (not x and not y <= 1),
2663          pr (not x or not y <= 1)]),
2664
2665   make_fun (foo, is),
2666   make_fun (bar, maybe),
2667
2668   test () :=
2669     block ([prederror : false,
2670             l : [true, false, 1, 2.0, 'q, 'q ()],
2671             res : []],
2672       for x in l do
2673         for y in l do (
2674           push (foo (x, y), res),
2675           push (bar (x, y), res)),
2676       res),
2677
2678   l1 : test (),
2679
2680   translate_or_lose (foo, bar),
2681
2682   l2 : test (),
2683
2684   is (l1 = l2));
2685 true;
2686
2687 (kill (foo, bar), 0);
2688 0;
2689
2690 block ([translate : false, l1, l2],
2691   local (test, make_fun),
2692
2693   make_fun (name, pr) ::=
2694     buildq ([name, pr],
2695       name (x) :=
2696         [pr (x <  1),
2697          pr (x <= 1),
2698          pr (x >  1),
2699          pr (x >= 1),
2700
2701          pr (not (x <  1)),
2702          pr (not (x <= 1)),
2703          pr (not (x >  1)),
2704          pr (not (x >= 1)),
2705
2706          pr (not not (x <  1)),
2707          pr (not not (x <= 1)),
2708          pr (not not (x >  1)),
2709          pr (not not (x >= 1)),
2710
2711          pr (x = 1),
2712          pr (x # 1),
2713          pr (not (x = 1)),
2714          pr (not (x # 1)),
2715          pr (not not (x = 1)),
2716          pr (not not (x # 1)),
2717
2718          pr (equal (x, 1)),
2719          pr (notequal (x, 1)),
2720          pr (not equal (x, 1)),
2721          pr (not notequal (x, 1)),
2722          pr (not not equal (x, 1)),
2723          pr (not not notequal (x, 1))]),
2724
2725   make_fun (foo, is),
2726   make_fun (bar, maybe),
2727
2728   test () :=
2729     block ([res : []],
2730       block ([prederror : true],
2731         push (errcatch (foo ('z)), res)),
2732       block ([prederror : false,
2733               l : [0, 0.0, 0.0b0,
2734                    1, 1.0, 1.0b0,
2735                    2, 2.0, 2.0b0,
2736                    %i, 1.0 * %i, 1.0b0 * %i,
2737                    2 * %i, 2.0 * %i, 2.0b0 * %i,
2738                    true, false,
2739                    'z, 'z ()]],
2740         for x in l do (
2741           push (foo (x), res),
2742           push (bar (x), res))),
2743       res),
2744
2745   l1 : test (),
2746
2747   translate_or_lose (foo, bar),
2748
2749   l2 : test (),
2750
2751   is (l1 = l2));
2752 true;
2753
2754 (kill (foo, bar), 0);
2755 0;
2756
2757 block ([translate : false, l1, l2],
2758   local (test),
2759
2760   foo (x, q, prederror) :=
2761     block ([r],
2762       [if x then 0,
2763        if not x then 0,
2764        if not not x then 0,
2765        if not not not x then 0,
2766        if x then q + r,
2767        if not x then q + r,
2768        if not not x then q + r,
2769        if not not not x then q + r,
2770        if x then 1 else 2,
2771        if not x then 1 else 2,
2772        if not not x then 1 else 2,
2773        if not not not x then 1 else 2,
2774        if x then x else q + r,
2775        if not x then x else q + r,
2776        if not not x then x else q + r,
2777        if not not not x then x else q + r,
2778        if x = 1 then x else q + r,
2779        if x # 1 then x else q + r,
2780        if not x = 1 then x else q + r,
2781        if not x # 1 then x else q + r,
2782        if not not x = 1 then x else q + r,
2783        if not not x # 1 then x else q + r,
2784        if not not not x = 1 then x else q + r,
2785        if not not not x # 1 then x else q + r]),
2786
2787   test () :=
2788     block ([l : [true, false, 1, 2.0, 3.0b0, 'z, 'z ()],
2789             res : []],
2790       push (errcatch (foo (1, 2, true)), res),
2791       for x in l do
2792         for q in l do
2793           push (foo (x, q, false), res),
2794       res),
2795
2796   l1 : test (),
2797
2798   translate_or_lose (foo),
2799
2800   l2 : test (),
2801
2802   is (l1 = l2));
2803 true;
2804
2805 (kill (foo), 0);
2806 0;
2807
2808 block ([translate : false, l1, l2],
2809   local (rewritehack, eqhack, test),
2810
2811   /* Take a relational expr and potentially rewrite it in some
2812    * equivalent way, e.g.  x<1  =>  1-x>0
2813    */
2814   rewritehack (r) :=
2815     eval_string_lisp ("(apply #'mevalp2 $r (mop $r) (margs $r))")[1],
2816
2817   /* Translated code can produce relational exprs that are in a
2818    * different, but equivalent, form compared to the exprs produce
2819    * by interpreted code.
2820    *
2821    * Compare two conditionals by requiring that everything matches
2822    * exactly, except possibly the first (only) test.  The tests
2823    * should match exactly after applying rewritehack to them.
2824    */
2825   eqhack (interp, transl) :=
2826     if atom (interp) or atom (transl) or op (interp) # "if" or op (transl) # "if" then
2827       is (interp = transl)
2828     else
2829       is (rest (interp) = rest (transl)
2830           and
2831           rewritehack (first (interp)) = rewritehack (first (transl))),
2832
2833   foo (x) :=
2834     block ([r],
2835       [if x <  1 then x else r,
2836        if x <= 1 then x else r,
2837        if x >  1 then x else r,
2838        if x >= 1 then x else r,
2839
2840        if not (x <  1) then x else r,
2841        if not (x <= 1) then x else r,
2842        if not (x >  1) then x else r,
2843        if not (x >= 1) then x else r,
2844
2845        if not not (x <  1) then x else r,
2846        if not not (x <= 1) then x else r,
2847        if not not (x >  1) then x else r,
2848        if not not (x >= 1) then x else r,
2849
2850        if x = 1 then x else r,
2851        if x # 1 then x else r,
2852        if not (x = 1) then x else r,
2853        if not (x # 1) then x else r,
2854        if not not (x = 1) then x else r,
2855        if not not (x # 1) then x else r,
2856
2857        if equal (x, 1) then x else r,
2858        if notequal (x, 1) then x else r,
2859        if not equal (x, 1) then x else r,
2860        if not notequal (x, 1) then x else r,
2861        if not not equal (x, 1) then x else r,
2862        if not not notequal (x, 1) then x else r]),
2863
2864   test () :=
2865     block ([res : []],
2866       block ([prederror : true],
2867         push (errcatch (foo ('z)), res)),
2868       block ([prederror : false,
2869               l : [0, 0.0, 0.0b0,
2870                    1, 1.0, 1.0b0,
2871                    2, 2.0, 2.0b0,
2872                        %i, 1.0 * %i, 1.0b0 * %i,
2873                    2 * %i, 2.0 * %i, 2.0b0 * %i,
2874                    true, false,
2875                    'z, 'z ()]],
2876         for x in l do
2877           res : append (foo (x), res)),
2878       res),
2879
2880   l1 : test (),
2881
2882   translate_or_lose (foo),
2883
2884   l2 : test (),
2885
2886   every (eqhack, l1, l2));
2887 true;
2888
2889 (kill (foo), 0);
2890 0;
2891
2892 block ([translate : false, l1, l2],
2893   local (test),
2894
2895   foo (x, y, z) :=
2896     block ([r],
2897       [if x >  0 and y >  0 and z >  0 then x + y = z else r,
2898        if x >  0 or  y >  0 or  z >  0 then x + y = z else r,
2899        if x >= 1 and y >= 1 and z >= 1 then x + y = z else r,
2900        if x >= 1 or  y >= 1 or  z >= 1 then x + y = z else r,
2901        if x <= 2 and y <= 2 and z <= 2 then x + y = z else r,
2902        if x <= 2 or  y <= 2 or  z <= 2 then x + y = z else r,
2903        if x <  3 and y <  3 and z <  3 then x + y = z else r,
2904        if x <  3 or  y <  3 or  z <  3 then x + y = z else r]),
2905
2906   test () :=
2907     block ([l : [1, 2.0, 3.0b0, %i],
2908             res : []],
2909       for x in l do
2910         for y in l do
2911           for z in l do
2912             push (foo (x, y, z), res),
2913       res),
2914
2915   l1 : test (),
2916
2917   translate_or_lose (foo),
2918
2919   l2 : test (),
2920
2921   is (l1 = l2));
2922 true;
2923
2924 (kill (foo), 0);
2925 0;
2926
2927 block ([translate : false, l1, l2],
2928   local (test),
2929
2930   foo (p, x, y, z) :=
2931     (modedeclare (p, boolean, x, fixnum, y, flonum, z, number),
2932       block ([r],
2933         [if p and x >  0 and y >  0 and z >  0 then x + y - z else r,
2934          if p or  x >  0 or  y >  0 or  z >  0 then x + y - z else r,
2935          if p and x >= 1 and y >= 1 and z >= 1 then x + y - z else r,
2936          if p or  x >= 1 or  y >= 1 or  z >= 1 then x + y - z else r,
2937          if p and x <= 2 and y <= 2 and z <= 2 then x + y - z else r,
2938          if p or  x <= 2 or  y <= 2 or  z <= 2 then x + y - z else r,
2939          if p and x <  3 and y <  3 and z <  3 then x + y - z else r,
2940          if p or  x <  3 or  y <  3 or  z <  3 then x + y - z else r,
2941
2942          if p and x >  y and y >  z and z >  3 then x + y + z else r,
2943          if p or  x >  y or  y >  z or  z >  3 then x + y + z else r,
2944          if p and x >= y and y >= z and z >= 2 then x + y + z else r,
2945          if p or  x >= y or  y >= z or  z >= 2 then x + y + z else r,
2946          if p and x <= y and y <= z and z <= 1 then x + y + z else r,
2947          if p or  x <= y or  y <= z or  z <= 1 then x + y + z else r,
2948          if p and x <  y and y <  z and z <  0 then x + y + z else r,
2949          if p or  x <  y or  y <  z or  z <  0 then x + y + z else r])),
2950
2951   test () :=
2952     block ([bool : [true, false],
2953             fixl : [0, 1, 2, 3, 4],
2954             flol : [0.0, 1.0, 2.0, 3.0, 4.0],
2955             numl : [0, 1.0, 2, 3.0, 4],
2956             res : []],
2957       for p in bool do
2958         for x in fixl do
2959           for y in flol do
2960             for z in numl do
2961               push (foo (p, x, y, z), res),
2962       res),
2963
2964   l1 : test (),
2965
2966   translate_or_lose (foo),
2967
2968   l2 : test (),
2969
2970   is (l1 = l2));
2971 true;
2972
2973 (kill (foo, p, x, y, z), 0);
2974 0;
2975
2976 block ([translate : false, l1, l2],
2977   local (test),
2978
2979   foo (p, x, y, z) :=
2980     block ([r],
2981       [if p and x and y and z then x + y = z else r,
2982        if p or  x or  y or  z then x + y = z else r,
2983
2984        if p and equal (x, 1) and equal (y, 1) and equal (z, 1) then x + y = z else r,
2985        if p or  equal (x, 1) or  equal (y, 1) or  equal (z, 1) then x + y = z else r,
2986
2987        if not p and not equal (x, 1) and not equal (y, 1) and not equal (z, 1) then x + y = z else r,
2988        if not p or  not equal (x, 1) or  not equal (y, 1) or  not equal (z, 1) then x + y = z else r,
2989
2990        if p and notequal (x, 1) and notequal (y, 1) and notequal (z, 1) then x + y = z else r,
2991        if p or  notequal (x, 1) or  notequal (y, 1) or  notequal (z, 1) then x + y = z else r,
2992
2993        if not p and not notequal (x, 1) and not notequal (y, 1) and not notequal (z, 1) then x + y = z else r,
2994        if not p or  not notequal (x, 1) or  not notequal (y, 1) or  not notequal (z, 1) then x + y = z else r]),
2995
2996   test () :=
2997     block ([prederror : false,
2998             l : [true, false, 1, 2.0, 3.0b0, %i, 'z, 'z ()],
2999             res : []],
3000       for p in [true, false] do
3001         for x in l do
3002           for y in l do
3003             for z in l do
3004               push (foo (p, x, y, z), res),
3005       res),
3006
3007   l1 : test (),
3008
3009   translate_or_lose (foo),
3010
3011   l2 : test (),
3012
3013   is (l1 = l2));
3014 true;
3015
3016 (kill (foo), 0);
3017 0;
3018
3019 block ([translate : false, l1, l2],
3020   local (test),
3021
3022   pred (a, b) := equal (a, b),
3023
3024   foo (x, q) :=
3025     block ([r, var1, var2, v1 : 'var1, v2 : 'var2],
3026       [if pred (x, 1) then x,
3027        if not pred (x, 1) then x,
3028        if pred (x, 1) or pred (x, 2) then x,
3029        if pred (x, 1) then x else q + r,
3030        if not pred (x, 1) then x else q + r,
3031        if pred (x, 1) or pred (x, 2) then x else q + r,
3032        if pred (x, 1) then f (x + q) elseif pred (x, 2) then g (x + q) elseif pred (x, q) then v1 :: r * x else var1 : q * r,
3033        if pred (x, 1) then f (x + q) else if pred (x, 2) then g (x + q) else if pred (x, q) then v2 :: r * x else var2 : q * r,
3034        if pred (x, 1) and q then f (x + q) elseif pred (x, 2) or q then g (x + q) elseif not pred (x, q) then v1 :: r * x else var1 : q * r,
3035        if pred (x, 1) and q then f (x + q) else if pred (x, 2) or q then g (x + q) else if not pred (x, q) then v2 :: r * x else var2 : q * r,
3036        if pred (x, 1) and not q then f (x + q) elseif pred (x, 2) or not q then g (x + q) elseif not pred (x, q) then v1 :: r * x else var1 : q * r,
3037        if pred (x, 1) and not q then f (x + q) else if pred (x, 2) or not q then g (x + q) else if not pred (x, q) then v2 :: r * x else var2 : q * r]),
3038
3039   test () :=
3040     block ([res : []],
3041       block ([prederror : false],
3042         push (errcatch (foo (true, false)), res)),
3043       block ([prederror : false,
3044               l : [true, false, 1, 2.0, 3.0b0, %i, 'z, 'z ()]],
3045         for x in l do
3046           for q in l do
3047             push (foo (x, q), res)),
3048       res),
3049
3050   l1 : test (),
3051
3052   translate_or_lose (pred, foo),
3053
3054   l2 : test (),
3055
3056   is (l1 = l2));
3057 true;
3058
3059 (kill (pred, foo), 0);
3060 0;
3061
3062 block ([translate : false, l1, l2],
3063   local (test),
3064
3065   /* I really want push(x,a) below in foo, bar and baz,
3066    * but the translation of the push special form just
3067    * punts to MEVAL.  I want the loop bodies translated
3068    * better than that, especially in baz, so just do
3069    * a:cons(x,a) everywhere here.
3070    */
3071
3072   foo () :=
3073     [block ([a : []],
3074        for x : 1 thru 5 do a : cons (x, a),
3075        a),
3076      block ([a : []],
3077        for x : 1 thru 5 while x < 3 do a : cons (x, a),
3078        a),
3079      block ([a : []],
3080        for x : 1 thru 5 while x > 3 do a : cons (x, a),
3081        a),
3082      block ([a : []],
3083        for x : 1 thru 5 while x < 10 do a : cons (x, a),
3084        a),
3085      block ([a : []],
3086        for x : 1 thru 5 while x > 10 do a : cons (x, a),
3087        a),
3088      block ([a : []],
3089        for x : 1 thru 5 unless x < 3 do a : cons (x, a),
3090        a),
3091      block ([a : []],
3092        for x : 1 thru 5 unless x > 3 do a : cons (x, a),
3093        a)],
3094
3095   bar (p) :=
3096     [block ([a : []],
3097        for x : 1 thru 5 while p do a : cons (x, a),
3098        a),
3099      block ([a : []],
3100        for x : 1 thru 5 while x < 3 and p do a : cons (x, a),
3101        a),
3102      block ([a : []],
3103        for x : 1 thru 5 while x < 3 or p do a : cons (x, a),
3104        a),
3105      block ([a : []],
3106        for x : 1 thru 5 while x < 10 or 'z do a : cons (x, a),
3107        a)],
3108
3109   baz () :=
3110     [block ([a : []],
3111        for x : 1 thru 5 do a : cons (if x then x else false, a),
3112        a),
3113      block ([a : []],
3114        for x : 1 thru 5 while x < 3 do a : cons (if x then x else false, a),
3115        a)],
3116
3117   test () :=
3118     block ([res : []],
3119       push (foo (), res),
3120       for p in [true, false] do
3121         push (bar (p), res),
3122       push (baz (), res),
3123       push (errcatch (bar ('z)), res),
3124       res),
3125
3126   l1 : test (),
3127
3128   translate_or_lose (foo, bar, baz),
3129
3130   l2 : test (),
3131
3132   is (l1 = l2));
3133 true;
3134
3135 (kill (foo, bar, baz), 0);
3136 0;
3137
3138 /* Basic tests for error checking of translated return and go forms */
3139
3140 (foo () := return (),
3141  translate (foo));
3142 [];
3143
3144 (foo () := do return (1),
3145  translate_or_lose (foo),
3146  foo ());
3147 1;
3148
3149 (foo () := block (return (2)),
3150  translate_or_lose (foo),
3151  foo ());
3152 2;
3153
3154 (foo () := go (x),
3155  translate (foo));
3156 [];
3157
3158 (foo () := block (go (f ())),
3159  translate (foo));
3160 [];
3161
3162 /* *cough* */
3163 (foo () := do (go (1), return (false), 1, return (true)),
3164  translate_or_lose (foo),
3165  foo ());
3166 true;
3167
3168 /* *cough* */
3169 (foo () := block (block (go (x)), return (1), go (x), return (2), x, 3),
3170  translate_or_lose (foo),
3171  foo ());
3172 3;
3173
3174 (foo () := block (go (end), return (0), end, 1),
3175  translate_or_lose (foo),
3176  foo ());
3177 1;
3178
3179 (kill (foo), 0);
3180 0;
3181
3182 /* Bug #4260: translate fails with go tag in final position */
3183
3184 block ([translate : false, l1, l2],
3185   foo () :=
3186     [block (),
3187      block ([]),
3188      block (1),
3189      block (a),
3190      block ('a),
3191      block (done),
3192      block ('done),
3193      block (go (0), return (false), 0),
3194      block (go (a), return (false), a),
3195      block (go (done), return (false), done),
3196      block (go (b), return (false), b, 1),
3197      block (go (c), return (false), c, d),
3198      block (go (f), return (false), f, 'g),
3199      block (go (done), return (false), done, 'end),
3200      block (go (2), return (false), 1, return (true), 2, go (1))],
3201
3202   l1 : foo (),
3203
3204   translate_or_lose (foo),
3205
3206   l2 : foo (),
3207
3208   is (l1 = l2));
3209 true;
3210
3211 (kill (foo), 0);
3212 0;
3213
3214
3215
3216
3217
3218 /*** KILLING THESE FUNCTIONS SHOULD BE THE LAST TEST IN THIS FILE ***/
3219 (kill (translate_or_lose, compile_or_lose), 0);
3220 0;
3221 /*** THERE SHOULD BE NO TESTS BEYOND THIS POINT ***/