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; */ // 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);
  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 { 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) >= 4096) && ((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) >= 4096) && ((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) >= 4096) && ((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 = 4095;
 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) >= 4096) && ((x) >= 512)))
 472     return ram_get_car (x);
 473   else if ((!((x) >= 4096) && !(!((x) >= 4096) && ((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) >= 4096) && ((x) >= 512)))
 486     return (t << 8) + ram_get_field3 (x);
 487   else if ((!((x) >= 4096) && !(!((x) >= 4096) && ((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) >= 4096) && ((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) >= 4096) && !(!((o) >= 4096) && ((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) {
 579
 580
 581   int8 result = 0;
 582   int16 xlo;
 583   int16 ylo;
 584
 585   for (;;) {
 586     if (((x) == ((0 + (3 - -1)))) || ((x) == (((0 + (3 - -1))-1)))) {
 587       if (!((x) == (y)))
 588  { if (negp (y)) result = 1; else result = -1; }
 589       break;
 590     }
 591
 592     if (((y) == ((0 + (3 - -1)))) || ((y) == (((0 + (3 - -1))-1)))) {
 593       if (negp (x)) result = -1; else result = 1;
 594       break;
 595     }
 596
 597     xlo = integer_lo (x);
 598     ylo = integer_lo (y);
 599     x = integer_hi (x);
 600     y = integer_hi (y);
 601     if (xlo != ylo)
 602       { if (xlo < ylo) result = -1; else result = 1; }
 603   }
 604   return result;
 605 }
 606
 607 int16 integer_length (int16 x) {
 608
 609
 610
 611   int16 result = 0;
 612   int16 next;
 613   int16 d;
 614
 615   while (!(((next = integer_hi (x))) == ((0 + (3 - -1))))) {
 616     result += 16;
 617     x = next;
 618   }
 619
 620   d = integer_lo (x);
 621
 622   while (d > 0) {
 623     result++;
 624     d >>= 1;
 625   }
 626
 627   return result;
 628 }
 629
 630 int16 shr (int16 x) {
 631
 632
 633   int16 result = 0;
 634   int16 d;
 635
 636   for (;;) {
 637     if (((x) == ((0 + (3 - -1)))) || ((x) == (((0 + (3 - -1))-1)))) {
 638       result = norm (result, x);
 639       break;
 640     }
 641
 642     d = integer_lo (x);
 643     x = integer_hi (x);
 644     int tmp = 1;
 645     result = make_integer ((d >> 1) |
 646                            ((integer_lo (x) & 1) ? (tmp<<15) : 0), // TODO only shifting by literals is permitted, so had to change the 16 -1 to 15
 647                            result);
 648   }
 649
 650   return result;
 651 }
 652
 653 int16 negative_carry (int16 carry) {
 654   if (carry)
 655     return ((0 + (3 - -1))-1);
 656   else
 657     return (0 + (3 - -1));
 658 }
 659
 660 int16 shl (int16 x) {
 661
 662
 663   int16 negc = (0 + (3 - -1));
 664   int16 temp;
 665   int16 result = 0;
 666   int16 d;
 667
 668   for (;;) {
 669     if (((x) == (negc))) {
 670       result = norm (result, x);
 671       break;
 672     }
 673
 674     d = integer_lo (x);
 675     x = integer_hi (x);
 676     temp = negc;
 677     int tmp = 1;
 678     negc = negative_carry (d & (tmp<<15));
 679     result = make_integer ((d << 1) | ((temp) == (3)), result); // TODO was ((0 + (3 - -1))-1)
 680   }
 681
 682   return result;
 683 }
 684
 685 int16 shift_left (int16 x, int16 n) {
 686
 687
 688   if (((x) == ((0 + (3 - -1)))))
 689     return x;
 690
 691   while (n & (16 -1)) {
 692     x = shl (x);
 693     n--;
 694   }
 695
 696   while (n > 0) {
 697     x = make_integer (0, x);
 698     n -= 16;
 699   }
 700
 701   return x;
 702 }
 703
 704 int16 add (int16 x, int16 y) {
 705
 706
 707   int16 negc = (0 + (3 - -1));
 708   int16 result = 0;
 709   int16 dx;
 710   int16 dy;
 711
 712   for (;;) {
 713     if (((x) == (negc))) {
 714       result = norm (result, y);
 715       break;
 716     }
 717
 718     if (((y) == (negc))) {
 719       result = norm (result, x);
 720       break;
 721     }
 722
 723     dx = integer_lo (x);
 724     dy = integer_lo (y);
 725     dx = dx + dy;
 726
 727     if (((negc) == ((0 + (3 - -1)))))
 728       negc = negative_carry (dx < dy);
 729     else {
 730       dx++;
 731       negc = negative_carry (dx <= dy);
 732     }
 733
 734     x = integer_hi (x);
 735     y = integer_hi (y);
 736
 737     result = make_integer (dx, result);
 738   }
 739
 740   return result;
 741 }
 742
 743 int16 invert (int16 x) {
 744   if (((x) == ((0 + (3 - -1)))))
 745     return ((0 + (3 - -1))-1);
 746   else
 747     return (0 + (3 - -1));
 748 }
 749
 750 int16 sub (int16 x, int16 y) {
 751
 752   int16 negc = ((0 + (3 - -1))-1);
 753   int16 result = 0;
 754   int16 dx;
 755   int16 dy;
 756
 757   for (;;) {
 758     if (((x) == (negc)) && (((y) == ((0 + (3 - -1)))) || ((y) == (((0 + (3 - -1))-1))))) {
 759       result = norm (result, invert (y));
 760       break;
 761     }
 762
 763     if (((y) == (invert (negc)))) {
 764       result = norm (result, x);
 765       break;
 766     }
 767
 768     dx = integer_lo (x);
 769     dy = ~integer_lo (y);
 770     dx = dx + dy;
 771
 772     if (((negc) == ((0 + (3 - -1)))))
 773       negc = negative_carry (dx < dy);
 774     else {
 775       dx++;
 776       negc = negative_carry (dx <= dy);
 777     }
 778
 779     x = integer_hi (x);
 780     y = integer_hi (y);
 781
 782     result = make_integer (dx, result);
 783   }
 784
 785   return result;
 786 }
 787
 788 int16 neg (int16 x) {
 789
 790
 791   return sub ((0 + (3 - -1)), x);
 792 }
 793
 794 int16 scale (int16 n, int16 x) {
 795
 796
 797   int16 result;
 798   int16 carry;
 799   int32 m;
 800
 801   if ((n == 0) || ((x) == ((0 + (3 - -1)))))
 802     return (0 + (3 - -1));
 803
 804   if (n == 1)
 805     return x;
 806
 807   result = 0;
 808   carry = 0;
 809
 810   for (;;) {
 811     if (((x) == ((0 + (3 - -1))))){
 812       if (carry <= 255)
 813         result = norm (result, (carry + (3 - -1)));
 814       else
 815         result = norm (result, make_integer (carry, (0 + (3 - -1))));
 816       break;
 817     }
 818
 819     if (((x) == (((0 + (3 - -1))-1)))) {
 820       carry = carry - n;
 821       int tmp = 1;
 822       if (carry >= ((tmp<<16) + -1))
 823         result = norm (result, ((carry & #xff) + (3 - -1)));
 824       else
 825         result = norm (result, make_integer (carry, ((0 + (3 - -1))-1)));
 826       break;
 827     }
 828
 829     int32 tmp1 = integer_lo (x);
 830     m = tmp1 * n + carry;
 831
 832     x = integer_hi (x);
 833     carry = m >> 16;
 834     int16 tmp2 = m;
 835     result = make_integer (tmp2, result);
 836   }
 837
 838   return result;
 839 }
 840
 841 int16 mulnonneg (int16 x, int16 y) {
 842
 843
 844
 845   int16 result = 0;
 846   int16 s = scale (integer_lo (x), y);
 847
 848   for (;;) {
 849     result = make_integer (integer_lo (s), result);
 850     s = integer_hi (s);
 851     x = integer_hi (x);
 852
 853     if (((x) == ((0 + (3 - -1)))))
 854       break;
 855
 856     s = add (s, scale (integer_lo (x), y));
 857   }
 858
 859   return norm (result, s);
 860 }
 861
 862
 863 int16 divnonneg (int16 x, int16 y) {
 864
 865
 866
 867   int16 result = (0 + (3 - -1));
 868   int16 lx = integer_length (x);
 869   int16 ly = integer_length (y);
 870
 871   if (lx >= ly) {
 872     lx = lx - ly;
 873
 874     y = shift_left (y, lx);
 875
 876     do {
 877       result = shl (result);
 878       if (cmp (x, y) >= 0) {
 879         x = sub (x, y);
 880         result = add (((0 + (3 - -1))+1), result);
 881       }
 882       y = shr (y);
 883     } while (lx-- != 0);
 884   }
 885
 886   return result;
 887 }
 888
 889 int16 bitwise_ior (int16 x, int16 y) {
 890
 891
 892   int16 result = 0;
 893
 894   for (;;){
 895     if (((x) == ((0 + (3 - -1)))))
 896       return norm(result, y);
 897     if (((x) == (((0 + (3 - -1))-1))))
 898       return norm(result, x);
 899     result = make_integer(integer_lo(x) | integer_lo(y),
 900                           result);
 901     x = integer_hi(x);
 902     y = integer_hi(y);
 903   }
 904 }
 905
 906 int16 bitwise_xor (int16 x, int16 y) {
 907
 908
 909   int16 result = 0;
 910
 911   for (;;){
 912     if (((x) == ((0 + (3 - -1)))))
 913       return norm(result, y);
 914     if (((x) == (((0 + (3 - -1))-1))))
 915       return norm(result, x);
 916     result = make_integer(integer_lo(x) ^ integer_lo(y),
 917      result);
 918     x = integer_hi(x);
 919     y = integer_hi(y);
 920   }
 921 }
 922
 923
 924
 925 int16 encode_int (int32 n) {
 926   if (n >= -1 && n <= 255) {
 927     int16 tmp = n;
 928     return (tmp + (3 - -1));
 929   }
 930
 931   return alloc_ram_cell_init (0, (0 + (3 - -1)), n >> 8, n);
 932 }
 933 void decode_2_int_args () {
 934   a1 = decode_int (arg1);
 935   a2 = decode_int (arg2);
 936 }
 937
 938
 939
 940
 941
 942 void prim_numberp () {
 943   if (arg1 >= 3
 944       && arg1 <= (3 + (255 - -1)))
 945     arg1 = 1;
 946   else {
 947     if ((!((arg1) >= 4096) && ((arg1) >= 512))){
 948       arg1 = (ram_get_field0 (arg1) & #xc0) == 0;
 949     }
 950     else if ((!((arg1) >= 4096) && !(!((arg1) >= 4096) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1))))
 951       arg1 = (rom_get_field0 (arg1) & #xc0) == 0;
 952     else
 953       arg1 = 0;
 954   }
 955 }
 956 void prim_add () {
 957
 958   arg1 = add (arg1, arg2);
 959
 960
 961
 962
 963   arg2 = 0;
 964 }
 965
 966 void prim_sub () {
 967
 968   arg1 = sub (arg1, arg2);
 969
 970
 971
 972
 973   arg2 = 0;
 974 }
 975
 976 void prim_mul () {
 977
 978   a1 = negp (arg1);
 979   a2 = negp (arg2);
 980   arg1 = mulnonneg (a1 ? neg(arg1) : arg1,
 981       a2 ? neg(arg2) : arg2);
 982   if (a1 + a2 == 1)
 983     arg1 = neg(arg1);
 984
 985
 986
 987
 988   arg2 = 0;
 989 }
 990
 991 void prim_div () {
 992
 993   if (((arg2) == (((0) + (3 - -1)))))
 994     halt_with_error();
 995   a1 = negp (arg1);
 996   a2 = negp (arg2);
 997   arg1 = divnonneg (a1 ? neg(arg1) : arg1,
 998       a2 ? neg(arg2) : arg2);
 999   if (a1 + a2 == 1)
1000     arg1 = neg(arg1);
1001
1002
1003
1004
1005
1006
1007   arg2 = 0;
1008 }
1009
1010 void prim_rem () {
1011
1012   if (((arg2) == (((0) + (3 - -1)))))
1013     halt_with_error();
1014   if (negp(arg1) || negp(arg2))
1015     halt_with_error();
1016
1017
1018   arg3 = divnonneg (arg1, arg2);
1019   arg4 = mulnonneg (arg2, arg3);
1020   arg1 = sub(arg1, arg4 );
1021   arg3 = 0;
1022   arg4 = 0;
1023
1024
1025
1026
1027
1028
1029   arg2 = 0;
1030 }
1031
1032 void prim_neg () {
1033
1034   arg1 = neg (arg1);
1035
1036
1037
1038
1039 }
1040
1041 void prim_eq () {
1042
1043   arg1 = ((cmp (arg1, arg2) == 0));
1044
1045
1046
1047
1048   arg2 = 0;
1049 }
1050
1051 void prim_lt () {
1052
1053   arg1 = ((cmp (arg1, arg2) < 0));
1054
1055
1056
1057
1058   arg2 = 0;
1059 }
1060
1061 void prim_gt () {
1062
1063   arg1 = ((cmp (arg1, arg2) > 0));
1064
1065
1066
1067
1068   arg2 = 0;
1069 }
1070
1071 void prim_leq () {
1072
1073   arg1 = ((cmp (arg1, arg2) <= 0));
1074
1075
1076
1077
1078   arg2 = 0;
1079
1080 }
1081
1082 void prim_geq () {
1083
1084   arg1 = ((cmp (arg1, arg2) >= 0));
1085
1086
1087
1088
1089   arg2 = 0;
1090 }
1091
1092 void prim_ior () {
1093
1094   arg1 = bitwise_ior(arg1, arg2);
1095
1096
1097
1098
1099   arg2 = 0;
1100 }
1101
1102 void prim_xor () {
1103
1104   arg1 = bitwise_xor(arg1, arg2);
1105
1106
1107
1108
1109   arg2 = 0;
1110 }
1111
1112
1113
1114
1115
1116
1117
1118 void prim_pairp () {
1119   if ((!((arg1) >= 4096) && ((arg1) >= 512)))
1120     arg1 = (((((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == 0))));
1121   else if ((!((arg1) >= 4096) && !(!((arg1) >= 4096) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1))))
1122     arg1 = (((((rom_get_field0 (arg1) & #x80) == #x80) && ((rom_get_field2 (arg1) & #xe0) == 0))));
1123   else
1124     arg1 = 0;
1125 }
1126
1127 int16 cons (int16 car, int16 cdr) {
1128   return alloc_ram_cell_init (#x80 | (car >> 8),
1129          car & #xff,
1130          0 | (cdr >> 8),
1131          cdr & #xff);
1132 }
1133
1134 void prim_cons () {
1135   arg1 = cons (arg1, arg2);
1136   arg2 = 0;
1137 }
1138
1139 void prim_car () {
1140   if ((!((arg1) >= 4096) && ((arg1) >= 512))) {
1141     if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == 0)))
1142       halt_with_error();
1143     arg1 = ram_get_car (arg1);
1144   }
1145   else if ((!((arg1) >= 4096) && !(!((arg1) >= 4096) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1)))) {
1146     if (!(((rom_get_field0 (arg1) & #x80) == #x80) && ((rom_get_field2 (arg1) & #xe0) == 0)))
1147       halt_with_error();
1148     arg1 = rom_get_car (arg1);
1149   }
1150   else
1151     halt_with_error();
1152 }
1153
1154 void prim_cdr () {
1155   if ((!((arg1) >= 4096) && ((arg1) >= 512))) {
1156     if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == 0)))
1157       halt_with_error();
1158     arg1 = ram_get_cdr (arg1);
1159   }
1160   else if ((!((arg1) >= 4096) && !(!((arg1) >= 4096) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1)))) {
1161     if (!(((rom_get_field0 (arg1) & #x80) == #x80) && ((rom_get_field2 (arg1) & #xe0) == 0)))
1162       halt_with_error();
1163     arg1 = rom_get_cdr (arg1);
1164   }
1165   else
1166     halt_with_error();
1167 }
1168
1169 void prim_set_car () {
1170   if ((!((arg1) >= 4096) && ((arg1) >= 512))) {
1171     if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == 0)))
1172       halt_with_error();
1173
1174     ram_set_car (arg1, arg2);
1175     arg1 = 0;
1176     arg2 = 0;
1177   }
1178   else
1179     halt_with_error();
1180 }
1181
1182 void prim_set_cdr () {
1183   if ((!((arg1) >= 4096) && ((arg1) >= 512))) {
1184     if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == 0)))
1185       halt_with_error();
1186
1187     ram_set_cdr (arg1, arg2);
1188     arg1 = 0;
1189     arg2 = 0;
1190   }
1191   else
1192     halt_with_error();
1193 }
1194
1195 void prim_nullp () {
1196   arg1 = ((arg1 == 2));
1197 }
1198
1199
1200
1201
1202
1203 void prim_u8vectorp () {
1204   if ((!((arg1) >= 4096) && ((arg1) >= 512)))
1205     arg1 = (((((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == #x60))));
1206   else if ((!((arg1) >= 4096) && !(!((arg1) >= 4096) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1))))
1207     arg1 = (((((rom_get_field0 (arg1) & #x80) == #x80) && ((rom_get_field2 (arg1) & #xe0) == #x60))));
1208   else
1209     arg1 = 0;
1210 }
1211
1212 void prim_make_u8vector () {
1213   decode_2_int_args ();
1214
1215   if (a2 > 255)
1216     halt_with_error();
1217
1218   arg3 = alloc_vec_cell (a1);
1219   arg1 = alloc_ram_cell_init (#x80 | (a1 >> 8),
1220          a1 & #xff,         #x60 | (arg3 >> 8),
1221          arg3 & #xff);
1222
1223   a1 = (a1 + 3) >> 2;
1224   while (a1--) {
1225     ram_set_field0 (arg3, a2);
1226     ram_set_field1 (arg3, a2);
1227     ram_set_field2 (arg3, a2);
1228     ram_set_field3 (arg3, a2);
1229     arg3++;
1230   }
1231 }
1232
1233 void prim_u8vector_ref () {
1234   a2 = decode_int (arg2);
1235
1236   if ((!((arg1) >= 4096) && ((arg1) >= 512))) {
1237     if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == #x60)))
1238       halt_with_error();
1239     if ((ram_get_car (arg1) <= a2) || (a2 < 0))
1240       halt_with_error();
1241     arg1 = ram_get_cdr (arg1);
1242   }
1243   else if ((!((arg1) >= 4096) && !(!((arg1) >= 4096) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1)))) {
1244     if (!(((rom_get_field0 (arg1) & #x80) == #x80) && ((rom_get_field2 (arg1) & #xe0) == #x60)))
1245       halt_with_error();
1246     if ((rom_get_car (arg1) <= a2) || (a2 < 0))
1247       halt_with_error();
1248     arg1 = rom_get_cdr (arg1);
1249   }
1250   else
1251     halt_with_error();
1252
1253   if (((arg1) >= 4096)) {
1254     arg1 += (a2 >> 2);
1255     a2 %= 4;
1256
1257     arg1 = encode_int (ram_get_fieldn (arg1, a2));
1258   }
1259   else {
1260     while (a2--)
1261       arg1 = rom_get_cdr (arg1);
1262
1263
1264     arg1 = rom_get_car (arg1);
1265   }
1266
1267   arg2 = 0;
1268   arg3 = 0;
1269   arg4 = 0;
1270 }
1271
1272 void prim_u8vector_set () {
1273   a2 = decode_int (arg2);
1274   a3 = decode_int (arg3);
1275
1276   if (a3 > 255)
1277     halt_with_error();
1278
1279   if ((!((arg1) >= 4096) && ((arg1) >= 512))) {
1280     if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == #x60)))
1281       halt_with_error();
1282     if ((ram_get_car (arg1) <= a2) || (a2 < 0))
1283       halt_with_error();
1284     arg1 = ram_get_cdr (arg1);
1285   }
1286   else
1287     halt_with_error();
1288
1289   arg1 += (a2 >> 2);
1290   a2 %= 4;
1291
1292   ram_set_fieldn (arg1, a2, a3);
1293
1294   arg1 = 0;
1295   arg2 = 0;
1296   arg3 = 0;
1297 }
1298
1299 void prim_u8vector_length () {
1300   if ((!((arg1) >= 4096) && ((arg1) >= 512))) {
1301     if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == #x60)))
1302       halt_with_error();
1303     arg1 = encode_int (ram_get_car (arg1));
1304   }
1305   else if ((!((arg1) >= 4096) && !(!((arg1) >= 4096) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1)))) {
1306     if (!(((rom_get_field0 (arg1) & #x80) == #x80) && ((rom_get_field2 (arg1) & #xe0) == #x60)))
1307       halt_with_error();
1308     arg1 = encode_int (rom_get_car (arg1));
1309   }
1310   else
1311     halt_with_error();
1312 }
1313
1314 void prim_u8vector_copy () {
1315
1316
1317
1318   a1 = decode_int (arg2);
1319   a2 = decode_int (arg4);
1320   a3 = decode_int (arg5);
1321
1322
1323   if ((!((arg1) >= 4096) && ((arg1) >= 512)) && (!((arg3) >= 4096) && ((arg3) >= 512))) {
1324     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)))
1325       halt_with_error();
1326     if ((ram_get_car (arg1) < (a1 + a3)) || (a1 < 0) ||
1327  (ram_get_car (arg3) < (a2 + a3)) || (a2 < 0))
1328       halt_with_error();
1329
1330
1331     arg1 = ram_get_cdr (arg1);
1332     arg1 += (a1 >> 2);
1333     a1 %= 4;
1334     arg3 = ram_get_cdr (arg3);
1335     arg3 += (a2 >> 2);
1336     a2 %= 4;
1337
1338
1339     while (a3--) {
1340       ram_set_fieldn (arg3, a2, ram_get_fieldn (arg1, a1));
1341
1342       a1++;
1343       arg1 += (a1 >> 2);
1344       a1 %= 4;
1345       a2++;
1346       arg3 += (a2 >> 2);
1347       a2 %= 4;
1348     }
1349   }
1350
1351   else if ((!((arg1) >= 4096) && !(!((arg1) >= 4096) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1))) && (!((arg3) >= 4096) && ((arg3) >= 512))) {
1352     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)))
1353       halt_with_error();
1354     if ((rom_get_car (arg1) < (a1 + a3)) || (a1 < 0) ||
1355  (ram_get_car (arg3) < (a2 + a3)) || (a2 < 0))
1356       halt_with_error();
1357
1358     arg1 = rom_get_cdr (arg1);
1359     while (a1--)
1360       arg1 = rom_get_cdr (arg1);
1361
1362     arg3 = ram_get_cdr (arg3);
1363     arg3 += (a2 >> 2);
1364     a2 %= 4;
1365
1366     while (a3--) {
1367       ram_set_fieldn (arg3, a2, decode_int (rom_get_car (arg1)));
1368
1369       arg1 = rom_get_cdr (arg1);
1370       a2++;
1371       arg3 += (a2 >> 2);
1372       a2 %= 4;
1373     }
1374   }
1375   else
1376     halt_with_error();
1377
1378   arg1 = 0;
1379   arg2 = 0;
1380   arg3 = 0;
1381   arg4 = 0;
1382   arg5 = 0;
1383 }
1384
1385
1386
1387
1388
1389 void prim_eqp () {
1390   arg1 = ((arg1 == arg2));
1391   arg2 = 0;
1392 }
1393
1394 void prim_not () {
1395   arg1 = ((arg1 == 0));
1396 }
1397
1398 void prim_symbolp () {
1399   if ((!((arg1) >= 4096) && ((arg1) >= 512)))
1400     arg1 = (((((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == #x20))));
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) == #x20))));
1403   else
1404     arg1 = 0;
1405 }
1406
1407 void prim_stringp () {
1408   if ((!((arg1) >= 4096) && ((arg1) >= 512)))
1409     arg1 = (((((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == #x40))));
1410   else if ((!((arg1) >= 4096) && !(!((arg1) >= 4096) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1))))
1411     arg1 = (((((rom_get_field0 (arg1) & #x80) == #x80) && ((rom_get_field2 (arg1) & #xe0) == #x40))));
1412   else
1413     arg1 = 0;
1414 }
1415
1416 void prim_string2list () {
1417   if ((!((arg1) >= 4096) && ((arg1) >= 512))) {
1418     if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == #x40)))
1419       halt_with_error();
1420
1421     arg1 = ram_get_car (arg1);
1422   }
1423   else if ((!((arg1) >= 4096) && !(!((arg1) >= 4096) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1)))) {
1424     if (!(((rom_get_field0 (arg1) & #x80) == #x80) && ((rom_get_field2 (arg1) & #xe0) == #x40)))
1425       halt_with_error();
1426
1427     arg1 = rom_get_car (arg1);
1428     }
1429   else
1430     halt_with_error();
1431 }
1432
1433 void prim_list2string () {
1434   arg1 = alloc_ram_cell_init (#x80 | ((arg1 & #x1f00) >> 8),
1435          arg1 & #xff,         #x40,
1436          0);
1437 }
1438
1439 void prim_booleanp () {
1440   arg1 = ((arg1 < 2));
1441 }
1442
1443
1444
1445
1446
1447 void prim_print () {
1448
1449
1450
1451
1452   arg1 = 0;
1453 }
1454
1455 int32 read_clock () {
1456   int32 now = 0;
1457
1458
1459   /* now = from_now( 0 ); */
1460   return now;
1461 }
1462
1463 void prim_clock () {
1464   arg1 = encode_int (read_clock ());
1465 }
1466
1467 void prim_motor () {
1468   decode_2_int_args ();
1469
1470   if (a1 < 1 || a1 > 2 || a2 < -100 || a2 > 100)
1471     halt_with_error();
1472
1473
1474   /*   MOTOR_set( a1, a2 ); */
1475
1476
1477
1478
1479
1480
1481
1482   arg1 = 0;
1483   arg2 = 0;
1484 }
1485
1486
1487 void prim_led () {
1488   decode_2_int_args ();
1489   a3 = decode_int (arg3);
1490
1491   if (a1 < 1 || a1 > 3 || a2 < 0 || a3 < 0)
1492     halt_with_error();
1493
1494
1495 /*   LED_set( a1, a2, a3 ); */
1496
1497
1498
1499
1500
1501
1502
1503   arg1 = 0;
1504   arg2 = 0;
1505   arg3 = 0;
1506 }
1507
1508
1509 void prim_led2_color () {
1510   a1 = decode_int (arg1);
1511
1512   if (a1 < 0 || a1 > 1)
1513     halt_with_error();
1514
1515
1516 /*   LED2_color_set( a1 ); */
1517
1518
1519
1520
1521
1522
1523
1524   arg1 = 0;
1525 }
1526
1527
1528 void prim_getchar_wait () {
1529   decode_2_int_args();
1530   a1 = read_clock () + a1;
1531
1532   if (a1 < 0 || a2 < 1 || a2 > 3)
1533     halt_with_error();
1534
1535
1536   arg1 = 0;
1537 /*   { */
1538 /*     serial_port_set ports; */
1539 /*     ports = serial_rx_wait_with_timeout( a2, a1 ); */
1540 /*     if (ports != 0) */
1541 /*       arg1 = encode_int (serial_rx_read( ports )); */
1542 /*   } */
1543 }
1544
1545
1546 void prim_putchar () {
1547   decode_2_int_args ();
1548
1549   if (a1 < 0 || a1 > 255 || a2 < 1 || a2 > 3)
1550     halt_with_error();
1551
1552
1553 /*   serial_tx_write( a2, a1 ); */
1554
1555
1556
1557
1558
1559
1560
1561   arg1 = 0;
1562   arg2 = 0;
1563 }
1564
1565
1566 void prim_beep () {
1567   decode_2_int_args ();
1568
1569   if (a1 < 1 || a1 > 255 || a2 < 0)
1570     halt_with_error();
1571
1572
1573 /*   beep( a1, from_now( a2 ) ); */
1574
1575
1576
1577
1578
1579
1580
1581   arg1 = 0;
1582   arg2 = 0;
1583 }
1584
1585
1586 void prim_adc () {
1587   int16 x;
1588
1589   a1 = decode_int (arg1);
1590
1591   if (a1 < 1 || a1 > 3)
1592     halt_with_error();
1593
1594
1595 /*   x = adc( a1 ); */
1596   arg1 = encode_int (x);
1597 }
1598
1599 void prim_sernum () {
1600   int16 x;
1601
1602
1603 /*   x = serial_num (); */
1604
1605
1606
1607
1608
1609
1610   arg1 = encode_int (x);
1611 }
1612
1613
1614
1615
1616
1617 void prim_network_init () {
1618
1619
1620
1621
1622
1623 }
1624
1625 void prim_network_cleanup () {
1626
1627
1628
1629 }
1630
1631 void prim_receive_packet_to_u8vector () {
1632
1633   if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == #x60)))
1634     halt_with_error();
1635 }
1636
1637 void prim_send_packet_from_u8vector () {
1638
1639
1640
1641   if (!(((ram_get_field0 (arg1) & #x80) == #x80) && ((ram_get_field2 (arg1) & #xe0) == #x60)))
1642     halt_with_error();
1643
1644   a2 = decode_int (arg2);
1645   a1 = 0;
1646
1647
1648   if (ram_get_car (arg1) < a2)
1649     halt_with_error();
1650
1651   arg1 = ram_get_cdr (arg1);
1652   arg2 = 0;
1653 }
1654
1655 /* void push_arg1 (); */
1656 /* int16 pop (); */
1657 /* void pop_procedure (); */
1658 /* void handle_arity_and_rest_param (); */
1659 /* void build_env (); */
1660 /* void save_cont (); */
1661 /* void interpreter (); */
1662
1663 void push_arg1 () {
1664   env = cons (arg1, env);
1665   arg1 = 0;
1666 }
1667
1668 int16 pop () {
1669   int16 o = ram_get_car (env);
1670   env = ram_get_cdr (env);
1671   return o;
1672 }
1673
1674 void pop_procedure () {
1675   arg1 = pop();
1676
1677   if ((!((arg1) >= 4096) && ((arg1) >= 512))) {
1678     if (!((ram_get_field0 (arg1) & #xc0) == #x40))
1679       halt_with_error();
1680
1681     entry = ram_get_entry (arg1) + #x5000;
1682   }
1683   else if ((!((arg1) >= 4096) && !(!((arg1) >= 4096) && ((arg1) >= 512)) && ((arg1) >= (3 +255 - -1 +1)))) {
1684     if (!((rom_get_field0 (arg1) & #xc0) == #x40))
1685       halt_with_error();
1686
1687     entry = rom_get_entry (arg1) + #x5000;
1688   }
1689   else
1690     halt_with_error();
1691 }
1692
1693 void handle_arity_and_rest_param () {
1694   int8 np;
1695
1696   np = rom_get (entry++);
1697
1698   if ((np & #x80) == 0) {
1699     if (na != np)
1700       halt_with_error();
1701   }
1702   else {
1703     np = ~np;
1704
1705     if (na < np)
1706       halt_with_error();
1707
1708     arg3 = 2;
1709
1710     while (na > np) {
1711       arg4 = pop();
1712
1713       arg3 = cons (arg4, arg3);
1714       arg4 = 0;
1715
1716       na--;
1717     }
1718
1719     arg1 = cons (arg3, arg1);
1720     arg3 = 0;
1721   }
1722 }
1723
1724 void build_env () {
1725   while (na != 0) {
1726     arg3 = pop();
1727
1728     arg1 = cons (arg3, arg1);
1729
1730     na--;
1731   }
1732
1733   arg3 = 0;
1734 }
1735
1736 void save_cont () {
1737
1738   arg3 = alloc_ram_cell_init (#x40 | (pc >> 11),
1739          (pc >> 3) & #xff,
1740          ((pc & #x0007) << 5) | (env >> 8),
1741          env & #xff);
1742   cont = alloc_ram_cell_init (#x80 | (cont >> 8),
1743                               cont & #xff,         #x80 | (arg3 >> 8),
1744                               arg3 & #xff);
1745   arg3 = 0;
1746 }
1747
1748 void init_ram_heap () {
1749   int8 i;
1750   int16 o = 4095;
1751
1752   free_list = 0;
1753
1754   while (o > (512 + (glovars + 1) >> 1)) {
1755
1756
1757     ram_set_gc_tags (o, (0<<5));
1758     ram_set_car (o, free_list);
1759     free_list = o;
1760     o--;
1761   }
1762
1763   free_list_vec = 4096;
1764   ram_set_car (free_list_vec, 0);
1765
1766
1767
1768   ram_set_cdr (free_list_vec, ((8191 - 4096 + 1)*4) >> 2);
1769
1770   for (i=0; i<glovars; i++)
1771     set_global (i, 0);
1772
1773   arg1 = 0;
1774   arg2 = 0;
1775   arg3 = 0;
1776   arg4 = 0;
1777   cont = 0;
1778   env = 2;
1779 }
1780
1781
1782 void interpreter () {
1783   int16 tmp = rom_get (#x5000 +2);
1784   pc = (#x5000 + 4) + (tmp << 2);
1785
1786   glovars = rom_get (#x5000 +3);
1787
1788   init_ram_heap ();
1789
1790   dispatch: ; bytecode = rom_get (pc++); bytecode_hi4 = bytecode & #xf0; bytecode_lo4 = bytecode & #x0f; switch (bytecode_hi4 >> 4) {;
1791
1792
1793   case 0: // TODO used to be #x00 >> 4
1794
1795   ;
1796
1797   arg1 = bytecode_lo4;
1798
1799   push_arg1 ();
1800
1801   ; goto dispatch;;
1802
1803
1804   case 1:;;
1805
1806   ;
1807   arg1 = bytecode_lo4+16;
1808
1809   push_arg1 ();
1810
1811   ; goto dispatch;;
1812
1813
1814   case 2:;;
1815
1816   ;
1817
1818   arg1 = env;
1819
1820   while (bytecode_lo4 != 0) {
1821     arg1 = ram_get_cdr (arg1);
1822     bytecode_lo4--;
1823   }
1824
1825   arg1 = ram_get_car (arg1);
1826
1827   push_arg1 ();
1828
1829   ; goto dispatch;;
1830
1831
1832   case 3:;;
1833
1834   ;
1835
1836   bytecode_lo4 += 16;
1837
1838   arg1 = env;
1839
1840   while (bytecode_lo4 != 0) {
1841     arg1 = ram_get_cdr (arg1);
1842     bytecode_lo4--;
1843   }
1844
1845   arg1 = ram_get_car (arg1);
1846
1847   push_arg1 ();
1848
1849   ; goto dispatch;;
1850
1851
1852   case 4:;;
1853
1854   ;
1855
1856   arg1 = get_global (bytecode_lo4);
1857
1858   push_arg1 ();
1859
1860   ; goto dispatch;;
1861
1862
1863   case 5:;;
1864
1865   ;
1866
1867   set_global (bytecode_lo4, pop());
1868
1869   ; goto dispatch;;
1870
1871
1872   case 6:;;
1873
1874   ;
1875
1876   na = bytecode_lo4;
1877
1878   pop_procedure ();
1879   handle_arity_and_rest_param ();
1880   build_env ();
1881   save_cont ();
1882
1883   env = arg1;
1884   pc = entry;
1885
1886   arg1 = 0;
1887
1888   ; goto dispatch;;
1889
1890
1891   case 7:;;
1892
1893   ;
1894
1895   na = bytecode_lo4;
1896
1897   pop_procedure ();
1898   handle_arity_and_rest_param ();
1899   build_env ();
1900
1901   env = arg1;
1902   pc = entry;
1903
1904   arg1 = 0;
1905
1906   ; goto dispatch;;
1907
1908
1909   case 8:;;
1910
1911   switch (bytecode_lo4) {
1912   case 0:
1913     bytecode = rom_get (pc++);
1914     arg2 = bytecode;
1915
1916     bytecode = rom_get (pc++);
1917
1918     ;
1919
1920
1921     entry = (arg2 << 8) + bytecode + #x5000;
1922     arg1 = 2;
1923
1924     na = rom_get (entry++);
1925
1926     build_env ();
1927     save_cont ();
1928
1929     env = arg1;
1930     pc = entry;
1931
1932     arg1 = 0;
1933     arg2 = 0;
1934
1935     break;
1936
1937   case 1:
1938     bytecode = rom_get (pc++);
1939     arg2 = bytecode;
1940
1941     bytecode = rom_get (pc++);
1942
1943     ;
1944
1945
1946     entry = (arg2 << 8) + bytecode + #x5000;
1947     arg1 = 2;
1948
1949     na = rom_get (entry++);
1950
1951     build_env ();
1952
1953     env = arg1;
1954     pc = entry;
1955
1956     arg1 = 0;
1957     arg2 = 0;
1958
1959     break;
1960
1961   case 2:
1962     bytecode = rom_get (pc++);
1963     arg2 = bytecode;
1964
1965     bytecode = rom_get (pc++);
1966
1967     ;
1968
1969
1970     pc = (arg2 << 8) + bytecode + #x5000;
1971
1972     break;
1973
1974   case 3:
1975     bytecode = rom_get (pc++);
1976     arg2 = bytecode;
1977
1978     bytecode = rom_get (pc++);
1979
1980     ;
1981
1982
1983     if (pop() == 0)
1984       pc = (arg2 << 8) + bytecode + #x5000;
1985
1986     break;
1987
1988   case 4:
1989     bytecode = rom_get (pc++);
1990     arg2 = bytecode;
1991
1992     bytecode = rom_get (pc++);
1993
1994     ;
1995
1996     arg3 = pop();
1997
1998     entry = (arg2 << 8) | bytecode;
1999
2000     arg1 = alloc_ram_cell_init (#x40 | (arg2 >> 3),
2001     ((arg2 & #x07) << 5) | (bytecode >> 3),
2002     ((bytecode &#x07) << 5) |((arg3 &#x1f00) >>8),
2003     arg3 & #xff);
2004
2005     push_arg1 ();
2006
2007     arg2 = 0;
2008     arg3 = 0;
2009
2010     break;
2011
2012   case 5:
2013     bytecode = rom_get (pc++);
2014
2015     ;
2016
2017
2018     entry = pc + bytecode + #x5000;
2019     arg1 = 2;
2020
2021     na = rom_get (entry++);
2022
2023     build_env ();
2024     save_cont ();
2025
2026     env = arg1;
2027     pc = entry;
2028
2029     arg1 = 0;
2030
2031     break;
2032
2033   case 6:
2034     bytecode = rom_get (pc++);
2035
2036     ;
2037
2038
2039     entry = pc + bytecode + #x5000;
2040     arg1 = 2;
2041
2042     na = rom_get (entry++);
2043
2044     build_env ();
2045
2046     env = arg1;
2047     pc = entry;
2048
2049     arg1 = 0;
2050
2051     break;
2052
2053   case 7:
2054     bytecode = rom_get (pc++);
2055
2056     ;
2057
2058     pc = pc + bytecode + #x5000;
2059
2060     break;
2061
2062   case 8:
2063     bytecode = rom_get (pc++);
2064
2065     ;
2066
2067
2068     if (pop() == 0)
2069       pc = pc + bytecode + #x5000;
2070
2071     break;
2072
2073   case 9:
2074     bytecode = rom_get (pc++);
2075
2076     ;
2077
2078     arg3 = pop();
2079
2080     entry = pc + bytecode;
2081
2082     arg1 = alloc_ram_cell_init (#x40 | (arg2 >> 3),
2083     ((arg2 & #x07) << 5) | (bytecode >> 3),
2084     ((bytecode &#x07) <<5) |((arg3 &#x1f00) >>8),
2085     arg3 & #xff);
2086
2087     push_arg1 ();
2088
2089     arg3 = 0;
2090
2091     break;
2092   case 14:
2093     bytecode = rom_get (pc++);
2094
2095     ;
2096
2097     arg1 = get_global (bytecode);
2098
2099     push_arg1 ();
2100
2101     break;
2102
2103   case 15:
2104     bytecode = rom_get (pc++);
2105
2106     ;
2107
2108     set_global (bytecode, pop());
2109
2110     break;
2111   }
2112
2113   ; goto dispatch;;
2114
2115
2116   case 9:;;
2117
2118
2119
2120   bytecode = rom_get (pc++);
2121
2122   ;
2123
2124   arg1 = (bytecode_lo4 << 8) | bytecode;
2125   push_arg1 ();
2126
2127   ; goto dispatch;;
2128
2129
2130   case 10:;;
2131
2132   ; goto dispatch;;
2133
2134
2135   case 11:;;
2136
2137   ; goto dispatch;;
2138
2139
2140   case 12:;;
2141
2142   ;
2143
2144   switch (bytecode_lo4) {
2145   case 0:
2146     arg1 = pop(); prim_numberp (); push_arg1 (); break;
2147   case 1:
2148     arg2 = pop(); arg1 = pop(); prim_add (); push_arg1 (); break;
2149   case 2:
2150     arg2 = pop(); arg1 = pop(); prim_sub (); push_arg1 (); break;
2151   case 3:
2152     arg2 = pop(); arg1 = pop(); prim_mul (); push_arg1 (); break;
2153   case 4:
2154     arg2 = pop(); arg1 = pop(); prim_div (); push_arg1 (); break;
2155   case 5:
2156     arg2 = pop(); arg1 = pop(); prim_rem (); push_arg1 (); break;
2157   case 6:
2158     arg1 = pop(); prim_neg (); push_arg1 (); break;
2159   case 7:
2160     arg2 = pop(); arg1 = pop(); prim_eq (); push_arg1 (); break;
2161   case 8:
2162     arg2 = pop(); arg1 = pop(); prim_lt (); push_arg1 (); break;
2163   case 9:
2164     arg2 = pop(); arg1 = pop(); prim_leq (); push_arg1 (); break;
2165   case 10:
2166     arg2 = pop(); arg1 = pop(); prim_gt (); push_arg1 (); break;
2167   case 11:
2168     arg2 = pop(); arg1 = pop(); prim_geq (); push_arg1 (); break;
2169   case 12:
2170     arg1 = pop(); prim_pairp (); push_arg1 (); break;
2171   case 13:
2172     arg2 = pop(); arg1 = pop(); prim_cons (); push_arg1 (); break;
2173   case 14:
2174     arg1 = pop(); prim_car (); push_arg1 (); break;
2175   case 15:
2176     arg1 = pop(); prim_cdr (); push_arg1 (); break;
2177   }
2178
2179   ; goto dispatch;;
2180
2181
2182   case 13:;;
2183
2184   ;
2185
2186   switch (bytecode_lo4) {
2187   case 0:
2188     arg2 = pop(); arg1 = pop(); prim_set_car (); break;
2189   case 1:
2190     arg2 = pop(); arg1 = pop(); prim_set_cdr (); break;
2191   case 2:
2192     arg1 = pop(); prim_nullp (); push_arg1 (); break;
2193   case 3:
2194     arg2 = pop(); arg1 = pop(); prim_eqp (); push_arg1 (); break;
2195   case 4:
2196     arg1 = pop(); prim_not (); push_arg1 (); break;
2197   case 5:
2198
2199     arg1 = cont;
2200     push_arg1 ();
2201     break;
2202   case 6:
2203
2204
2205     arg1 = pop();
2206     cont = pop();
2207
2208     push_arg1 ();
2209
2210     na = 0;
2211
2212     pop_procedure ();
2213     handle_arity_and_rest_param ();
2214     build_env ();
2215
2216     env = arg1;
2217     pc = entry;
2218
2219     arg1 = 0;
2220
2221     break;
2222   case 7:
2223
2224
2225     arg1 = pop();
2226     cont = pop();
2227
2228     arg2 = ram_get_cdr (cont);
2229
2230     pc = ram_get_entry (arg2);
2231
2232     env = ram_get_cdr (arg2);
2233     cont = ram_get_car (cont);
2234
2235     push_arg1 ();
2236     arg2 = 0;
2237
2238     break;
2239   case 8:
2240
2241     return;
2242   case 9:
2243
2244     arg1 = pop(); prim_symbolp (); push_arg1 (); break;
2245   case 10:
2246
2247     arg1 = pop(); prim_stringp (); push_arg1 (); break;
2248   case 11:
2249
2250     arg1 = pop(); prim_string2list (); push_arg1 (); break;
2251   case 12:
2252
2253     arg1 = pop(); prim_list2string (); push_arg1 (); break;
2254   case 13:
2255
2256     arg2 = pop(); arg1 = pop(); prim_make_u8vector (); push_arg1 (); break;
2257   case 14:
2258
2259     arg2 = pop(); arg1 = pop(); prim_u8vector_ref (); push_arg1 (); break;
2260   case 15:
2261
2262     arg3 = pop(); arg2 = pop(); arg1 = pop(); prim_u8vector_set (); break;
2263   }
2264
2265   ; goto dispatch;;
2266
2267
2268   case 14:;;
2269
2270   ;
2271
2272   switch (bytecode_lo4) {
2273   case 0:
2274
2275     arg1 = pop();
2276     prim_print ();
2277     break;
2278   case 1:
2279
2280     prim_clock (); push_arg1 (); break;
2281   case 2:
2282
2283     arg2 = pop(); arg1 = pop(); prim_motor (); break;
2284   case 3:
2285
2286     arg3 = pop(); arg2 = pop(); arg1 = pop(); prim_led (); ;break;
2287   case 4:
2288
2289     arg1 = pop(); prim_led2_color (); break;
2290   case 5:
2291
2292     arg2 = pop(); arg1 = pop(); prim_getchar_wait (); push_arg1 (); break;
2293   case 6:
2294
2295     arg2 = pop(); arg1 = pop(); prim_putchar (); break;
2296   case 7:
2297
2298     arg2 = pop(); arg1 = pop(); prim_beep (); break;
2299   case 8:
2300
2301     arg1 = pop(); prim_adc (); push_arg1 (); break;
2302   case 9:
2303
2304     arg1 = pop(); prim_u8vectorp (); push_arg1 (); break;
2305   case 10:
2306
2307     prim_sernum (); push_arg1 (); break;
2308   case 11:
2309
2310     arg1 = pop(); prim_u8vector_length (); push_arg1 (); break;
2311   case 12:
2312
2313     arg5 = pop(); arg4 = pop(); arg3 = pop(); arg2 = pop(); arg1 = pop();
2314     prim_u8vector_copy (); break;
2315     break;
2316   case 13:
2317
2318     arg1 = pop();
2319     pop();
2320     push_arg1 ();
2321     break;
2322   case 14:
2323
2324     pop();
2325     break;
2326   case 15:
2327
2328     arg1 = pop();
2329     arg2 = ram_get_cdr (cont);
2330     pc = ram_get_entry (arg2);
2331     env = ram_get_cdr (arg2);
2332     cont = ram_get_car (cont);
2333     push_arg1 ();
2334     arg2 = 0;
2335     break;
2336   }
2337
2338   ; goto dispatch;;
2339
2340
2341
2342   case 15:;;
2343
2344   ;
2345
2346   switch (bytecode_lo4) {
2347   case 0:
2348
2349     arg1 = pop(); prim_booleanp (); push_arg1 (); break;
2350   case 1:
2351
2352     prim_network_init (); break;
2353   case 2:
2354
2355     prim_network_cleanup (); break;
2356   case 3:
2357
2358     arg1 = pop(); prim_receive_packet_to_u8vector (); push_arg1 (); break;
2359   case 4:
2360
2361     arg2 = pop(); arg1 = pop(); prim_send_packet_from_u8vector ();
2362     push_arg1 (); break;
2363   case 5:
2364     arg2 = pop(); arg1 = pop(); prim_ior (); push_arg1 (); break;
2365     break;
2366   case 6:
2367     arg2 = pop(); arg1 = pop(); prim_xor (); push_arg1 (); break;
2368     break;
2369   }
2370
2371   ; goto dispatch;;
2372
2373
2374
2375   };
2376 }
2377
2378 interpreter();