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