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) == 1);
 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) < 1);
 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) > 1);
 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) <= 1);
 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) >= 1);
 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 ();
 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 ();
 250   arg1 = encode_int (a1 ^ a2);
 251 #endif
 252   arg2 = OBJ_FALSE;
 253 }
 254
 255 // TODO primitives for shifting ?
 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)
 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)
 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)
 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)) || (ram_get_car (arg3) < (a2 + a3)))
 471       ERROR("u8vector-copy!.0", "vector index invalid");
 472
 473     // position to the start
 474     arg1 = ram_get_cdr (arg1);
 475     arg1 += (a1 >> 2);
 476     a1 %= 4;
 477     arg3 = ram_get_cdr (arg3);
 478     arg3 += (a2 >> 2);
 479     a2 %= 4;
 480
 481     // copy
 482     while (a3--) {
 483       ram_set_fieldn (arg3, a2, ram_get_fieldn (arg1, a1));
 484
 485       a1++;
 486       arg1 += (a1 >> 2);
 487       a1 %= 4; // TODO merge with the previous similar block ?
 488       a2++;
 489       arg3 += (a2 >> 2);
 490       a2 %= 4;
 491     }
 492   }
 493   // case 2 : rom to ram
 494   else if (IN_ROM(arg1) && IN_RAM(arg3)) {
 495     if (!ROM_VECTOR(arg1) || !RAM_VECTOR(arg3))
 496       TYPE_ERROR("u8vector-copy!.1", "vector");
 497     if ((rom_get_car (arg1) < (a1 + a3)) || (ram_get_car (arg3) < (a2 + a3)))
 498       ERROR("u8vector-copy!.1", "vector index invalid");
 499
 500     arg1 = rom_get_cdr (arg1);
 501     while (a1--)
 502       arg1 = rom_get_cdr (arg1);
 503
 504     arg3 = ram_get_cdr (arg3);
 505     arg3 += (a2 >> 2);
 506     a2 %= 4;
 507
 508     while (a3--) {
 509       ram_set_fieldn (arg3, a2, decode_int (rom_get_car (arg1)));
 510
 511       arg1 = rom_get_cdr (arg1);
 512       a2++;
 513       arg3 += (a2 >> 2);
 514       a2 %= 4; // TODO very similar to the other case
 515     }
 516   }
 517   else
 518     TYPE_ERROR("u8vector-copy!.2", "vector");
 519
 520   arg1 = OBJ_FALSE;
 521   arg2 = OBJ_FALSE;
 522   arg3 = OBJ_FALSE;
 523   arg4 = OBJ_FALSE;
 524   arg5 = OBJ_FALSE;
 525 }
 526
 527 /*---------------------------------------------------------------------------*/
 528
 529 // miscellaneous primitives
 530
 531 void prim_eqp () {
 532   arg1 = encode_bool (arg1 == arg2);
 533   arg2 = OBJ_FALSE;
 534 }
 535
 536 void prim_not () {
 537   arg1 = encode_bool (arg1 == OBJ_FALSE);
 538 }
 539
 540 void prim_symbolp () {
 541   if (IN_RAM(arg1))
 542     arg1 = encode_bool (RAM_SYMBOL(arg1));
 543   else if (IN_ROM(arg1))
 544     arg1 = encode_bool (ROM_SYMBOL(arg1));
 545   else
 546     arg1 = OBJ_FALSE;
 547 }
 548
 549 void prim_stringp () {
 550   if (IN_RAM(arg1))
 551     arg1 = encode_bool (RAM_STRING(arg1));
 552   else if (IN_ROM(arg1))
 553     arg1 = encode_bool (ROM_STRING(arg1));
 554   else
 555     arg1 = OBJ_FALSE;
 556 }
 557
 558 void prim_string2list () {
 559   if (IN_RAM(arg1)) {
 560     if (!RAM_STRING(arg1))
 561       TYPE_ERROR("string->list.0", "string");
 562
 563     arg1 = ram_get_car (arg1);
 564   }
 565   else if (IN_ROM(arg1)) {
 566     if (!ROM_STRING(arg1))
 567       TYPE_ERROR("string->list.1", "string");
 568
 569     arg1 = rom_get_car (arg1);
 570     }
 571   else
 572     TYPE_ERROR("string->list.2", "string");
 573 }
 574
 575 void prim_list2string () {
 576   arg1 = alloc_ram_cell_init (COMPOSITE_FIELD0 | ((arg1 & 0x1f00) >> 8),
 577                               arg1 & 0xff,
 578                               STRING_FIELD2,
 579                               0);
 580 }
 581
 582 void prim_booleanp () {
 583   arg1 = encode_bool (arg1 < 2);
 584 }
 585
 586 /*---------------------------------------------------------------------------*/
 587
 588 // robot-specific primitives
 589
 590 #ifdef WORKSTATION
 591
 592 void show (obj o) {
 593 #if 0
 594   printf ("[%d]", o);
 595 #endif
 596
 597   if (o == OBJ_FALSE)
 598     printf ("#f");
 599   else if (o == OBJ_TRUE)
 600     printf ("#t");
 601   else if (o == OBJ_NULL)
 602     printf ("()");
 603   else if (o <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM)))
 604     printf ("%d", DECODE_FIXNUM(o));
 605   else {
 606     uint8 in_ram;
 607
 608     if (IN_RAM(o))
 609       in_ram = 1;
 610     else
 611       in_ram = 0;
 612
 613     if ((in_ram && RAM_BIGNUM(o)) || (!in_ram && ROM_BIGNUM(o))) // TODO fix for new bignums, especially for the sign, a -5 is displayed as 251
 614       printf ("%d", decode_int (o));
 615     else if ((in_ram && RAM_COMPOSITE(o)) || (!in_ram && ROM_COMPOSITE(o))) {
 616       obj car;
 617       obj cdr;
 618
 619       if ((in_ram && RAM_PAIR(o)) || (!in_ram && ROM_PAIR(o))) {
 620         if (in_ram) {
 621           car = ram_get_car (o);
 622           cdr = ram_get_cdr (o);
 623         }
 624         else {
 625           car = rom_get_car (o);
 626           cdr = rom_get_cdr (o);
 627         }
 628
 629         printf ("(");
 630
 631       loop:
 632
 633         show (car);
 634
 635         if (cdr == OBJ_NULL)
 636           printf (")");
 637         else if ((IN_RAM(cdr) && RAM_PAIR(cdr))
 638                  || (IN_ROM(cdr) && ROM_PAIR(cdr))) {
 639           if (IN_RAM(cdr)) {
 640             car = ram_get_car (cdr);
 641             cdr = ram_get_cdr (cdr);
 642           }
 643           else {
 644             car = rom_get_car (cdr);
 645             cdr = rom_get_cdr (cdr);
 646           }
 647
 648           printf (" ");
 649           goto loop;
 650         }
 651         else {
 652           printf (" . ");
 653           show (cdr);
 654           printf (")");
 655         }
 656       }
 657       else if ((in_ram && RAM_SYMBOL(o)) || (!in_ram && ROM_SYMBOL(o)))
 658         printf ("#<symbol>");
 659       else if ((in_ram && RAM_STRING(o)) || (!in_ram && ROM_STRING(o)))
 660         printf ("#<string>");
 661       else if ((in_ram && RAM_VECTOR(o)) || (!in_ram && ROM_VECTOR(o)))
 662         printf ("#<vector %d>", o);
 663       else {
 664         printf ("(");
 665         cdr = ram_get_car (o);
 666         car = ram_get_cdr (o);
 667         // ugly hack, takes advantage of the fact that pairs and
 668         // continuations have the same layout
 669         goto loop;
 670       }
 671     }
 672     else { // closure
 673       obj env;
 674       rom_addr pc;
 675
 676       if (IN_RAM(o))
 677         env = ram_get_cdr (o);
 678       else
 679         env = rom_get_cdr (o);
 680
 681       if (IN_RAM(o))
 682         pc = ram_get_entry (o);
 683       else
 684         pc = rom_get_entry (o);
 685
 686       printf ("{0x%04x ", pc);
 687       show (env);
 688       printf ("}");
 689     }
 690   }
 691
 692   fflush (stdout);
 693 }
 694
 695 void print (obj o) {
 696   show (o);
 697   printf ("\n");
 698   fflush (stdout);
 699 }
 700
 701 #endif
 702
 703 void prim_print () {
 704 #ifdef WORKSTATION
 705   print (arg1);
 706 #endif
 707
 708   arg1 = OBJ_FALSE;
 709 }
 710
 711 uint32 read_clock () {
 712   uint32 now = 0;
 713
 714 #ifdef  PICOBOARD2
 715   now = from_now( 0 );
 716 #endif
 717
 718 #ifdef WORKSTATION
 719 #ifdef _WIN32
 720   static int32 start = 0;
 721   struct timeb tb;
 722   ftime (&tb);
 723   now = tb.time * 1000 + tb.millitm;
 724   if (start == 0)
 725     start = now;
 726   now -= start;
 727 #else
 728   static int32 start = 0;
 729   struct timeval tv;
 730   if (gettimeofday (&tv, NULL) == 0) {
 731     now = tv.tv_sec * 1000 + tv.tv_usec / 1000;
 732     if (start == 0)
 733       start = now;
 734     now -= start;
 735   }
 736 #endif
 737 #endif
 738
 739   return now;
 740 }
 741
 742 void prim_clock () {
 743   arg1 = encode_int (read_clock ());
 744 }
 745
 746 void prim_motor () {
 747   decode_2_int_args ();
 748
 749   if (a1 < 1 || a1 > 2 || a2 < -100 || a2 > 100) // TODO since we now use undigned values, we can't go backwards anymore
 750     ERROR("motor", "argument out of range");
 751
 752 #ifdef  PICOBOARD2
 753   MOTOR_set( a1, a2 );
 754 #endif
 755
 756 #ifdef WORKSTATION
 757   printf ("motor %d -> power=%d\n", a1, a2);
 758   fflush (stdout);
 759 #endif
 760
 761   arg1 = OBJ_FALSE;
 762   arg2 = OBJ_FALSE;
 763 }
 764
 765
 766 void prim_led () {
 767   decode_2_int_args ();
 768   a3 = decode_int (arg3);
 769
 770   if (a1 < 1 || a1 > 3)
 771     ERROR("led", "argument out of range");
 772
 773 #ifdef  PICOBOARD2
 774   LED_set( a1, a2, a3 );
 775 #endif
 776
 777 #ifdef WORKSTATION
 778   printf ("led %d -> duty=%d period=%d\n", a1, a2, a3 );
 779   fflush (stdout);
 780 #endif
 781
 782   arg1 = OBJ_FALSE;
 783   arg2 = OBJ_FALSE;
 784   arg3 = OBJ_FALSE;
 785 }
 786
 787
 788 void prim_led2_color () {
 789   a1 = decode_int (arg1);
 790
 791   if (a1 > 1)
 792     ERROR("led2-colors", "argument out of range");
 793
 794 #ifdef PICOBOARD2
 795   LED2_color_set( a1 );
 796 #endif
 797
 798 #ifdef WORKSTATION
 799   printf ("led2-color -> %s\n", (a1==0)?"green":"red");
 800   fflush (stdout);
 801 #endif
 802
 803   arg1 = OBJ_FALSE;
 804 }
 805
 806
 807 void prim_getchar_wait () {
 808   decode_2_int_args();
 809   a1 = read_clock () + a1;
 810
 811   if (a2 < 1 || a2 > 3)
 812     ERROR("getchar-wait", "argument out of range");
 813
 814   arg1 = OBJ_FALSE;
 815
 816 #ifdef PICOBOARD2
 817   {
 818     serial_port_set ports;
 819     ports = serial_rx_wait_with_timeout( a2, a1 );
 820     if (ports != 0)
 821       arg1 = encode_int (serial_rx_read( ports ));
 822   }
 823 #endif
 824
 825 #ifdef WORKSTATION
 826 #ifdef _WIN32
 827   arg1 = OBJ_FALSE;
 828   do {
 829     if (_kbhit ())  {
 830       arg1 = encode_int (_getch ());
 831       break;
 832     }
 833   } while (read_clock () < a1);
 834 #else
 835   arg1 = encode_int (getchar ());
 836 #endif
 837 #endif
 838 }
 839
 840
 841 void prim_putchar () {
 842   decode_2_int_args ();
 843
 844   if (a1 > 255 || a2 < 1 || a2 > 3)
 845     ERROR("putchar", "argument out of range");
 846
 847 #ifdef  PICOBOARD2
 848   serial_tx_write( a2, a1 );
 849 #endif
 850 #ifdef SIXPIC
 851   uart_write(a1);
 852 #endif
 853
 854 #ifdef WORKSTATION
 855   putchar (a1);
 856   fflush (stdout);
 857 #endif
 858
 859   arg1 = OBJ_FALSE;
 860   arg2 = OBJ_FALSE;
 861 }
 862
 863
 864 void prim_beep () {
 865   decode_2_int_args ();
 866
 867   if (a1 < 1 || a1 > 255)
 868     ERROR("beep", "argument out of range");
 869
 870 #ifdef  PICOBOARD2
 871   beep( a1, from_now( a2 ) );
 872 #endif
 873
 874 #ifdef WORKSTATION
 875   printf ("beep -> freq-div=%d duration=%d\n", a1, a2 );
 876   fflush (stdout);
 877 #endif
 878
 879   arg1 = OBJ_FALSE;
 880   arg2 = OBJ_FALSE;
 881 }
 882
 883
 884 void prim_adc () {
 885   uint16 x;
 886
 887   a1 = decode_int (arg1);
 888
 889   if (a1 < 1 || a1 > 3)
 890     ERROR("adc", "argument out of range");
 891
 892 #ifdef  PICOBOARD2
 893   x = adc( a1 );
 894 #endif
 895
 896 #ifdef WORKSTATION
 897   x = read_clock () & 255;
 898   if (x > 127) x = 256 - x;
 899   x += 200;
 900 #endif
 901
 902   arg1 = encode_int (x);
 903 }
 904
 905 void prim_sernum () {
 906   uint16 x;
 907
 908 #ifdef  PICOBOARD2
 909   x = serial_num ();
 910 #endif
 911
 912 #ifdef WORKSTATION
 913   x = 0;
 914 #endif
 915
 916   arg1 = encode_int (x);
 917 }
 918
 919 /*---------------------------------------------------------------------------*/
 920
 921 // networking primitives
 922
 923 void prim_network_init () { // TODO maybe put in the initialization of the vm
 924 #ifdef NETWORKING
 925   handle = pcap_open_live(INTERFACE, MAX_PACKET_SIZE, PROMISC, TO_MSEC, errbuf);
 926   if (handle == NULL)
 927     ERROR("network-init", "interface not responding");
 928 #endif
 929 }
 930
 931 void prim_network_cleanup () { // TODO maybe put in halt ?
 932 #ifdef NETWORKING
 933   pcap_close(handle);
 934 #endif
 935 }
 936
 937 void prim_receive_packet_to_u8vector () {
 938   // arg1 is the vector in which to put the received packet
 939   if (!RAM_VECTOR(arg1))
 940     TYPE_ERROR("receive-packet-to-u8vector", "vector");
 941
 942 #ifdef NETWORKING
 943   // receive the packet in the buffer
 944   struct pcap_pkthdr header;
 945   const u_char *packet;
 946
 947   packet = pcap_next(handle, &header);
 948
 949   if (packet == NULL)
 950     header.len = 0;
 951
 952   if (ram_get_car (arg1) < header.len)
 953     ERROR("receive-packet-to-u8vector", "packet longer than vector");
 954
 955   if (header.len > 0) { // we have received a packet, write it in the vector
 956     arg2 = rom_get_cdr (arg1);
 957     arg1 = header.len; // we return the length of the received packet
 958     a1 = 0;
 959
 960     while (a1 < arg1) {
 961       ram_set_fieldn (arg2, a1 % 4, (char)packet[a1]);
 962       a1++;
 963       arg2 += (a1 % 4) ? 0 : 1;
 964     }
 965
 966     arg2 = OBJ_FALSE;
 967   }
 968   else // no packet to be read
 969     arg1 = OBJ_FALSE;
 970 #endif
 971 }
 972
 973 void prim_send_packet_from_u8vector () {
 974   // arg1 is the vector which contains the packet to be sent
 975   // arg2 is the length of the packet
 976   // TODO only works with ram vectors for now
 977   if (!RAM_VECTOR(arg1))
 978     TYPE_ERROR("send-packet-from-vector!", "vector");
 979
 980   a2 = decode_int (arg2); // TODO fix for bignums
 981   a1 = 0;
 982
 983   // TODO test if the length of the packet is longer than the length of the vector
 984   if (ram_get_car (arg1) < a2)
 985     ERROR("send-packet-from-u8vector", "packet cannot be longer than vector");
 986
 987   arg1 = ram_get_cdr (arg1);
 988
 989 #ifdef NETWORKING
 990   // copy the packet to the output buffer
 991   while (a1 < a2)
 992     buf[a1] = ram_get_fieldn (arg1, a1 % 4);
 993   // TODO maybe I could just give pcap the pointer to the memory
 994
 995   if (pcap_sendpacket(handle, buf, a2) < 0) // TODO an error has occurred, can we reuse the interface ?
 996     arg1 = OBJ_FALSE;
 997   else
 998     arg1 = OBJ_TRUE;
 999 #endif
1000
1001   arg2 = OBJ_FALSE;
1002 }