tests/picobit/picobit-vm-sixpic.c

   1 // TODO at least, use #include and #define, but #define would require me to start all over...
   2 // no typedefs
   3 // no forward declarations
   4 // Scheme-style hex literals
   5 // no explicit casts (intermediate variables instead)
   6 // removed functions that interact with the firmware, and with rom
   7 // had some case labels that were not literals (but could have been constant folded) in the dispatch
   8
   9 /* typedef char int8; */
  10 /* typedef short int16; */
  11 /* typedef long int32; */
  12 /* typedef unsigned char uint8; */
  13 /* typedef unsigned short uint16; */
  14 /* typedef unsigned long uint32; */
  15
  16 /* typedef uint8 word; */
  17
  18 /* typedef uint16 ram_addr; */
  19 /* typedef uint16 rom_addr; */
  20
  21 int16 arg1;
  22 int16 arg2;
  23 int16 arg3;
  24 int16 arg4;
  25 int16 arg5;
  26 int16 cont;
  27 int16 env;
  28
  29 int8 na;
  30 int16 pc;
  31 int8 glovars;
  32 int16 entry;
  33 int8 bytecode;
  34 int8 bytecode_hi4;
  35 int8 bytecode_lo4;
  36 int16 a1;
  37 int16 a2;
  38 int16 a3;
  39
  40 void halt_with_error (){
  41   return; // TODO
  42 }
  43
  44
  45 /* typedef int16 obj; */ // TODO actually has 21 bits
  46 /* int8 rom_get (int16 a){ */
  47 /*   return /\* *(int8*) *\/a; // TODO had rom, but caused problems */
  48 /* } */ // TODO now a predefined routine
  49 /* int8 ram_get_gc_tags (int16 o); */
  50 /* int8 ram_get_gc_tag0 (int16 o); */
  51 /* int8 ram_get_gc_tag1 (int16 o); */
  52 /* void ram_set_gc_tags (int16 o, int8 tags); */
  53 /* void ram_set_gc_tag0 (int16 o, int8 tag); */
  54 /* void ram_set_gc_tag1 (int16 o, int8 tag); */
  55 /* int8 ram_get_field0 (int16 o); */
  56 /* int8 ram_get_field1 (int16 o); */
  57 /* int8 ram_get_field2 (int16 o); */
  58 /* int8 ram_get_field3 (int16 o); */
  59 /* int8 ram_get_fieldn (int16 o, int8 n); */
  60 /* void ram_set_field0 (int16 o, int8 val); */
  61 /* void ram_set_field1 (int16 o, int8 val); */
  62 /* void ram_set_field2 (int16 o, int8 val); */
  63 /* void ram_set_field3 (int16 o, int8 val); */
  64 /* void ram_set_fieldn (int16 o, int8 n, int8 val); */
  65 /* int8 rom_get_field0 (int16 o); */
  66 /* int8 rom_get_field1 (int16 o); */
  67 /* int8 rom_get_field2 (int16 o); */
  68 /* int8 rom_get_field3 (int16 o); */
  69 int8 ram_get_gc_tags (int16 o) {
  70   int16 t2 = o - 512;
  71   return (*(((t2 << 2))+#x200) & #x60); // TODO not sure these shifts really save on code space, maybe multiplications (which would be 2 additions) would be better
  72 }
  73 int8 ram_get_gc_tag0 (int16 o) {
  74   int16 t2 = o - 512;
  75   return (*(((t2 << 2))+#x200) & #x20);
  76 }
  77 int8 ram_get_gc_tag1 (int16 o) {
  78   int16 t2 = o - 512;
  79   return (*(((t2 << 2))+#x200) & #x40);
  80 }
  81 void ram_set_gc_tags (int16 o, int8 tags) {
  82   int16 t2 = (o - 512) << 2; // TODO optimized a couple of things
  83   (*((t2)+#x200) = ((*((t2)+#x200) & #x9f) | (tags))); // TODO if we could use bst and bcf, would be better
  84 }
  85 void ram_set_gc_tag0 (int16 o, int8 tag) {
  86   int16 t2 = (o - 512) << 2; // TODO same here
  87   *(t2+#x200) = ((*(t2+#x200) & #xdf) | (tag));
  88 }
  89 void ram_set_gc_tag1 (int16 o, int8 tag) {
  90   int16 t2 = (o - 512) << 2; // TODO same here
  91   *(t2+#x200) = ((*(t2+#x200) & #xbf) | (tag));
  92 }
  93 int8 ram_get_field0 (int16 o) { int16 t2 = o - 512; return *(((t2 << 2) + (0))+#x200); }
  94 int8 ram_get_field1 (int16 o) { int16 t2 = o - 512; return *(((t2 << 2) + (1))+#x200); }
  95 int8 ram_get_field2 (int16 o) { int16 t2 = o - 512; return *(((t2 << 2) + (2))+#x200); }
  96 int8 ram_get_field3 (int16 o) { int16 t2 = o - 512; return *(((t2 << 2) + (3))+#x200); }
  97 int8 ram_get_fieldn (int16 o, int8 n) {
  98   switch (n) {
  99   case 0: return ram_get_field0 (o);
 100   case 1: return ram_get_field1 (o);
 101   case 2: return ram_get_field2 (o);
 102   case 3: return ram_get_field3 (o);
 103   }
 104 }
 105 void ram_set_field0 (int16 o, int8 val) { int16 t2 = o - 512; *(((t2 << 2) + (0))+#x200) = (val); }
 106 void ram_set_field1 (int16 o, int8 val) { int16 t2 = o - 512; *(((t2 << 2) + (1))+#x200) = (val); }
 107 void ram_set_field2 (int16 o, int8 val) { int16 t2 = o - 512; *(((t2 << 2) + (2))+#x200) = (val); }
 108 void ram_set_field3 (int16 o, int8 val) { int16 t2 = o - 512; *(((t2 << 2) + (3))+#x200) = (val); }
 109 void ram_set_fieldn (int16 o, int8 n, int8 val) {
 110   switch (n) {
 111   case 0: ram_set_field0 (o, val); break;
 112   case 1: ram_set_field1 (o, val); break;
 113   case 2: ram_set_field2 (o, val); break;
 114   case 3: ram_set_field3 (o, val); break;
 115   }
 116 }
 117 int8 rom_get_field0 (int16 o) { int16 t2 = (o) - (3 +255 - -1 +1); return rom_get (((t2 << 2) + (#x8000 + 4 + (0)))); }
 118 int8 rom_get_field1 (int16 o) { int16 t2 = (o) - (3 +255 - -1 +1); return rom_get (((t2 << 2) + (#x8000 + 4 + (1)))); }
 119 int8 rom_get_field2 (int16 o) { int16 t2 = (o) - (3 +255 - -1 +1); return rom_get (((t2 << 2) + (#x8000 + 4 + (2)))); }
 120 int8 rom_get_field3 (int16 o) { int16 t2 = (o) - (3 +255 - -1 +1); return rom_get (((t2 << 2) + (#x8000 + 4 + (3)))); }
 121
 122
 123 /* int16 ram_get_car (int16 o); */
 124 /* int16 rom_get_car (int16 o); */
 125 /* int16 ram_get_cdr (int16 o); */
 126 /* int16 rom_get_cdr (int16 o); */
 127 /* void ram_set_car (int16 o, int16 val); */
 128 /* void ram_set_cdr (int16 o, int16 val); */
 129
 130 /* int16 ram_get_entry (int16 o); */
 131 /* int16 rom_get_entry (int16 o); */
 132
 133 int16 ram_get_car (int16 o)
 134 { int16 tmp = (ram_get_field0 (o) & #x1f); return (tmp << 8) | ram_get_field1 (o); }
 135 int16 rom_get_car (int16 o)
 136 { int16 tmp = (rom_get_field0 (o) & #x1f); return (tmp << 8) | rom_get_field1 (o); }
 137 int16 ram_get_cdr (int16 o)
 138 { int16 tmp = (ram_get_field2 (o) & #x1f); return (tmp << 8) | ram_get_field3 (o); }
 139 int16 rom_get_cdr (int16 o)
 140 { int16 tmp = (rom_get_field2 (o) & #x1f); return (tmp << 8) | rom_get_field3 (o); }
 141
 142 void ram_set_car (int16 o, int16 val) {
 143   ram_set_field0 (o, (val >> 8) | (ram_get_field0 (o) & #xe0));
 144   ram_set_field1 (o, val & #xff);
 145 }
 146 void ram_set_cdr (int16 o, int16 val) {
 147   ram_set_field2 (o, (val >> 8) | (ram_get_field2 (o) & #xe0));
 148   ram_set_field3 (o, val & #xff);
 149 }
 150
 151
 152 int16 ram_get_entry (int16 o) {
 153   int16 tmp = (ram_get_field0 (o) & #x1f);
 154   return ((tmp << 11)
 155    | (ram_get_field1 (o) << 3)
 156    | (ram_get_field2 (o) >> 5));
 157 }
 158 int16 rom_get_entry (int16 o){
 159   int16 tmp = (rom_get_field0 (o) & #x1f);
 160   return ((tmp << 11)
 161    | (rom_get_field1 (o) << 3)
 162    | (rom_get_field2 (o) >> 5));
 163 }
 164
 165
 166 /* int16 get_global (int8 i); */
 167 /* void set_global (int8 i, int16 o); */
 168
 169 int16 get_global (int8 i) {
 170
 171   if (i & 1)
 172     return ram_get_cdr (512 + (i >> 1));
 173   else
 174     return ram_get_car (512 + (i >> 1));
 175 }
 176 void set_global (int8 i, int16 o) {
 177   if (i & 1)
 178     ram_set_cdr (512 + (i >> 1), o);
 179   else
 180     ram_set_car (512 + (i >> 1), o);
 181 }
 182
 183 int16 free_list;
 184 int16 free_list_vec;
 185
 186 void mark (int16 temp) {
 187
 188
 189   int16 stack;
 190   int16 visit;
 191
 192   if ((!((temp) >= 1280) && ((temp) >= 512))) {
 193     visit = 0;
 194
 195   push:
 196
 197     stack = visit;
 198     visit = temp;
 199
 200     ;
 201
 202     if (((((ram_get_field0 (visit) & #x80) == #x80) || ((ram_get_field0 (visit) & #xc0) == #x40) || ((ram_get_field0 (visit) & #xc0) == 0)) && ram_get_gc_tag0 (visit))
 203  || (((((ram_get_field0 (visit) & #x80) == #x80) && ((ram_get_field2 (visit) & #xe0) == 0)) || (((ram_get_field0 (visit) & #x80) == #x80) && ((ram_get_field2 (visit) & #xe0) == #x80)))
 204      && (ram_get_gc_tags (visit) != (0<<5))))
 205       ;
 206     else {
 207       if (((((ram_get_field0 (visit) & #x80) == #x80) && ((ram_get_field2 (visit) & #xe0) == 0)) || (((ram_get_field0 (visit) & #x80) == #x80) && ((ram_get_field2 (visit) & #xe0) == #x80)))) {
 208  ;
 209
 210       visit_field2:
 211
 212  temp = ram_get_cdr (visit);
 213
 214  if ((!((temp) >= 1280) && ((temp) >= 512))) {
 215    ;
 216    int16 tmp = 2; // TODO literals should be int, but that's wasteful
 217    ram_set_gc_tags (visit, (tmp<<5));
 218    ram_set_cdr (visit, stack);
 219    goto push;
 220  }
 221
 222  ;
 223
 224  goto visit_field1;
 225       }
 226
 227       if ((((ram_get_field0 (visit) & #x80) == #x80) || ((ram_get_field0 (visit) & #xc0) == #x40) || ((ram_get_field0 (visit) & #xc0) == 0))) {
 228  ;
 229
 230       visit_field1:
 231
 232
 233  if (((ram_get_field0 (visit) & #xc0) == #x40))
 234    temp = ram_get_cdr (visit);
 235  else
 236    temp = ram_get_car (visit);
 237
 238  if ((!((temp) >= 1280) && ((temp) >= 512))) {
 239    ;
 240    int16 tmp = 1;
 241    ram_set_gc_tag0 (visit, (tmp<<5));
 242    if (((ram_get_field0 (visit) & #xc0) == #x40))
 243      ram_set_cdr (visit, stack);
 244    else
 245      ram_set_car (visit, stack);
 246
 247    goto push;
 248  }
 249
 250  ;
 251       }
 252       else
 253  ;
 254       int tmp = 1;
 255       ram_set_gc_tag0 (visit, (tmp<<5));
 256     }
 257
 258   pop:
 259
 260     ;
 261
 262     if (stack != 0) {
 263       if (((((ram_get_field0 (stack) & #x80) == #x80) && ((ram_get_field2 (stack) & #xe0) == 0)) || (((ram_get_field0 (stack) & #x80) == #x80) && ((ram_get_field2 (stack) & #xe0) == #x80))) && ram_get_gc_tag1 (stack)) {
 264  ;
 265
 266  temp = ram_get_cdr (stack);
 267  ram_set_cdr (stack, visit);
 268  visit = stack;
 269  stack = temp;
 270
 271  ram_set_gc_tag1(visit, (0<<5));
 272
 273
 274  goto visit_field1;
 275       }
 276
 277       if (((ram_get_field0 (stack) & #xc0) == #x40)) {
 278
 279  ;
 280
 281  temp = ram_get_cdr (stack);
 282  ram_set_cdr (stack, visit);
 283  visit = stack;
 284  stack = temp;
 285
 286  goto pop;
 287       }
 288
 289       ;
 290
 291       temp = ram_get_car (stack);
 292       ram_set_car (stack, visit);
 293       visit = stack;
 294       stack = temp;
 295
 296       goto pop;
 297     }
 298   }
 299 }
 300
 301
 302
 303
 304
 305 void sweep () {
 306
 307
 308
 309
 310
 311
 312   int16 visit = 1279;
 313
 314   free_list = 0;
 315
 316   while (visit >= (512 + ((glovars + 1) >> 1))) {
 317
 318     int tmp = 1;
 319     if ((((ram_get_field0 (visit) & #x80) == #x80)
 320   && (ram_get_gc_tags (visit) == (0<<5)))
 321  || !(ram_get_gc_tags (visit) & (tmp<<5))) {
 322
 323       if ((((ram_get_field0 (visit) & #x80) == #x80) && ((ram_get_field2 (visit) & #xe0) == #x60))) {
 324
 325  int16 o = ram_get_cdr (visit);
 326  int16 i = ram_get_car (visit);
 327  ram_set_car (o, free_list_vec);
 328  ram_set_cdr (o, (i + 3) >> 2);
 329  free_list_vec = o;
 330
 331       }
 332       ram_set_car (visit, free_list);
 333       free_list = visit;
 334       }
 335     else {
 336       if (((ram_get_field0 (visit) & #x80) == #x80))
 337  ram_set_gc_tags (visit, (0<<5));
 338       else
 339  ram_set_gc_tag0 (visit, (0<<5));
 340
 341
 342
 343     }
 344     visit--;
 345   }
 346 }
 347
 348 void gc () {
 349   int8 i;
 350
 351   ;
 352
 353   ;
 354   mark (arg1);
 355   ;
 356   mark (arg2);
 357   ;
 358   mark (arg3);
 359   ;
 360   mark (arg4);
 361   ;
 362   mark (arg5);
 363   ;
 364   mark (cont);
 365   ;
 366   mark (env);
 367
 368   ;
 369   for (i=0; i<glovars; i++)
 370     mark (get_global (i));
 371
 372   sweep ();
 373 }
 374
 375
 376 int16 alloc_ram_cell () {
 377   int16 o;
 378
 379
 380
 381
 382
 383   if (free_list == 0) {
 384
 385     gc ();
 386     if (free_list == 0)
 387
 388       halt_with_error();
 389   }
 390
 391   o = free_list;
 392
 393   free_list = ram_get_car (o);
 394
 395   return o;
 396 }
 397
 398 int16 alloc_ram_cell_init (int8 f0, int8 f1, int8 f2, int8 f3) {
 399   int16 o = alloc_ram_cell ();
 400
 401   ram_set_field0 (o, f0);
 402   ram_set_field1 (o, f1);
 403   ram_set_field2 (o, f2);
 404   ram_set_field3 (o, f3);
 405
 406   return o;
 407 }
 408
 409 int16 alloc_vec_cell (int16 n) {
 410   int16 o = free_list_vec;
 411   int16 prec = 0;
 412   int8 gc_done = 0;
 413
 414
 415
 416
 417
 418
 419   while ((ram_get_cdr (o) * 4) < n) {
 420     if (o == 0) {
 421       if (gc_done)
 422  halt_with_error();
 423
 424       gc ();
 425       gc_done = 1;
 426
 427       o = free_list_vec;
 428       prec = 0;
 429       continue;
 430     }
 431     prec = o;
 432     o = ram_get_car (o);
 433   }
 434
 435
 436
 437   if (((ram_get_cdr(o) * 4) - n) < 4) {
 438     if (prec)
 439       ram_set_car (prec, ram_get_car (o));
 440     else
 441       free_list_vec = ram_get_car (o);
 442   }
 443
 444
 445   else {
 446     int16 new_free = o + (n + 3) >> 2;
 447     if (prec)
 448       ram_set_car (prec, new_free);
 449     else
 450       free_list_vec = new_free;
 451     ram_set_car (new_free, ram_get_car (o));
 452     ram_set_cdr (new_free, ram_get_cdr (o) - (n + 3) >> 2);
 453   }
 454
 455   return o;
 456 }
 457
 458
 459
 460 /* typedef int16 integer; */
 461 /* typedef int16 digit; */
 462 /* typedef int32 two_digit; */
 463 /* int16 make_integer (int16 lo, int16 hi); */
 464 /* int16 integer_hi (int16 x); */
 465 /* int16 integer_lo (int16 x); */
 466 int16 make_integer (int16 lo, int16 hi) {
 467   return alloc_ram_cell_init (0 | (hi >> 8), hi, lo >> 8, lo);
 468 }
 469
 470 int16 integer_hi (int16 x) {
 471   if ((!((x) >= 1280) && ((x) >= 512)))
 472     return ram_get_car (x);
 473   else if ((!((x) >= 1280) && !(!((x) >= 1280) && ((x) >= 512)) && ((x) >= (3 +255 - -1 +1))))
 474     return rom_get_car (x);
 475   else if (x < (3 - -1)){
 476     return ((0 + (3 - -1))-1);
 477   }
 478   else{
 479     return (0 + (3 - -1));
 480   }
 481 }
 482
 483 int16 integer_lo (int16 x) {
 484   int16 t = ram_get_field2 (x);
 485   if ((!((x) >= 1280) && ((x) >= 512)))
 486     return (t << 8) + ram_get_field3 (x);
 487   else if ((!((x) >= 1280) && !(!((x) >= 1280) && ((x) >= 512)) && ((x) >= (3 +255 - -1 +1))))
 488     return (t << 8) + rom_get_field3 (x);
 489   else
 490     return x - (3 - -1);
 491 }
 492
 493
 494 /* int16 norm (int16 prefix, int16 n); */
 495 /* int8 negp (int16 x); */
 496 /* int8 cmp (int16 x, int16 y); */
 497 /* int16 integer_length (int16 x); */
 498 /* int16 shr (int16 x); */
 499 /* int16 negative_carry (int16 carry); */
 500 /* int16 shl (int16 x); */
 501 /* int16 shift_left (int16 x, int16 n); */
 502 /* int16 add (int16 x, int16 y); */
 503 /* int16 invert (int16 x); */
 504 /* int16 sub (int16 x, int16 y); */
 505 /* int16 neg (int16 x); */
 506 /* int16 scale (int16 n, int16 x); */
 507 /* int16 mulnonneg (int16 x, int16 y); */
 508 /* int16 divnonneg (int16 x, int16 y); */
 509
 510 int32 decode_int (int16 o) {
 511   int8 result;
 512   if (o < 3)
 513     halt_with_error();
 514
 515   if (o <= (3 + (255 - -1)))
 516     return (o - (3 - -1));
 517
 518   if ((!((o) >= 1280) && ((o) >= 512))) {
 519     if (!((ram_get_field0 (o) & #xc0) == 0))
 520       halt_with_error();
 521     return ram_get_field3 (o);
 522   }
 523   else if ((!((o) >= 1280) && !(!((o) >= 1280) && ((o) >= 512)) && ((o) >= (3 +255 - -1 +1)))) {
 524     if (!((rom_get_field0 (o) & #xc0) == 0))
 525       halt_with_error();
 526     return rom_get_field3 (o);
 527   }
 528   else
 529     halt_with_error();
 530 }
 531
 532 /* int32 decode_int (int16 o); */
 533 /* int16 encode_int (int32 n); */
 534
 535 int16 norm (int16 prefix, int16 n) {
 536
 537
 538
 539   while (prefix != 0) {
 540     int16 d = integer_lo (prefix);
 541     int16 temp = prefix;
 542
 543     prefix = integer_hi (temp);
 544
 545     if (((n) == ((0 + (3 - -1))))) {
 546       if (d <= 255) {
 547         n = (d + (3 - -1));
 548         continue;
 549       }
 550     }
 551     else if (((n) == (((0 + (3 - -1))-1)))) {
 552       int tmp = 1;
 553       if (d >= (tmp<<16) + -1) {
 554         int16 t = d - (tmp << 16);
 555         n = (t + (3 - -1));
 556         continue;
 557       }
 558     }
 559
 560     ram_set_car (temp, n);
 561     n = temp;
 562   }
 563
 564   return n;
 565 }
 566
 567 int8 negp (int16 x) {
 568
 569
 570   do {
 571     x = integer_hi (x);
 572     if (((x) == ((0 + (3 - -1))))) return 0;
 573   } while (!((x) == (((0 + (3 - -1))-1))));
 574
 575   return 1;
 576 }
 577
 578 int8 cmp (int16 x, int16 y) { // TODO changed. used to return -1, 0 and 1, now is 0, 1, 2
 579
 580
 581   int8 result = 1; // in cmp.c : cell 3
 582   int16 xlo;
 583   int16 ylo;
 584
 585   for (;;) { // bb 2
 586     if (((x) == ((0 + (3 - -1)))) // bbs 2 and 8
 587         || ((x) == (((0 + (3 - -1))-1)))) { // bbs 7 and 9
 588       if (!((x) == (y))) // bbs 6 and 12
 589         { if (negp (y)) // bb 11
 590             result = 2; // bb 14
 591           else result = 0; } // bb 15
 592       break; // bb 10
 593     }
 594
 595     if (((y) == ((0 + (3 - -1)))) // bbs 5 and 19
 596         || ((y) == (((0 + (3 - -1))-1)))) { // bbs 18 and 20
 597       if (negp (x)) // bb 17
 598         result = 0; // bb 22
 599       else result = 2; // bb 23
 600       break; // bb 21
 601     }
 602
 603     xlo = integer_lo (x); // bb 16
 604     ylo = integer_lo (y);
 605     x = integer_hi (x);
 606     y = integer_hi (y);
 607     if (xlo != ylo) // bb 16 and 26
 608       { if (xlo < ylo) // bb 25
 609           result = 0; // bb 28
 610         else result = 2; } // bb 29
 611   }
 612   return result;
 613 }
 614
 615 int16 integer_length (int16 x) {
 616
 617
 618
 619   int16 result = 0;
 620   int16 next;
 621   int16 d;
 622
 623   while (!(((next = integer_hi (x))) == ((0 + (3 - -1))))) {
 624     result += 16;
 625     x = next;
 626   }
 627
 628   d = integer_lo (x);
 629
 630   while (d > 0) {
 631     result++;
 632     d >>= 1;
 633   }
 634
 635   return result;
 636 }
 637
 638 int16 shr (int16 x) {
 639
 640
 641   int16 result = 0;
 642   int16 d;
 643
 644   for (;;) {
 645     if (((x) == ((0 + (3 - -1)))) || ((x) == (((0 + (3 - -1))-1)))) {
 646       result = norm (result, x);
 647       break;
 648     }
 649
 650     d = integer_lo (x);
 651     x = integer_hi (x);
 652     int tmp = 1;
 653     result = make_integer ((d >> 1) |
 654                            ((integer_lo (x) & 1) ? (tmp<<15) : 0), // TODO only shifting by literals is permitted, so had to change the 16 -1 to 15
 655                            result);
 656   }
 657
 658   return result;
 659 }
 660
 661 int16 negative_carry (int16 carry) {
 662   if (carry)
 663     return ((0 + (3 - -1))-1);
 664   else
 665     return (0 + (3 - -1));
 666 }
 667
 668 int16 shl (int16 x) {
 669
 670
 671   int16 negc = (0 + (3 - -1));
 672   int16 temp;
 673   int16 result = 0;
 674   int16 d;
 675
 676   for (;;) {
 677     if (((x) == (negc))) {
 678       result = norm (result, x);
 679       break;
 680     }
 681
 682     d = integer_lo (x);
 683     x = integer_hi (x);
 684     temp = negc;
 685     int tmp = 1;
 686     negc = negative_carry (d & (tmp<<15));
 687     result = make_integer ((d << 1) | ((temp) == (3)), result); // TODO was ((0 + (3 - -1))-1)
 688   }
 689
 690   return result;
 691 }
 692
 693 int16 shift_left (int16 x, int16 n) {
 694
 695
 696   if (((x) == ((0 + (3 - -1)))))
 697     return x;
 698
 699   while (n & (16 -1)) {
 700     x = shl (x);
 701     n--;
 702   }
 703
 704   while (n > 0) {
 705     x = make_integer (0, x);
 706     n -= 16;
 707   }
 708
 709   return x;
 710 }
 711
 712 int16 add (int16 x, int16 y) {
 713
 714
 715   int16 negc = (0 + (3 - -1));
 716   int16 result = 0;
 717   int16 dx;
 718   int16 dy;
 719
 720   for (;;) {
 721     if (((x) == (negc))) {
 722       result = norm (result, y);
 723       break;
 724     }
 725
 726     if (((y) == (negc))) {
 727       result = norm (result, x);
 728       break;
 729     }
 730
 731     dx = integer_lo (x);
 732     dy = integer_lo (y);
 733     dx = dx + dy;
 734
 735     if (((negc) == ((0 + (3 - -1)))))
 736       negc = negative_carry (dx < dy);
 737     else {
 738       dx++;
 739       negc = negative_carry (dx <= dy);
 740     }
 741
 742     x = integer_hi (x);
 743     y = integer_hi (y);
 744
 745     result = make_integer (dx, result);
 746   }
 747
 748   return result;
 749 }
 750
 751 int16 invert (int16 x) {
 752   if (((x) == ((0 + (3 - -1)))))
 753     return ((0 + (3 - -1))-1);
 754   else
 755     return (0 + (3 - -1));
 756 }
 757
 758 int16 sub (int16 x, int16 y) {
 759
 760   int16 negc = ((0 + (3 - -1))-1);
 761   int16 result = 0;
 762   int16 dx;
 763   int16 dy;
 764
 765   for (;;) {
 766     if (((x) == (negc)) && (((y) == ((0 + (3 - -1)))) || ((y) == (((0 + (3 - -1))-1))))) {
 767       result = norm (result, invert (y));
 768       break;
 769     }
 770
 771     if (((y) == (invert (negc)))) {
 772       result = norm (result, x);
 773       break;
 774     }
 775
 776     dx = integer_lo (x);
 777     dy = ~integer_lo (y);
 778     dx = dx + dy;
 779
 780     if (((negc) == ((0 + (3 - -1)))))
 781       negc = negative_carry (dx < dy);
 782     else {
 783       dx++;
 784       negc = negative_carry (dx <= dy);
 785     }
 786
 787     x = integer_hi (x);
 788     y = integer_hi (y);
 789
 790     result = make_integer (dx, result);
 791   }
 792
 793   return result;
 794 }
 795
 796 int16 neg (int16 x) {
 797
 798
 799   return sub ((0 + (3 - -1)), x);
 800 }
 801
 802 int16 scale (int16 n, int16 x) {
 803
 804
 805   int16 result;
 806   int16 carry;
 807   int32 m;
 808
 809   if ((n == 0) || ((x) == ((0 + (3 - -1)))))
 810     return (0 + (3 - -1));
 811
 812   if (n == 1)
 813     return x;
 814
 815   result = 0;
 816   carry = 0;
 817
 818   for (;;) {
 819     if (((x) == ((0 + (3 - -1))))){
 820       if (carry <= 255)
 821         result = norm (result, (carry + (3 - -1)));
 822       else
 823         result = norm (result, make_integer (carry, (0 + (3 - -1))));
 824       break;
 825     }
 826
 827     if (((x) == (((0 + (3 - -1))-1)))) {
 828       carry = carry - n;
 829       int tmp = 1;
 830       if (carry >= ((tmp<<16) + -1))
 831         result = norm (result, ((carry & #xff) + (3 - -1)));
 832       else
 833         result = norm (result, make_integer (carry, ((0 + (3 - -1))-1)));
 834       break;
 835     }
 836
 837     int32 tmp1 = integer_lo (x);
 838     m = tmp1 * n + carry;
 839
 840     x = integer_hi (x);
 841     carry = m >> 16;
 842     int16 tmp2 = m;
 843     result = make_integer (tmp2, result);
 844   }
 845
 846   return result;
 847 }
 848
 849 int16 mulnonneg (int16 x, int16 y) {
 850
 851
 852
 853   int16 result = 0;
 854   int16 s = scale (integer_lo (x), y);
 855
 856   for (;;) {
 857     result = make_integer (integer_lo (s), result);
 858     s = integer_hi (s);
 859     x = integer_hi (x);
 860
 861     if (((x) == ((0 + (3 - -1)))))
 862       break;
 863
 864     s = add (s, scale (integer_lo (x), y));
 865   }
 866
 867   return norm (result, s);
 868 }
 869
 870
 871 int16 divnonneg (int16 x, int16 y) {
 872
 873
 874
 875   int16 result = (0 + (3 - -1));
 876   int16 lx = integer_length (x);
 877   int16 ly = integer_length (y);
 878
 879   if (lx >= ly) {
 880     lx = lx - ly;
 881
 882     y = shift_left (y, lx);
 883
 884     do {
 885       result = shl (result);
 886       if (cmp (x, y) >= 1) { // TODO cmp changed
 887         x = sub (x, y);
 888         result = add (((0 + (3 - -1))+1), result);
 889       }
 890       y = shr (y);
 891     } while (lx-- != 0);
 892   }
 893
 894   return result;
 895 }
 896
 897 int16 bitwise_ior (int16 x, int16 y) {
 898
 899
 900   int16 result = 0;
 901
 902   for (;;){
 903     if (((x) == ((0 + (3 - -1)))))
 904       return norm(result, y);
 905     if (((x) == (((0 + (3 - -1))-1))))
 906       return norm(result, x);
 907     result = make_integer(integer_lo(x) | integer_lo(y),
 908                           result);
 909     x = integer_hi(x);
 910     y = integer_hi(y);
 911   }
 912 }
 913
 914 int16 bitwise_xor (int16 x, int16 y) {
 915
 916
 917   int16 result = 0;
 918
 919   for (;;){
 920     if (((x) == ((0 + (3 - -1)))))
 921       return norm(result, y);
 922     if (((x) == (((0 + (3 - -1))-1))))
 923       return norm(result, x);
 924     result = make_integer(integer_lo(x) ^ integer_lo(y),
 925      result);
 926     x = integer_hi(x);
 927     y = integer_hi(y);
 928   }
 929 }
 930
 931
 932
 933 int16 encode_int (int32 n) {
 934   if (n >= -1 && n <= 255) {
 935     int16 tmp = n;
 936     return (tmp + (3 - -1));
 937   }
 938
 939   return alloc_ram_cell_init (0, (0 + (3 - -1)), n >> 8, n);
 940 }
 941 void decode_2_int_args () {
 942   a1 = decode_int (arg1);
 943   a2 = decode_int (arg2);
 944 }
 945
 946
 947
 948
 949
 950 void prim_numberp () {
 951   if (arg1 >= 3
 952       && arg1 <= (3 + (255 - -1)))
 953     arg1 = 1;
 954   else {
 955     if ((!((arg1) >= 1280) && ((arg1) >= 512))){
 956       arg1 = (ram_get_field0 (arg1) & #xc0) == 0;
 957     }
 958     else if ((!((arg1) >= 1280) && !(!((arg1) >= 1280) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1))))
 959       arg1 = (rom_get_field0 (arg1) & #xc0) == 0;
 960     else
 961       arg1 = 0;
 962   }
 963 }
 964 void prim_add () {
 965
 966   arg1 = add (arg1, arg2);
 967
 968
 969
 970
 971   arg2 = 0;
 972 }
 973
 974 void prim_sub () {
 975
 976   arg1 = sub (arg1, arg2);
 977
 978
 979
 980
 981   arg2 = 0;
 982 }
 983
 984 void prim_mul () {
 985
 986   a1 = negp (arg1);
 987   a2 = negp (arg2);
 988   arg1 = mulnonneg (a1 ? neg(arg1) : arg1,
 989       a2 ? neg(arg2) : arg2);
 990   if (a1 + a2 == 1)
 991     arg1 = neg(arg1);
 992
 993
 994
 995
 996   arg2 = 0;
 997 }
 998
 999 void prim_div () {
1000
1001   if (((arg2) == (((0) + (3 - -1)))))
1002     halt_with_error();
1003   a1 = negp (arg1);
1004   a2 = negp (arg2);
1005   arg1 = divnonneg (a1 ? neg(arg1) : arg1,
1006       a2 ? neg(arg2) : arg2);
1007   if (a1 + a2 == 1)
1008     arg1 = neg(arg1);
1009
1010
1011
1012
1013
1014
1015   arg2 = 0;
1016 }
1017
1018 void prim_rem () {
1019
1020   if (((arg2) == (((0) + (3 - -1)))))
1021     halt_with_error();
1022   if (negp(arg1) || negp(arg2))
1023     halt_with_error();
1024
1025
1026   arg3 = divnonneg (arg1, arg2);
1027   arg4 = mulnonneg (arg2, arg3);
1028   arg1 = sub(arg1, arg4 );
1029   arg3 = 0;
1030   arg4 = 0;
1031
1032
1033
1034
1035
1036
1037   arg2 = 0;
1038 }
1039
1040 void prim_neg () {
1041
1042   arg1 = neg (arg1);
1043
1044
1045
1046
1047 }
1048
1049 void prim_eq () {
1050
1051   arg1 = ((cmp (arg1, arg2) == 1)); // TODO cmp changed
1052
1053
1054
1055
1056   arg2 = 0;
1057 }
1058
1059 void prim_lt () {
1060
1061   arg1 = ((cmp (arg1, arg2) < 1)); // TODO cmp changed
1062
1063
1064
1065
1066   arg2 = 0;
1067 }
1068
1069 void prim_gt () {
1070
1071   arg1 = ((cmp (arg1, arg2) > 1)); // TODO cmp changed
1072
1073
1074
1075
1076   arg2 = 0;
1077 }
1078
1079 void prim_leq () {
1080
1081   arg1 = ((cmp (arg1, arg2) <= 1)); // TODO cmp changed
1082
1083
1084
1085
1086   arg2 = 0;
1087
1088 }
1089
1090 void prim_geq () {
1091
1092   arg1 = ((cmp (arg1, arg2) >= 1)); // TODO cmp changed
1093
1094
1095
1096
1097   arg2 = 0;
1098 }
1099
1100 void prim_ior () {
1101
1102   arg1 = bitwise_ior(arg1, arg2);
1103
1104
1105
1106
1107   arg2 = 0;
1108 }
1109
1110 void prim_xor () {
1111
1112   arg1 = bitwise_xor(arg1, arg2);
1113
1114
1115
1116
1117   arg2 = 0;
1118 }
1119
1120
1121
1122
1123
1124
1125
1126 void prim_pairp () {
1127   if ((!((arg1) >= 1280) && ((arg1) >= 512)))
1128     arg1 = (((((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == 0))));
1129   else if ((!((arg1) >= 1280) && !(!((arg1) >= 1280) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1))))
1130     arg1 = (((((rom_get_field0 (arg1) & #x80) == #x80) && ((rom_get_field2 (arg1) & #xe0) == 0))));
1131   else
1132     arg1 = 0;
1133 }
1134
1135 int16 cons (int16 car, int16 cdr) {
1136   return alloc_ram_cell_init (#x80 | (car >> 8),
1137          car & #xff,
1138          0 | (cdr >> 8),
1139          cdr & #xff);
1140 }
1141
1142 void prim_cons () {
1143   arg1 = cons (arg1, arg2);
1144   arg2 = 0;
1145 }
1146
1147 void prim_car () {
1148   if ((!((arg1) >= 1280) && ((arg1) >= 512))) {
1149     if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == 0)))
1150       halt_with_error();
1151     arg1 = ram_get_car (arg1);
1152   }
1153   else if ((!((arg1) >= 1280) && !(!((arg1) >= 1280) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1)))) {
1154     if (!(((rom_get_field0 (arg1) & #x80) == #x80) && ((rom_get_field2 (arg1) & #xe0) == 0)))
1155       halt_with_error();
1156     arg1 = rom_get_car (arg1);
1157   }
1158   else
1159     halt_with_error();
1160 }
1161
1162 void prim_cdr () {
1163   if ((!((arg1) >= 1280) && ((arg1) >= 512))) {
1164     if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == 0)))
1165       halt_with_error();
1166     arg1 = ram_get_cdr (arg1);
1167   }
1168   else if ((!((arg1) >= 1280) && !(!((arg1) >= 1280) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1)))) {
1169     if (!(((rom_get_field0 (arg1) & #x80) == #x80) && ((rom_get_field2 (arg1) & #xe0) == 0)))
1170       halt_with_error();
1171     arg1 = rom_get_cdr (arg1);
1172   }
1173   else
1174     halt_with_error();
1175 }
1176
1177 void prim_set_car () {
1178   if ((!((arg1) >= 1280) && ((arg1) >= 512))) {
1179     if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == 0)))
1180       halt_with_error();
1181
1182     ram_set_car (arg1, arg2);
1183     arg1 = 0;
1184     arg2 = 0;
1185   }
1186   else
1187     halt_with_error();
1188 }
1189
1190 void prim_set_cdr () {
1191   if ((!((arg1) >= 1280) && ((arg1) >= 512))) {
1192     if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == 0)))
1193       halt_with_error();
1194
1195     ram_set_cdr (arg1, arg2);
1196     arg1 = 0;
1197     arg2 = 0;
1198   }
1199   else
1200     halt_with_error();
1201 }
1202
1203 void prim_nullp () {
1204   arg1 = ((arg1 == 2));
1205 }
1206
1207
1208
1209
1210
1211 void prim_u8vectorp () {
1212   if ((!((arg1) >= 1280) && ((arg1) >= 512)))
1213     arg1 = (((((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == #x60))));
1214   else if ((!((arg1) >= 1280) && !(!((arg1) >= 1280) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1))))
1215     arg1 = (((((rom_get_field0 (arg1) & #x80) == #x80) && ((rom_get_field2 (arg1) & #xe0) == #x60))));
1216   else
1217     arg1 = 0;
1218 }
1219
1220 void prim_make_u8vector () {
1221   decode_2_int_args ();
1222
1223   if (a2 > 255)
1224     halt_with_error();
1225
1226   arg3 = alloc_vec_cell (a1);
1227   arg1 = alloc_ram_cell_init (#x80 | (a1 >> 8),
1228          a1 & #xff,         #x60 | (arg3 >> 8),
1229          arg3 & #xff);
1230
1231   a1 = (a1 + 3) >> 2;
1232   while (a1--) {
1233     ram_set_field0 (arg3, a2);
1234     ram_set_field1 (arg3, a2);
1235     ram_set_field2 (arg3, a2);
1236     ram_set_field3 (arg3, a2);
1237     arg3++;
1238   }
1239 }
1240
1241 void prim_u8vector_ref () {
1242   a2 = decode_int (arg2);
1243
1244   if ((!((arg1) >= 1280) && ((arg1) >= 512))) {
1245     if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == #x60)))
1246       halt_with_error();
1247     if ((ram_get_car (arg1) <= a2) || (a2 < 0))
1248       halt_with_error();
1249     arg1 = ram_get_cdr (arg1);
1250   }
1251   else if ((!((arg1) >= 1280) && !(!((arg1) >= 1280) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1)))) {
1252     if (!(((rom_get_field0 (arg1) & #x80) == #x80) && ((rom_get_field2 (arg1) & #xe0) == #x60)))
1253       halt_with_error();
1254     if ((rom_get_car (arg1) <= a2) || (a2 < 0))
1255       halt_with_error();
1256     arg1 = rom_get_cdr (arg1);
1257   }
1258   else
1259     halt_with_error();
1260
1261   if (((arg1) >= 1280)) {
1262     arg1 += (a2 >> 2);
1263     a2 %= 4;
1264
1265     arg1 = encode_int (ram_get_fieldn (arg1, a2));
1266   }
1267   else {
1268     while (a2--)
1269       arg1 = rom_get_cdr (arg1);
1270
1271
1272     arg1 = rom_get_car (arg1);
1273   }
1274
1275   arg2 = 0;
1276   arg3 = 0;
1277   arg4 = 0;
1278 }
1279
1280 void prim_u8vector_set () {
1281   a2 = decode_int (arg2);
1282   a3 = decode_int (arg3);
1283
1284   if (a3 > 255)
1285     halt_with_error();
1286
1287   if ((!((arg1) >= 1280) && ((arg1) >= 512))) {
1288     if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == #x60)))
1289       halt_with_error();
1290     if ((ram_get_car (arg1) <= a2) || (a2 < 0))
1291       halt_with_error();
1292     arg1 = ram_get_cdr (arg1);
1293   }
1294   else
1295     halt_with_error();
1296
1297   arg1 += (a2 >> 2);
1298   a2 %= 4;
1299
1300   ram_set_fieldn (arg1, a2, a3);
1301
1302   arg1 = 0;
1303   arg2 = 0;
1304   arg3 = 0;
1305 }
1306
1307 void prim_u8vector_length () {
1308   if ((!((arg1) >= 1280) && ((arg1) >= 512))) {
1309     if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == #x60)))
1310       halt_with_error();
1311     arg1 = encode_int (ram_get_car (arg1));
1312   }
1313   else if ((!((arg1) >= 1280) && !(!((arg1) >= 1280) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1)))) {
1314     if (!(((rom_get_field0 (arg1) & #x80) == #x80) && ((rom_get_field2 (arg1) & #xe0) == #x60)))
1315       halt_with_error();
1316     arg1 = encode_int (rom_get_car (arg1));
1317   }
1318   else
1319     halt_with_error();
1320 }
1321
1322 void prim_u8vector_copy () {
1323
1324
1325
1326   a1 = decode_int (arg2);
1327   a2 = decode_int (arg4);
1328   a3 = decode_int (arg5);
1329
1330
1331   if ((!((arg1) >= 1280) && ((arg1) >= 512)) && (!((arg3) >= 1280) && ((arg3) >= 512))) {
1332     if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == #x60)) || !(((ram_get_field0 (arg3) & #x80) == #x80) && ((ram_get_field2 (arg3) & #xe0) == #x60)))
1333       halt_with_error();
1334     if ((ram_get_car (arg1) < (a1 + a3)) || (a1 < 0) ||
1335  (ram_get_car (arg3) < (a2 + a3)) || (a2 < 0))
1336       halt_with_error();
1337
1338
1339     arg1 = ram_get_cdr (arg1);
1340     arg1 += (a1 >> 2);
1341     a1 %= 4;
1342     arg3 = ram_get_cdr (arg3);
1343     arg3 += (a2 >> 2);
1344     a2 %= 4;
1345
1346
1347     while (a3--) {
1348       ram_set_fieldn (arg3, a2, ram_get_fieldn (arg1, a1));
1349
1350       a1++;
1351       arg1 += (a1 >> 2);
1352       a1 %= 4;
1353       a2++;
1354       arg3 += (a2 >> 2);
1355       a2 %= 4;
1356     }
1357   }
1358
1359   else if ((!((arg1) >= 1280) && !(!((arg1) >= 1280) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1))) && (!((arg3) >= 1280) && ((arg3) >= 512))) {
1360     if (!(((rom_get_field0 (arg1) & #x80) == #x80) && ((rom_get_field2 (arg1) & #xe0) == #x60)) || !(((ram_get_field0 (arg3) & #x80) == #x80) && ((ram_get_field2 (arg3) & #xe0) == #x60)))
1361       halt_with_error();
1362     if ((rom_get_car (arg1) < (a1 + a3)) || (a1 < 0) ||
1363  (ram_get_car (arg3) < (a2 + a3)) || (a2 < 0))
1364       halt_with_error();
1365
1366     arg1 = rom_get_cdr (arg1);
1367     while (a1--)
1368       arg1 = rom_get_cdr (arg1);
1369
1370     arg3 = ram_get_cdr (arg3);
1371     arg3 += (a2 >> 2);
1372     a2 %= 4;
1373
1374     while (a3--) {
1375       ram_set_fieldn (arg3, a2, decode_int (rom_get_car (arg1)));
1376
1377       arg1 = rom_get_cdr (arg1);
1378       a2++;
1379       arg3 += (a2 >> 2);
1380       a2 %= 4;
1381     }
1382   }
1383   else
1384     halt_with_error();
1385
1386   arg1 = 0;
1387   arg2 = 0;
1388   arg3 = 0;
1389   arg4 = 0;
1390   arg5 = 0;
1391 }
1392
1393
1394
1395
1396
1397 void prim_eqp () {
1398   arg1 = ((arg1 == arg2));
1399   arg2 = 0;
1400 }
1401
1402 void prim_not () {
1403   arg1 = ((arg1 == 0));
1404 }
1405
1406 void prim_symbolp () {
1407   if ((!((arg1) >= 1280) && ((arg1) >= 512)))
1408     arg1 = (((((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == #x20))));
1409   else if ((!((arg1) >= 1280) && !(!((arg1) >= 1280) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1))))
1410     arg1 = (((((rom_get_field0 (arg1) & #x80) == #x80) && ((rom_get_field2 (arg1) & #xe0) == #x20))));
1411   else
1412     arg1 = 0;
1413 }
1414
1415 void prim_stringp () {
1416   if ((!((arg1) >= 1280) && ((arg1) >= 512)))
1417     arg1 = (((((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == #x40))));
1418   else if ((!((arg1) >= 1280) && !(!((arg1) >= 1280) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1))))
1419     arg1 = (((((rom_get_field0 (arg1) & #x80) == #x80) && ((rom_get_field2 (arg1) & #xe0) == #x40))));
1420   else
1421     arg1 = 0;
1422 }
1423
1424 void prim_string2list () {
1425   if ((!((arg1) >= 1280) && ((arg1) >= 512))) {
1426     if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == #x40)))
1427       halt_with_error();
1428
1429     arg1 = ram_get_car (arg1);
1430   }
1431   else if ((!((arg1) >= 1280) && !(!((arg1) >= 1280) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1)))) {
1432     if (!(((rom_get_field0 (arg1) & #x80) == #x80) && ((rom_get_field2 (arg1) & #xe0) == #x40)))
1433       halt_with_error();
1434
1435     arg1 = rom_get_car (arg1);
1436     }
1437   else
1438     halt_with_error();
1439 }
1440
1441 void prim_list2string () {
1442   arg1 = alloc_ram_cell_init (#x80 | ((arg1 & #x1f00) >> 8),
1443          arg1 & #xff,         #x40,
1444          0);
1445 }
1446
1447 void prim_booleanp () {
1448   arg1 = ((arg1 < 2));
1449 }
1450
1451
1452
1453
1454
1455 void prim_print () {
1456
1457
1458
1459
1460   arg1 = 0;
1461 }
1462
1463 int32 read_clock () {
1464   int32 now = 0;
1465
1466
1467   /* now = from_now( 0 ); */
1468   return now;
1469 }
1470
1471 void prim_clock () {
1472   arg1 = encode_int (read_clock ());
1473 }
1474
1475 void prim_motor () {
1476   decode_2_int_args ();
1477
1478   if (a1 < 1 || a1 > 2 || a2 < -100 || a2 > 100)
1479     halt_with_error();
1480
1481
1482   /*   MOTOR_set( a1, a2 ); */
1483
1484
1485
1486
1487
1488
1489
1490   arg1 = 0;
1491   arg2 = 0;
1492 }
1493
1494
1495 void prim_led () {
1496   decode_2_int_args ();
1497   a3 = decode_int (arg3);
1498
1499   if (a1 < 1 || a1 > 3 || a2 < 0 || a3 < 0)
1500     halt_with_error();
1501
1502
1503 /*   LED_set( a1, a2, a3 ); */
1504
1505
1506
1507
1508
1509
1510
1511   arg1 = 0;
1512   arg2 = 0;
1513   arg3 = 0;
1514 }
1515
1516
1517 void prim_led2_color () {
1518   a1 = decode_int (arg1);
1519
1520   if (a1 < 0 || a1 > 1)
1521     halt_with_error();
1522
1523
1524 /*   LED2_color_set( a1 ); */
1525
1526
1527
1528
1529
1530
1531
1532   arg1 = 0;
1533 }
1534
1535
1536 void prim_getchar_wait () {
1537   decode_2_int_args();
1538   a1 = read_clock () + a1;
1539
1540   if (a1 < 0 || a2 < 1 || a2 > 3)
1541     halt_with_error();
1542
1543
1544   arg1 = 0;
1545 /*   { */
1546 /*     serial_port_set ports; */
1547 /*     ports = serial_rx_wait_with_timeout( a2, a1 ); */
1548 /*     if (ports != 0) */
1549 /*       arg1 = encode_int (serial_rx_read( ports )); */
1550 /*   } */
1551 }
1552
1553
1554 void prim_putchar () {
1555   decode_2_int_args ();
1556
1557   if (a1 < 0 || a1 > 255 || a2 < 1 || a2 > 3)
1558     halt_with_error();
1559
1560
1561 /*   serial_tx_write( a2, a1 ); */
1562
1563
1564
1565
1566
1567
1568
1569   arg1 = 0;
1570   arg2 = 0;
1571 }
1572
1573
1574 void prim_beep () {
1575   decode_2_int_args ();
1576
1577   if (a1 < 1 || a1 > 255 || a2 < 0)
1578     halt_with_error();
1579
1580
1581 /*   beep( a1, from_now( a2 ) ); */
1582
1583
1584
1585
1586
1587
1588
1589   arg1 = 0;
1590   arg2 = 0;
1591 }
1592
1593
1594 void prim_adc () {
1595   int16 x;
1596
1597   a1 = decode_int (arg1);
1598
1599   if (a1 < 1 || a1 > 3)
1600     halt_with_error();
1601
1602
1603 /*   x = adc( a1 ); */
1604   arg1 = encode_int (x);
1605 }
1606
1607 void prim_sernum () {
1608   int16 x;
1609
1610
1611 /*   x = serial_num (); */
1612
1613
1614
1615
1616
1617
1618   arg1 = encode_int (x);
1619 }
1620
1621
1622
1623
1624
1625 void prim_network_init () {
1626
1627
1628
1629
1630
1631 }
1632
1633 void prim_network_cleanup () {
1634
1635
1636
1637 }
1638
1639 void prim_receive_packet_to_u8vector () {
1640
1641   if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == #x60)))
1642     halt_with_error();
1643 }
1644
1645 void prim_send_packet_from_u8vector () {
1646
1647
1648
1649   if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == #x60)))
1650     halt_with_error();
1651
1652   a2 = decode_int (arg2);
1653   a1 = 0;
1654
1655
1656   if (ram_get_car (arg1) < a2)
1657     halt_with_error();
1658
1659   arg1 = ram_get_cdr (arg1);
1660   arg2 = 0;
1661 }
1662
1663 /* void push_arg1 (); */
1664 /* int16 pop (); */
1665 /* void pop_procedure (); */
1666 /* void handle_arity_and_rest_param (); */
1667 /* void build_env (); */
1668 /* void save_cont (); */
1669 /* void interpreter (); */
1670
1671 void push_arg1 () {
1672   env = cons (arg1, env);
1673   arg1 = 0;
1674 }
1675
1676 int16 pop () {
1677   int16 o = ram_get_car (env);
1678   env = ram_get_cdr (env);
1679   return o;
1680 }
1681
1682 void pop_procedure () {
1683   arg1 = pop();
1684
1685   if ((!((arg1) >= 1280) && ((arg1) >= 512))) {
1686     if (!((ram_get_field0 (arg1) & #xc0) == #x40))
1687       halt_with_error();
1688
1689     entry = ram_get_entry (arg1) + #x8000;
1690   }
1691   else if ((!((arg1) >= 1280) && !(!((arg1) >= 1280) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1)))) {
1692     if (!((rom_get_field0 (arg1) & #xc0) == #x40))
1693       halt_with_error();
1694
1695     entry = rom_get_entry (arg1) + #x8000;
1696   }
1697   else
1698     halt_with_error();
1699 }
1700
1701 void handle_arity_and_rest_param () {
1702   int8 np;
1703
1704   np = rom_get (entry++);
1705
1706   if ((np & #x80) == 0) {
1707     if (na != np)
1708       halt_with_error();
1709   }
1710   else {
1711     np = ~np;
1712
1713     if (na < np)
1714       halt_with_error();
1715
1716     arg3 = 2;
1717
1718     while (na > np) {
1719       arg4 = pop();
1720
1721       arg3 = cons (arg4, arg3);
1722       arg4 = 0;
1723
1724       na--;
1725     }
1726
1727     arg1 = cons (arg3, arg1);
1728     arg3 = 0;
1729   }
1730 }
1731
1732 void build_env () {
1733   while (na != 0) {
1734     arg3 = pop();
1735
1736     arg1 = cons (arg3, arg1);
1737
1738     na--;
1739   }
1740
1741   arg3 = 0;
1742 }
1743
1744 void save_cont () {
1745
1746   arg3 = alloc_ram_cell_init (#x40 | (pc >> 11),
1747          (pc >> 3) & #xff,
1748          ((pc & #x0007) << 5) | (env >> 8),
1749          env & #xff);
1750   cont = alloc_ram_cell_init (#x80 | (cont >> 8),
1751                               cont & #xff,         #x80 | (arg3 >> 8),
1752                               arg3 & #xff);
1753   arg3 = 0;
1754 }
1755
1756 void init_ram_heap () {
1757   int8 i;
1758   int16 o = 1279;
1759
1760   free_list = 0;
1761
1762   int16 tmp = (512 + ((glovars + 1) >> 1)); // TODO optimization TODO parens added to solve a potential shift priority problem
1763   while (o > tmp) {
1764
1765
1766     ram_set_gc_tags (o, (0<<5));
1767     ram_set_car (o, free_list);
1768     free_list = o;
1769     o--;
1770   }
1771
1772   free_list_vec = 1280;
1773   ram_set_car (free_list_vec, 0);
1774
1775
1776
1777   ram_set_cdr (free_list_vec, ((2047 - 1280 + 1)*4) >> 2);
1778
1779   for (i=0; i<glovars; i++)
1780     set_global (i, 0);
1781
1782   arg1 = 0;
1783   arg2 = 0;
1784   arg3 = 0;
1785   arg4 = 0;
1786   cont = 0;
1787   env = 2;
1788 }
1789
1790
1791 void interpreter () {
1792   int16 tmp = rom_get (#x8000 +2);
1793   pc = (#x8000 + 4) + (tmp << 2);
1794
1795   glovars = rom_get (#x8000 +3);
1796
1797   init_ram_heap ();
1798
1799  dispatch: ;
1800   bytecode = rom_get (pc++);
1801   bytecode_hi4 = bytecode & #xf0;
1802   bytecode_lo4 = bytecode & #x0f;
1803   switch (bytecode_hi4 >> 4) {;
1804
1805
1806   case 0: // TODO used to be #x00 >> 4
1807
1808   ;
1809
1810   arg1 = bytecode_lo4;
1811
1812   push_arg1 ();
1813
1814   ; goto dispatch;;
1815
1816
1817   case 1:;;
1818
1819   ;
1820   arg1 = bytecode_lo4+16;
1821
1822   push_arg1 ();
1823
1824   ; goto dispatch;;
1825
1826
1827   case 2:;;
1828
1829   ;
1830
1831   arg1 = env;
1832
1833   while (bytecode_lo4 != 0) {
1834     arg1 = ram_get_cdr (arg1);
1835     bytecode_lo4--;
1836   }
1837
1838   arg1 = ram_get_car (arg1);
1839
1840   push_arg1 ();
1841
1842   ; goto dispatch;;
1843
1844
1845   case 3:;;
1846
1847   ;
1848
1849   bytecode_lo4 += 16;
1850
1851   arg1 = env;
1852
1853   while (bytecode_lo4 != 0) {
1854     arg1 = ram_get_cdr (arg1);
1855     bytecode_lo4--;
1856   }
1857
1858   arg1 = ram_get_car (arg1);
1859
1860   push_arg1 ();
1861
1862   ; goto dispatch;;
1863
1864
1865   case 4:;;
1866
1867   ;
1868
1869   arg1 = get_global (bytecode_lo4);
1870
1871   push_arg1 ();
1872
1873   ; goto dispatch;;
1874
1875
1876   case 5:;;
1877
1878   ;
1879
1880   set_global (bytecode_lo4, pop());
1881
1882   ; goto dispatch;;
1883
1884
1885   case 6:;;
1886
1887   ;
1888
1889   na = bytecode_lo4;
1890
1891   pop_procedure ();
1892   handle_arity_and_rest_param ();
1893   build_env ();
1894   save_cont ();
1895
1896   env = arg1;
1897   pc = entry;
1898
1899   arg1 = 0;
1900
1901   ; goto dispatch;;
1902
1903
1904   case 7:;;
1905
1906   ;
1907
1908   na = bytecode_lo4;
1909
1910   pop_procedure ();
1911   handle_arity_and_rest_param ();
1912   build_env ();
1913
1914   env = arg1;
1915   pc = entry;
1916
1917   arg1 = 0;
1918
1919   ; goto dispatch;;
1920
1921
1922   case 8:;;
1923
1924   switch (bytecode_lo4) {
1925   case 0:
1926     bytecode = rom_get (pc++);
1927     arg2 = bytecode;
1928
1929     bytecode = rom_get (pc++);
1930
1931     ;
1932
1933
1934     entry = (arg2 << 8) + bytecode + #x8000;
1935     arg1 = 2;
1936
1937     na = rom_get (entry++);
1938
1939     build_env ();
1940     save_cont ();
1941
1942     env = arg1;
1943     pc = entry;
1944
1945     arg1 = 0;
1946     arg2 = 0;
1947
1948     break;
1949
1950   case 1:
1951     bytecode = rom_get (pc++);
1952     arg2 = bytecode;
1953
1954     bytecode = rom_get (pc++);
1955
1956     ;
1957
1958
1959     entry = (arg2 << 8) + bytecode + #x8000;
1960     arg1 = 2;
1961
1962     na = rom_get (entry++);
1963
1964     build_env ();
1965
1966     env = arg1;
1967     pc = entry;
1968
1969     arg1 = 0;
1970     arg2 = 0;
1971
1972     break;
1973
1974   case 2:
1975     bytecode = rom_get (pc++);
1976     arg2 = bytecode;
1977
1978     bytecode = rom_get (pc++);
1979
1980     ;
1981
1982
1983     pc = (arg2 << 8) + bytecode + #x8000;
1984
1985     break;
1986
1987   case 3:
1988     bytecode = rom_get (pc++);
1989     arg2 = bytecode;
1990
1991     bytecode = rom_get (pc++);
1992
1993     ;
1994
1995
1996     if (pop() == 0)
1997       pc = (arg2 << 8) + bytecode + #x8000;
1998
1999     break;
2000
2001   case 4:
2002     bytecode = rom_get (pc++);
2003     arg2 = bytecode;
2004
2005     bytecode = rom_get (pc++);
2006
2007     ;
2008
2009     arg3 = pop();
2010
2011     entry = (arg2 << 8) | bytecode;
2012
2013     arg1 = alloc_ram_cell_init (#x40 | (arg2 >> 3),
2014     ((arg2 & #x07) << 5) | (bytecode >> 3),
2015     ((bytecode &#x07) << 5) |((arg3 &#x1f00) >>8),
2016     arg3 & #xff);
2017
2018     push_arg1 ();
2019
2020     arg2 = 0;
2021     arg3 = 0;
2022
2023     break;
2024
2025     /*   case 5: */ // TODO useless, they don't work in the regular PICOBIT
2026 /*     bytecode = rom_get (pc++); */
2027
2028 /*     ; */
2029
2030
2031 /*     entry = pc + bytecode + #x8000; */
2032 /*     arg1 = 2; */
2033
2034 /*     na = rom_get (entry++); */
2035
2036 /*     build_env (); */
2037 /*     save_cont (); */
2038
2039 /*     env = arg1; */
2040 /*     pc = entry; */
2041
2042 /*     arg1 = 0; */
2043
2044 /*     break; */
2045
2046 /*   case 6: */
2047 /*     bytecode = rom_get (pc++); */
2048
2049 /*     ; */
2050
2051
2052 /*     entry = pc + bytecode + #x8000; */
2053 /*     arg1 = 2; */
2054
2055 /*     na = rom_get (entry++); */
2056
2057 /*     build_env (); */
2058
2059 /*     env = arg1; */
2060 /*     pc = entry; */
2061
2062 /*     arg1 = 0; */
2063
2064 /*     break; */
2065
2066 /*   case 7: */
2067 /*     bytecode = rom_get (pc++); */
2068
2069 /*     ; */
2070
2071 /*     pc = pc + bytecode + #x8000; */
2072
2073 /*     break; */
2074
2075 /*   case 8: */
2076 /*     bytecode = rom_get (pc++); */
2077
2078 /*     ; */
2079
2080
2081 /*     if (pop() == 0) */
2082 /*       pc = pc + bytecode + #x8000; */
2083
2084 /*     break; */
2085
2086 /*   case 9: */
2087 /*     bytecode = rom_get (pc++); */
2088
2089 /*     ; */
2090
2091 /*     arg3 = pop(); */
2092
2093 /*     entry = pc + bytecode; */
2094
2095 /*     arg1 = alloc_ram_cell_init (#x40 | (arg2 >> 3), */
2096 /*     ((arg2 & #x07) << 5) | (bytecode >> 3), */
2097 /*     ((bytecode &#x07) <<5) |((arg3 &#x1f00) >>8), */
2098 /*     arg3 & #xff); */
2099
2100 /*     push_arg1 (); */
2101
2102 /*     arg3 = 0; */
2103
2104 /*     break; */
2105   case 14:
2106     bytecode = rom_get (pc++);
2107
2108     ;
2109
2110     arg1 = get_global (bytecode);
2111
2112     push_arg1 ();
2113
2114     break;
2115
2116   case 15:
2117     bytecode = rom_get (pc++);
2118
2119     ;
2120
2121     set_global (bytecode, pop());
2122
2123     break;
2124   }
2125
2126   ; goto dispatch;;
2127
2128
2129   case 9:;;
2130
2131
2132
2133   bytecode = rom_get (pc++);
2134
2135   ;
2136
2137   arg1 = (bytecode_lo4 << 8) | bytecode;
2138   push_arg1 ();
2139
2140   ; goto dispatch;;
2141
2142
2143   case 10:;;
2144
2145   ; goto dispatch;;
2146
2147
2148   case 11:;;
2149
2150   ; goto dispatch;;
2151
2152
2153   case 12:;;
2154
2155   ;
2156
2157   switch (bytecode_lo4) {
2158   case 0:
2159     arg1 = pop(); prim_numberp (); push_arg1 (); break;
2160   case 1:
2161     arg2 = pop(); arg1 = pop(); prim_add (); push_arg1 (); break;
2162   case 2:
2163     arg2 = pop(); arg1 = pop(); prim_sub (); push_arg1 (); break;
2164   case 3:
2165     arg2 = pop(); arg1 = pop(); prim_mul (); push_arg1 (); break;
2166   case 4:
2167     arg2 = pop(); arg1 = pop(); prim_div (); push_arg1 (); break;
2168   case 5:
2169     arg2 = pop(); arg1 = pop(); prim_rem (); push_arg1 (); break;
2170   case 6:
2171     arg1 = pop(); prim_neg (); push_arg1 (); break;
2172   case 7:
2173     arg2 = pop(); arg1 = pop(); prim_eq (); push_arg1 (); break;
2174   case 8:
2175     arg2 = pop(); arg1 = pop(); prim_lt (); push_arg1 (); break;
2176   case 9:
2177     arg2 = pop(); arg1 = pop(); prim_leq (); push_arg1 (); break;
2178   case 10:
2179     arg2 = pop(); arg1 = pop(); prim_gt (); push_arg1 (); break;
2180   case 11:
2181     arg2 = pop(); arg1 = pop(); prim_geq (); push_arg1 (); break;
2182   case 12:
2183     arg1 = pop(); prim_pairp (); push_arg1 (); break;
2184   case 13:
2185     arg2 = pop(); arg1 = pop(); prim_cons (); push_arg1 (); break;
2186   case 14:
2187     arg1 = pop(); prim_car (); push_arg1 (); break;
2188   case 15:
2189     arg1 = pop(); prim_cdr (); push_arg1 (); break;
2190   }
2191
2192   ; goto dispatch;;
2193
2194
2195   case 13:;;
2196
2197   ;
2198
2199   switch (bytecode_lo4) {
2200   case 0:
2201     arg2 = pop(); arg1 = pop(); prim_set_car (); break;
2202   case 1:
2203     arg2 = pop(); arg1 = pop(); prim_set_cdr (); break;
2204   case 2:
2205     arg1 = pop(); prim_nullp (); push_arg1 (); break;
2206   case 3:
2207     arg2 = pop(); arg1 = pop(); prim_eqp (); push_arg1 (); break;
2208   case 4:
2209     arg1 = pop(); prim_not (); push_arg1 (); break;
2210   case 5:
2211
2212     arg1 = cont;
2213     push_arg1 ();
2214     break;
2215   case 6:
2216
2217
2218     arg1 = pop();
2219     cont = pop();
2220
2221     push_arg1 ();
2222
2223     na = 0;
2224
2225     pop_procedure ();
2226     handle_arity_and_rest_param ();
2227     build_env ();
2228
2229     env = arg1;
2230     pc = entry;
2231
2232     arg1 = 0;
2233
2234     break;
2235   case 7:
2236
2237
2238     arg1 = pop();
2239     cont = pop();
2240
2241     arg2 = ram_get_cdr (cont);
2242
2243     pc = ram_get_entry (arg2);
2244
2245     env = ram_get_cdr (arg2);
2246     cont = ram_get_car (cont);
2247
2248     push_arg1 ();
2249     arg2 = 0;
2250
2251     break;
2252   case 8:
2253
2254     return;
2255   case 9:
2256
2257     arg1 = pop(); prim_symbolp (); push_arg1 (); break;
2258   case 10:
2259
2260     arg1 = pop(); prim_stringp (); push_arg1 (); break;
2261   case 11:
2262
2263     arg1 = pop(); prim_string2list (); push_arg1 (); break;
2264   case 12:
2265
2266     arg1 = pop(); prim_list2string (); push_arg1 (); break;
2267   case 13:
2268
2269     arg2 = pop(); arg1 = pop(); prim_make_u8vector (); push_arg1 (); break;
2270   case 14:
2271
2272     arg2 = pop(); arg1 = pop(); prim_u8vector_ref (); push_arg1 (); break;
2273   case 15:
2274
2275     arg3 = pop(); arg2 = pop(); arg1 = pop(); prim_u8vector_set (); break;
2276   }
2277
2278   ; goto dispatch;;
2279
2280
2281   case 14:;;
2282
2283   ;
2284
2285   switch (bytecode_lo4) {
2286   case 0:
2287
2288     arg1 = pop();
2289     prim_print ();
2290     break;
2291   case 1:
2292
2293     prim_clock (); push_arg1 (); break;
2294   case 2:
2295
2296     arg2 = pop(); arg1 = pop(); prim_motor (); break;
2297   case 3:
2298
2299     arg3 = pop(); arg2 = pop(); arg1 = pop(); prim_led (); ;break;
2300   case 4:
2301
2302     arg1 = pop(); prim_led2_color (); break;
2303   case 5:
2304
2305     arg2 = pop(); arg1 = pop(); prim_getchar_wait (); push_arg1 (); break;
2306   case 6:
2307
2308     arg2 = pop(); arg1 = pop(); prim_putchar (); break;
2309   case 7:
2310
2311     arg2 = pop(); arg1 = pop(); prim_beep (); break;
2312   case 8:
2313
2314     arg1 = pop(); prim_adc (); push_arg1 (); break;
2315   case 9:
2316
2317     arg1 = pop(); prim_u8vectorp (); push_arg1 (); break;
2318   case 10:
2319
2320     prim_sernum (); push_arg1 (); break;
2321   case 11:
2322
2323     arg1 = pop(); prim_u8vector_length (); push_arg1 (); break;
2324   case 12:
2325
2326     arg5 = pop(); arg4 = pop(); arg3 = pop(); arg2 = pop(); arg1 = pop();
2327     prim_u8vector_copy (); break;
2328     break;
2329   case 13:
2330
2331     arg1 = pop();
2332     pop();
2333     push_arg1 ();
2334     break;
2335   case 14:
2336
2337     pop();
2338     break;
2339   case 15:
2340
2341     arg1 = pop();
2342     arg2 = ram_get_cdr (cont);
2343     pc = ram_get_entry (arg2);
2344     env = ram_get_cdr (arg2);
2345     cont = ram_get_car (cont);
2346     push_arg1 ();
2347     arg2 = 0;
2348     break;
2349   }
2350
2351   ; goto dispatch;;
2352
2353
2354
2355   case 15:;;
2356
2357   ;
2358
2359   switch (bytecode_lo4) {
2360   case 0:
2361
2362     arg1 = pop(); prim_booleanp (); push_arg1 (); break;
2363   case 1:
2364
2365     prim_network_init (); break;
2366   case 2:
2367
2368     prim_network_cleanup (); break;
2369   case 3:
2370
2371     arg1 = pop(); prim_receive_packet_to_u8vector (); push_arg1 (); break;
2372   case 4:
2373
2374     arg2 = pop(); arg1 = pop(); prim_send_packet_from_u8vector ();
2375     push_arg1 (); break;
2376   case 5:
2377     arg2 = pop(); arg1 = pop(); prim_ior (); push_arg1 (); break;
2378     break;
2379   case 6:
2380     arg2 = pop(); arg1 = pop(); prim_xor (); push_arg1 (); break;
2381     break;
2382   }
2383
2384   ; goto dispatch;;
2385
2386
2387
2388   };
2389 }
2390
2391 interpreter();