primitives.c

   1 /* file: "primitives.c" */
   2
   3 /*
   4  * Copyright 2004-2009 by Marc Feeley and Vincent St-Amour, All Rights Reserved.
   5  */
   6
   7 #include "picobit-vm.h"
   8
   9 /*---------------------------------------------------------------------------*/
  10
  11 #ifdef WORKSTATION
  12 char *prim_name[64] =
  13   {
  14     "prim #%number?",
  15     "prim #%+",
  16     "prim #%-",
  17     "prim #%*",
  18     "prim #%quotient",
  19     "prim #%remainder",
  20     "prim #%neg",
  21     "prim #%=",
  22     "prim #%<",
  23     "prim #%<=",
  24     "prim #%>",
  25     "prim #%>=",
  26     "prim #%pair?",
  27     "prim #%cons",
  28     "prim #%car",
  29     "prim #%cdr",
  30     "prim #%set-car!",
  31     "prim #%set-cdr!",
  32     "prim #%null?",
  33     "prim #%eq?",
  34     "prim #%not",
  35     "prim #%get-cont",
  36     "prim #%graft-to-cont",
  37     "prim #%return-to-cont",
  38     "prim #%halt",
  39     "prim #%symbol?",
  40     "prim #%string?",
  41     "prim #%string->list",
  42     "prim #%list->string",
  43     "prim #%make-u8vector",
  44     "prim #%u8vector-ref",
  45     "prim #%u8vector-set!",
  46     "prim #%print",
  47     "prim #%clock",
  48     "prim #%motor",
  49     "prim #%led",
  50     "prim #%led2-color",
  51     "prim #%getchar-wait",
  52     "prim #%putchar",
  53     "prim #%beep",
  54     "prim #%adc",
  55     "prim #%u8vector?",
  56     "prim #%sernum",
  57     "prim #%u8vector-length",
  58     "prim #%u8vector-copy!",
  59     "shift",
  60     "pop",
  61     "return",
  62     "prim #%boolean?",
  63     "prim #%network-init",
  64     "prim #%network-cleanup",
  65     "prim #%receive-packet-to-u8vector",
  66     "prim #%send-packet-from-u8vector",
  67     "prim #%ior",
  68     "prim #%xor",
  69     "prim 55",
  70     "prim 56",
  71     "prim 57",
  72     "prim 58",
  73     "prim 59",
  74     "prim 60",
  75     "prim 61",
  76     "prim 62",
  77     "prim 63"
  78   };
  79 #endif
  80
  81 /*---------------------------------------------------------------------------*/
  82
  83 // numerical primitives
  84
  85 void prim_numberp () {
  86   if (arg1 >= MIN_FIXNUM_ENCODING
  87       && arg1 <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM)))
  88     arg1 = OBJ_TRUE;
  89   else {
  90     if (IN_RAM(arg1))
  91       arg1 = encode_bool (RAM_BIGNUM(arg1));
  92     else if (IN_ROM(arg1))
  93       arg1 = encode_bool (ROM_BIGNUM(arg1));
  94     else
  95       arg1 = OBJ_FALSE;
  96   }
  97 }
  98
  99 void prim_add () {
 100 #ifdef INFINITE_PRECISION_BIGNUMS
 101   arg1 = add (arg1, arg2);
 102 #else
 103   decode_2_int_args ();
 104   arg1 = encode_int (a1 + a2);
 105 #endif
 106   arg2 = OBJ_FALSE;
 107 }
 108
 109 void prim_sub () {
 110 #ifdef INFINITE_PRECISION_BIGNUMS
 111   arg1 = sub (arg1, arg2);
 112 #else
 113   decode_2_int_args ();
 114   arg1 = encode_int (a1 - a2);
 115 #endif
 116   arg2 = OBJ_FALSE;
 117 }
 118
 119 void prim_mul () {
 120 #ifdef INFINITE_PRECISION_BIGNUMS
 121   a1 = negp (arg1);
 122   a2 = negp (arg2); // -1 if negative
 123   arg1 = mulnonneg (a1 ? neg(arg1) : arg1,
 124                     a2 ? neg(arg2) : arg2);
 125   if (a1 + a2 == 1) // only one of the 2 was negative
 126     arg1 = neg(arg1);
 127 #else
 128   decode_2_int_args ();
 129   arg1 = encode_int (a1 * a2);
 130 #endif
 131   arg2 = OBJ_FALSE;
 132 }
 133
 134 void prim_div () {
 135 #ifdef INFINITE_PRECISION_BIGNUMS
 136   if (obj_eq(arg2, ZERO))
 137     ERROR("quotient", "divide by 0");
 138   a1 = negp (arg1);
 139   a2 = negp (arg2); // -1 if negative
 140   arg1 = divnonneg (a1 ? neg(arg1) : arg1,
 141                     a2 ? neg(arg2) : arg2);
 142   if (a1 + a2 == 1) // only one of the 2 was negative
 143     arg1 = neg(arg1);
 144 #else
 145   decode_2_int_args ();
 146   if (a2 == 0)
 147     ERROR("quotient", "divide by 0");
 148   arg1 = encode_int (a1 / a2);
 149 #endif
 150   arg2 = OBJ_FALSE;
 151 }
 152
 153 void prim_rem () {
 154 #ifdef INFINITE_PRECISION_BIGNUMS
 155   if (obj_eq(arg2, ZERO))
 156     ERROR("remainder", "divide by 0");
 157   if (negp(arg1) || negp(arg2))
 158     ERROR("remainder", "only positive numbers are supported");
 159   // TODO fix this to handle negatives
 160   // TODO logic quite similar to mul and div (likely, once we fix), abstract ?
 161   arg3 = divnonneg (arg1, arg2);
 162   arg4 = mulnonneg (arg2, arg3);
 163   arg1 = sub(arg1, arg4 );
 164   arg3 = OBJ_FALSE;
 165   arg4 = OBJ_FALSE;
 166 #else
 167   decode_2_int_args ();
 168   if (a2 == 0)
 169     ERROR("remainder", "divide by 0");
 170   arg1 = encode_int (a1 % a2);
 171 #endif
 172   arg2 = OBJ_FALSE;
 173 }
 174
 175 void prim_neg () {
 176 #ifdef INFINITE_PRECISION_BIGNUMS
 177   arg1 = neg (arg1);
 178 #else
 179   a1 = decode_int (arg1);
 180   arg1 = encode_int (- a1);
 181 #endif
 182 }
 183
 184 void prim_eq () {
 185 #ifdef INFINITE_PRECISION_BIGNUMS
 186   arg1 = encode_bool(cmp (arg1, arg2) == 0);
 187 #else
 188   decode_2_int_args ();
 189   arg1 = encode_bool(a1 == a2);
 190 #endif
 191   arg2 = OBJ_FALSE;
 192 }
 193
 194 void prim_lt () {
 195 #ifdef INFINITE_PRECISION_BIGNUMS
 196   arg1 = encode_bool(cmp (arg1, arg2) < 0);
 197 #else
 198   decode_2_int_args ();
 199   arg1 = encode_bool(a1 < a2);
 200 #endif
 201   arg2 = OBJ_FALSE;
 202 }
 203
 204 void prim_gt () {
 205 #ifdef INFINITE_PRECISION_BIGNUMS
 206   arg1 = encode_bool(cmp (arg1, arg2) > 0);
 207 #else
 208   decode_2_int_args ();
 209   arg1 = encode_bool(a1 > a2);
 210 #endif
 211   arg2 = OBJ_FALSE;
 212 }
 213
 214 void prim_leq () { // TODO these 2 are useful, but they add to the code size, is it worth it ?
 215 #ifdef INFINITE_PRECISION_BIGNUMS
 216   arg1 = encode_bool(cmp (arg1, arg2) <= 0);
 217 #else
 218   decode_2_int_args ();
 219   arg1 = encode_bool(a1 <= a2);
 220 #endif
 221   arg2 = OBJ_FALSE;
 222
 223 }
 224
 225 void prim_geq () {
 226 #ifdef INFINITE_PRECISION_BIGNUMS
 227   arg1 = encode_bool(cmp (arg1, arg2) >= 0);
 228 #else
 229   decode_2_int_args ();
 230   arg1 = encode_bool(a1 >= a2);
 231 #endif
 232   arg2 = OBJ_FALSE;
 233 }
 234
 235 void prim_ior () {
 236 #ifdef INFINITE_PRECISION_BIGNUMS
 237   arg1 = bitwise_ior(arg1, arg2);
 238 #else
 239   decode_2_int_args (); // TODO is the function call overhead worth it ?
 240   arg1 = encode_int (a1 | a2);
 241 #endif
 242   arg2 = OBJ_FALSE;
 243 }
 244
 245 void prim_xor () {
 246 #ifdef INFINITE_PRECISION_BIGNUMS
 247   arg1 = bitwise_xor(arg1, arg2);
 248 #else
 249   decode_2_int_args (); // TODO is the function call overhead worth it ?
 250   arg1 = encode_int (a1 ^ a2);
 251 #endif
 252   arg2 = OBJ_FALSE;
 253 }
 254
 255 // TODO primitives de shift ?
 256
 257 /*---------------------------------------------------------------------------*/
 258
 259 // list primitives
 260
 261 void prim_pairp () {
 262   if (IN_RAM(arg1))
 263     arg1 = encode_bool (RAM_PAIR(arg1));
 264   else if (IN_ROM(arg1))
 265     arg1 = encode_bool (ROM_PAIR(arg1));
 266   else
 267     arg1 = OBJ_FALSE;
 268 }
 269
 270 obj cons (obj car, obj cdr) {
 271   return alloc_ram_cell_init (COMPOSITE_FIELD0 | (car >> 8),
 272                               car & 0xff,
 273                               PAIR_FIELD2 | (cdr >> 8),
 274                               cdr & 0xff);
 275 }
 276
 277 void prim_cons () {
 278   arg1 = cons (arg1, arg2);
 279   arg2 = OBJ_FALSE;
 280 }
 281
 282 void prim_car () {
 283   if (IN_RAM(arg1)) {
 284     if (!RAM_PAIR(arg1))
 285       TYPE_ERROR("car.0", "pair");
 286     arg1 = ram_get_car (arg1);
 287   }
 288   else if (IN_ROM(arg1)) {
 289     if (!ROM_PAIR(arg1))
 290       TYPE_ERROR("car.1", "pair");
 291     arg1 = rom_get_car (arg1);
 292   }
 293   else
 294     TYPE_ERROR("car.2", "pair");
 295 }
 296
 297 void prim_cdr () {
 298   if (IN_RAM(arg1)) {
 299     if (!RAM_PAIR(arg1))
 300       TYPE_ERROR("cdr.0", "pair");
 301     arg1 = ram_get_cdr (arg1);
 302   }
 303   else if (IN_ROM(arg1)) {
 304     if (!ROM_PAIR(arg1))
 305       TYPE_ERROR("cdr.1", "pair");
 306     arg1 = rom_get_cdr (arg1);
 307   }
 308   else
 309     TYPE_ERROR("cdr.2", "pair");
 310 }
 311
 312 void prim_set_car () {
 313   if (IN_RAM(arg1)) {
 314     if (!RAM_PAIR(arg1))
 315       TYPE_ERROR("set-car!.0", "pair");
 316
 317     ram_set_car (arg1, arg2);
 318     arg1 = OBJ_FALSE;
 319     arg2 = OBJ_FALSE;
 320   }
 321   else
 322     TYPE_ERROR("set-car!.1", "pair");
 323 }
 324
 325 void prim_set_cdr () {
 326   if (IN_RAM(arg1)) {
 327     if (!RAM_PAIR(arg1))
 328       TYPE_ERROR("set-cdr!.0", "pair");
 329
 330     ram_set_cdr (arg1, arg2);
 331     arg1 = OBJ_FALSE;
 332     arg2 = OBJ_FALSE;
 333   }
 334   else
 335     TYPE_ERROR("set-cdr!.1", "pair");
 336 }
 337
 338 void prim_nullp () {
 339   arg1 = encode_bool (arg1 == OBJ_NULL);
 340 }
 341
 342 /*---------------------------------------------------------------------------*/
 343
 344 // vector primitives
 345
 346 void prim_u8vectorp () {
 347   if (IN_RAM(arg1))
 348     arg1 = encode_bool (RAM_VECTOR(arg1));
 349   else if (IN_ROM(arg1))
 350     arg1 = encode_bool (ROM_VECTOR(arg1));
 351   else
 352     arg1 = OBJ_FALSE;
 353 }
 354
 355 void prim_make_u8vector () {
 356   decode_2_int_args (); // arg1 is length, arg2 is contents
 357   // TODO adapt for the new bignums
 358   if (a2 > 255)
 359     ERROR("make-u8vector", "byte vectors can only contain bytes");
 360
 361   arg3 = alloc_vec_cell (a1);
 362   arg1 = alloc_ram_cell_init (COMPOSITE_FIELD0 | (a1 >> 8),
 363                               a1 & 0xff,
 364                               VECTOR_FIELD2 | (arg3 >> 8),
 365                               arg3 & 0xff);
 366
 367   a1 = (a1 + 3) >> 2; // actual length, in words
 368   while (a1--) {
 369     ram_set_field0 (arg3, a2);
 370     ram_set_field1 (arg3, a2);
 371     ram_set_field2 (arg3, a2);
 372     ram_set_field3 (arg3, a2);
 373     arg3++;
 374   }
 375 }
 376
 377 void prim_u8vector_ref () {
 378   a2 = decode_int (arg2);
 379   // TODO adapt for the new bignums
 380   if (IN_RAM(arg1)) {
 381     if (!RAM_VECTOR(arg1))
 382       TYPE_ERROR("u8vector-ref.0", "vector");
 383     if ((ram_get_car (arg1) <= a2) || (a2 < 0))
 384       ERROR("u8vector-ref.0", "vector index invalid");
 385     arg1 = ram_get_cdr (arg1);
 386   }
 387   else if (IN_ROM(arg1)) {
 388     if (!ROM_VECTOR(arg1))
 389       TYPE_ERROR("u8vector-ref.1", "vector");
 390     if ((rom_get_car (arg1) <= a2) || (a2 < 0))
 391       ERROR("u8vector-ref.1", "vector index invalid");
 392     arg1 = rom_get_cdr (arg1);
 393   }
 394   else
 395     TYPE_ERROR("u8vector-ref.2", "vector");
 396
 397   if (IN_VEC(arg1)) {
 398     arg1 += (a2 >> 2);
 399     a2 %= 4;
 400
 401     arg1 = encode_int (ram_get_fieldn (arg1, a2));
 402   }
 403   else { // rom vector, stored as a list
 404     while (a2--)
 405       arg1 = rom_get_cdr (arg1);
 406
 407     // the contents are already encoded as fixnums
 408     arg1 = rom_get_car (arg1);
 409   }
 410
 411   arg2 = OBJ_FALSE;
 412   arg3 = OBJ_FALSE;
 413   arg4 = OBJ_FALSE;
 414 }
 415
 416 void prim_u8vector_set () { // TODO a lot in common with ref, abstract that
 417   a2 = decode_int (arg2); // TODO adapt for bignums
 418   a3 = decode_int (arg3);
 419
 420   if (a3 > 255)
 421     ERROR("u8vector-set!", "byte vectors can only contain bytes");
 422
 423   if (IN_RAM(arg1)) {
 424     if (!RAM_VECTOR(arg1))
 425       TYPE_ERROR("u8vector-set!.0", "vector");
 426     if ((ram_get_car (arg1) <= a2) || (a2 < 0))
 427       ERROR("u8vector-set!", "vector index invalid");
 428     arg1 = ram_get_cdr (arg1);
 429   }
 430   else
 431     TYPE_ERROR("u8vector-set!.1", "vector");
 432
 433   arg1 += (a2 >> 2);
 434   a2 %= 4;
 435
 436   ram_set_fieldn (arg1, a2, a3);
 437
 438   arg1 = OBJ_FALSE;
 439   arg2 = OBJ_FALSE;
 440   arg3 = OBJ_FALSE;
 441 }
 442
 443 void prim_u8vector_length () {
 444   if (IN_RAM(arg1)) {
 445     if (!RAM_VECTOR(arg1))
 446       TYPE_ERROR("u8vector-length.0", "vector");
 447     arg1 = encode_int (ram_get_car (arg1));
 448   }
 449   else if (IN_ROM(arg1)) {
 450     if (!ROM_VECTOR(arg1))
 451       TYPE_ERROR("u8vector-length.1", "vector");
 452     arg1 = encode_int (rom_get_car (arg1));
 453   }
 454   else
 455     TYPE_ERROR("u8vector-length.2", "vector");
 456 }
 457
 458 void prim_u8vector_copy () {
 459   // arg1 is source, arg2 is source-start, arg3 is target, arg4 is target-start
 460   // arg5 is number of bytes to copy
 461
 462   a1 = decode_int (arg2);
 463   a2 = decode_int (arg4);
 464   a3 = decode_int (arg5);
 465
 466   // case 1 : ram to ram
 467   if (IN_RAM(arg1) && IN_RAM(arg3)) {
 468     if (!RAM_VECTOR(arg1) || !RAM_VECTOR(arg3))
 469       TYPE_ERROR("u8vector-copy!.0", "vector");
 470     if ((ram_get_car (arg1) < (a1 + a3)) || (a1 < 0) ||
 471         (ram_get_car (arg3) < (a2 + a3)) || (a2 < 0))
 472       ERROR("u8vector-copy!.0", "vector index invalid");
 473
 474     // position to the start
 475     arg1 = ram_get_cdr (arg1);
 476     arg1 += (a1 >> 2);
 477     a1 %= 4;
 478     arg3 = ram_get_cdr (arg3);
 479     arg3 += (a2 >> 2);
 480     a2 %= 4;
 481
 482     // copy
 483     while (a3--) {
 484       ram_set_fieldn (arg3, a2, ram_get_fieldn (arg1, a1));
 485
 486       a1++;
 487       arg1 += (a1 >> 2);
 488       a1 %= 4; // TODO merge with the previous similar block ?
 489       a2++;
 490       arg3 += (a2 >> 2);
 491       a2 %= 4;
 492     }
 493   }
 494   // case 2 : rom to ram
 495   else if (IN_ROM(arg1) && IN_RAM(arg3)) {
 496     if (!ROM_VECTOR(arg1) || !RAM_VECTOR(arg3))
 497       TYPE_ERROR("u8vector-copy!.1", "vector");
 498     if ((rom_get_car (arg1) < (a1 + a3)) || (a1 < 0) ||
 499         (ram_get_car (arg3) < (a2 + a3)) || (a2 < 0))
 500       ERROR("u8vector-copy!.1", "vector index invalid");
 501
 502     arg1 = rom_get_cdr (arg1);
 503     while (a1--)
 504       arg1 = rom_get_cdr (arg1);
 505
 506     arg3 = ram_get_cdr (arg3);
 507     arg3 += (a2 >> 2);
 508     a2 %= 4;
 509
 510     while (a3--) {
 511       ram_set_fieldn (arg3, a2, decode_int (rom_get_car (arg1)));
 512
 513       arg1 = rom_get_cdr (arg1);
 514       a2++;
 515       arg3 += (a2 >> 2);
 516       a2 %= 4; // TODO very similar to the other case
 517     }
 518   }
 519   else
 520     TYPE_ERROR("u8vector-copy!.2", "vector");
 521
 522   arg1 = OBJ_FALSE;
 523   arg2 = OBJ_FALSE;
 524   arg3 = OBJ_FALSE;
 525   arg4 = OBJ_FALSE;
 526   arg5 = OBJ_FALSE;
 527 }
 528
 529 /*---------------------------------------------------------------------------*/
 530
 531 // miscellaneous primitives
 532
 533 void prim_eqp () {
 534   arg1 = encode_bool (arg1 == arg2);
 535   arg2 = OBJ_FALSE;
 536 }
 537
 538 void prim_not () {
 539   arg1 = encode_bool (arg1 == OBJ_FALSE);
 540 }
 541
 542 void prim_symbolp () {
 543   if (IN_RAM(arg1))
 544     arg1 = encode_bool (RAM_SYMBOL(arg1));
 545   else if (IN_ROM(arg1))
 546     arg1 = encode_bool (ROM_SYMBOL(arg1));
 547   else
 548     arg1 = OBJ_FALSE;
 549 }
 550
 551 void prim_stringp () {
 552   if (IN_RAM(arg1))
 553     arg1 = encode_bool (RAM_STRING(arg1));
 554   else if (IN_ROM(arg1))
 555     arg1 = encode_bool (ROM_STRING(arg1));
 556   else
 557     arg1 = OBJ_FALSE;
 558 }
 559
 560 void prim_string2list () {
 561   if (IN_RAM(arg1)) {
 562     if (!RAM_STRING(arg1))
 563       TYPE_ERROR("string->list.0", "string");
 564
 565     arg1 = ram_get_car (arg1);
 566   }
 567   else if (IN_ROM(arg1)) {
 568     if (!ROM_STRING(arg1))
 569       TYPE_ERROR("string->list.1", "string");
 570
 571     arg1 = rom_get_car (arg1);
 572     }
 573   else
 574     TYPE_ERROR("string->list.2", "string");
 575 }
 576
 577 void prim_list2string () {
 578   arg1 = alloc_ram_cell_init (COMPOSITE_FIELD0 | ((arg1 & 0x1f00) >> 8),
 579                               arg1 & 0xff,
 580                               STRING_FIELD2,
 581                               0);
 582 }
 583
 584 void prim_booleanp () {
 585   arg1 = encode_bool (arg1 < 2);
 586 }
 587
 588 /*---------------------------------------------------------------------------*/
 589
 590 // robot-specific primitives
 591
 592 #ifdef WORKSTATION
 593
 594 void show (obj o) {
 595 #if 0
 596   printf ("[%d]", o);
 597 #endif
 598
 599   if (o == OBJ_FALSE)
 600     printf ("#f");
 601   else if (o == OBJ_TRUE)
 602     printf ("#t");
 603   else if (o == OBJ_NULL)
 604     printf ("()");
 605   else if (o <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM)))
 606     printf ("%d", DECODE_FIXNUM(o));
 607   else {
 608     uint8 in_ram;
 609
 610     if (IN_RAM(o))
 611       in_ram = 1;
 612     else
 613       in_ram = 0;
 614
 615     if ((in_ram && RAM_BIGNUM(o)) || (!in_ram && ROM_BIGNUM(o))) // TODO fix for new bignums
 616       printf ("%d", decode_int (o));
 617     else if ((in_ram && RAM_COMPOSITE(o)) || (!in_ram && ROM_COMPOSITE(o))) {
 618       obj car;
 619       obj cdr;
 620
 621       if ((in_ram && RAM_PAIR(o)) || (!in_ram && ROM_PAIR(o))) {
 622         if (in_ram) {
 623           car = ram_get_car (o);
 624           cdr = ram_get_cdr (o);
 625         }
 626         else {
 627           car = rom_get_car (o);
 628           cdr = rom_get_cdr (o);
 629         }
 630
 631         printf ("(");
 632
 633       loop:
 634
 635         show (car);
 636
 637         if (cdr == OBJ_NULL)
 638           printf (")");
 639         else if ((IN_RAM(cdr) && RAM_PAIR(cdr))
 640                  || (IN_ROM(cdr) && ROM_PAIR(cdr))) {
 641           if (IN_RAM(cdr)) {
 642             car = ram_get_car (cdr);
 643             cdr = ram_get_cdr (cdr);
 644           }
 645           else {
 646             car = rom_get_car (cdr);
 647             cdr = rom_get_cdr (cdr);
 648           }
 649
 650           printf (" ");
 651           goto loop;
 652         }
 653         else {
 654           printf (" . ");
 655           show (cdr);
 656           printf (")");
 657         }
 658       }
 659       else if ((in_ram && RAM_SYMBOL(o)) || (!in_ram && ROM_SYMBOL(o)))
 660         printf ("#<symbol>");
 661       else if ((in_ram && RAM_STRING(o)) || (!in_ram && ROM_STRING(o)))
 662         printf ("#<string>");
 663       else if ((in_ram && RAM_VECTOR(o)) || (!in_ram && ROM_VECTOR(o)))
 664         printf ("#<vector %d>", o);
 665       else {
 666         printf ("(");
 667         cdr = ram_get_car (o);
 668         car = ram_get_cdr (o);
 669         // ugly hack, takes advantage of the fact that pairs and
 670         // continuations have the same layout
 671         goto loop;
 672       }
 673     }
 674     else { // closure
 675       obj env;
 676       rom_addr pc;
 677
 678       if (IN_RAM(o))
 679         env = ram_get_cdr (o);
 680       else
 681         env = rom_get_cdr (o);
 682
 683       if (IN_RAM(o))
 684         pc = ram_get_entry (o);
 685       else
 686         pc = rom_get_entry (o);
 687
 688       printf ("{0x%04x ", pc);
 689       show (env);
 690       printf ("}");
 691     }
 692   }
 693
 694   fflush (stdout);
 695 }
 696
 697 void print (obj o) {
 698   show (o);
 699   printf ("\n");
 700   fflush (stdout);
 701 }
 702
 703 #endif
 704
 705 void prim_print () {
 706 #ifdef WORKSTATION
 707   print (arg1);
 708 #endif
 709
 710   arg1 = OBJ_FALSE;
 711 }
 712
 713 int32 read_clock () {
 714   int32 now = 0;
 715
 716 #ifdef PICOBOARD2
 717   now = from_now( 0 );
 718 #endif
 719
 720 #ifdef WORKSTATION
 721 #ifdef _WIN32
 722   static int32 start = 0;
 723   struct timeb tb;
 724   ftime (&tb);
 725   now = tb.time * 1000 + tb.millitm;
 726   if (start == 0)
 727     start = now;
 728   now -= start;
 729 #else
 730   static int32 start = 0;
 731   struct timeval tv;
 732   if (gettimeofday (&tv, NULL) == 0) {
 733     now = tv.tv_sec * 1000 + tv.tv_usec / 1000;
 734     if (start == 0)
 735       start = now;
 736     now -= start;
 737   }
 738 #endif
 739 #endif
 740
 741   return now;
 742 }
 743
 744 void prim_clock () {
 745   arg1 = encode_int (read_clock ());
 746 }
 747
 748 void prim_motor () {
 749   decode_2_int_args ();
 750
 751   if (a1 < 1 || a1 > 2 || a2 < -100 || a2 > 100)
 752     ERROR("motor", "argument out of range");
 753
 754 #ifdef PICOBOARD2
 755   MOTOR_set( a1, a2 );
 756 #endif
 757
 758 #ifdef WORKSTATION
 759   printf ("motor %d -> power=%d\n", a1, a2);
 760   fflush (stdout);
 761 #endif
 762
 763   arg1 = OBJ_FALSE;
 764   arg2 = OBJ_FALSE;
 765 }
 766
 767
 768 void prim_led () {
 769   decode_2_int_args ();
 770   a3 = decode_int (arg3);
 771
 772   if (a1 < 1 || a1 > 3 || a2 < 0 || a3 < 0)
 773     ERROR("led", "argument out of range");
 774
 775 #ifdef PICOBOARD2
 776   LED_set( a1, a2, a3 );
 777 #endif
 778
 779 #ifdef WORKSTATION
 780   printf ("led %d -> duty=%d period=%d\n", a1, a2, a3 );
 781   fflush (stdout);
 782 #endif
 783
 784   arg1 = OBJ_FALSE;
 785   arg2 = OBJ_FALSE;
 786   arg3 = OBJ_FALSE;
 787 }
 788
 789
 790 void prim_led2_color () {
 791   a1 = decode_int (arg1);
 792
 793   if (a1 < 0 || a1 > 1)
 794     ERROR("led2-colors", "argument out of range");
 795
 796 #ifdef PICOBOARD2
 797   LED2_color_set( a1 );
 798 #endif
 799
 800 #ifdef WORKSTATION
 801   printf ("led2-color -> %s\n", (a1==0)?"green":"red");
 802   fflush (stdout);
 803 #endif
 804
 805   arg1 = OBJ_FALSE;
 806 }
 807
 808
 809 void prim_getchar_wait () {
 810   decode_2_int_args();
 811   a1 = read_clock () + a1;
 812
 813   if (a1 < 0 || a2 < 1 || a2 > 3)
 814     ERROR("getchar-wait", "argument out of range");
 815
 816 #ifdef PICOBOARD2
 817   arg1 = OBJ_FALSE;
 818   {
 819     serial_port_set ports;
 820     ports = serial_rx_wait_with_timeout( a2, a1 );
 821     if (ports != 0)
 822       arg1 = encode_int (serial_rx_read( ports ));
 823   }
 824 #endif
 825
 826 #ifdef WORKSTATION
 827 #ifdef _WIN32
 828   arg1 = OBJ_FALSE;
 829   do {
 830     if (_kbhit ())  {
 831       arg1 = encode_int (_getch ());
 832       break;
 833     }
 834   } while (read_clock () < a1);
 835 #else
 836   arg1 = encode_int (getchar ());
 837 #endif
 838 #endif
 839 }
 840
 841
 842 void prim_putchar () {
 843   decode_2_int_args ();
 844
 845   if (a1 < 0 || a1 > 255 || a2 < 1 || a2 > 3)
 846     ERROR("putchar", "argument out of range");
 847
 848 #ifdef PICOBOARD2
 849   serial_tx_write( a2, a1 );
 850 #endif
 851
 852 #ifdef WORKSTATION
 853   putchar (a1);
 854   fflush (stdout);
 855 #endif
 856
 857   arg1 = OBJ_FALSE;
 858   arg2 = OBJ_FALSE;
 859 }
 860
 861
 862 void prim_beep () {
 863   decode_2_int_args ();
 864
 865   if (a1 < 1 || a1 > 255 || a2 < 0)
 866     ERROR("beep", "argument out of range");
 867
 868 #ifdef PICOBOARD2
 869   beep( a1, from_now( a2 ) );
 870 #endif
 871
 872 #ifdef WORKSTATION
 873   printf ("beep -> freq-div=%d duration=%d\n", a1, a2 );
 874   fflush (stdout);
 875 #endif
 876
 877   arg1 = OBJ_FALSE;
 878   arg2 = OBJ_FALSE;
 879 }
 880
 881
 882 void prim_adc () {
 883   short x;
 884
 885   a1 = decode_int (arg1);
 886
 887   if (a1 < 1 || a1 > 3)
 888     ERROR("adc", "argument out of range");
 889
 890 #ifdef PICOBOARD2
 891   x = adc( a1 );
 892 #endif
 893
 894 #ifdef WORKSTATION
 895   x = read_clock () & 255;
 896   if (x > 127) x = 256 - x;
 897   x += 200;
 898 #endif
 899
 900   arg1 = encode_int (x);
 901 }
 902
 903 void prim_sernum () {
 904   short x;
 905
 906 #ifdef PICOBOARD2
 907   x = serial_num ();
 908 #endif
 909
 910 #ifdef WORKSTATION
 911   x = 0;
 912 #endif
 913
 914   arg1 = encode_int (x);
 915 }
 916
 917 /*---------------------------------------------------------------------------*/
 918
 919 // networking primitives
 920
 921 void prim_network_init () { // TODO maybe put in the initialization of the vm
 922 #ifdef NETWORKING
 923   handle = pcap_open_live(INTERFACE, MAX_PACKET_SIZE, PROMISC, TO_MSEC, errbuf);
 924   if (handle == NULL)
 925     ERROR("network-init", "interface not responding");
 926 #endif
 927 }
 928
 929 void prim_network_cleanup () { // TODO maybe put in halt ?
 930 #ifdef NETWORKING
 931   pcap_close(handle);
 932 #endif
 933 }
 934
 935 void prim_receive_packet_to_u8vector () {
 936   // arg1 is the vector in which to put the received packet
 937   if (!RAM_VECTOR(arg1))
 938     TYPE_ERROR("receive-packet-to-u8vector", "vector");
 939
 940 #ifdef NETWORKING
 941   // receive the packet in the buffer
 942   struct pcap_pkthdr header;
 943   const u_char *packet;
 944
 945   packet = pcap_next(handle, &header);
 946
 947   if (packet == NULL)
 948     header.len = 0;
 949
 950   if (ram_get_car (arg1) < header.len)
 951     ERROR("receive-packet-to-u8vector", "packet longer than vector");
 952
 953   if (header.len > 0) { // we have received a packet, write it in the vector
 954     arg2 = rom_get_cdr (arg1);
 955     arg1 = header.len; // we return the length of the received packet
 956     a1 = 0;
 957
 958     while (a1 < arg1) {
 959       ram_set_fieldn (arg2, a1 % 4, (char)packet[a1]);
 960       a1++;
 961       arg2 += (a1 % 4) ? 0 : 1;
 962     }
 963
 964     arg2 = OBJ_FALSE;
 965   }
 966   else // no packet to be read
 967     arg1 = OBJ_FALSE;
 968 #endif
 969 }
 970
 971 void prim_send_packet_from_u8vector () {
 972   // arg1 is the vector which contains the packet to be sent
 973   // arg2 is the length of the packet
 974   // TODO only works with ram vectors for now
 975   if (!RAM_VECTOR(arg1))
 976     TYPE_ERROR("send-packet-from-vector!", "vector");
 977
 978   a2 = decode_int (arg2); // TODO fix for bignums
 979   a1 = 0;
 980
 981   // TODO test if the length of the packet is longer than the length of the vector
 982   if (ram_get_car (arg1) < a2)
 983     ERROR("send-packet-from-u8vector", "packet cannot be longer than vector");
 984
 985   arg1 = ram_get_cdr (arg1);
 986
 987 #ifdef NETWORKING
 988   // copy the packet to the output buffer
 989   while (a1 < a2)
 990     buf[a1] = ram_get_fieldn (arg1, a1 % 4);
 991   // TODO maybe I could just give pcap the pointer to the memory
 992
 993   if (pcap_sendpacket(handle, buf, a2) < 0) // TODO an error has occurred, can we reuse the interface ?
 994     arg1 = OBJ_FALSE;
 995   else
 996     arg1 = OBJ_TRUE;
 997 #endif
 998
 999   arg2 = OBJ_FALSE;
1000 }