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 6",
  21     "prim #%=",
  22     "prim #%<",
  23     "prim 9",
  24     "prim #%>",
  25     "prim 11",
  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 44"
  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   arg1 = mulnonneg (arg1, arg2);
 122 #else
 123   decode_2_int_args ();
 124   arg1 = encode_int (a1 * a2);
 125 #endif
 126   arg2 = OBJ_FALSE;
 127 }
 128
 129 void prim_div () {
 130 #ifdef INFINITE_PRECISION_BIGNUMS
 131   if (obj_eq(arg2, ZERO))
 132     ERROR("quotient", "divide by 0");
 133   arg1 = divnonneg (arg1, arg2);
 134 #else
 135   decode_2_int_args ();
 136   if (a2 == 0)
 137     ERROR("quotient", "divide by 0");
 138   arg1 = encode_int (a1 / a2);
 139 #endif
 140   arg2 = OBJ_FALSE;
 141 }
 142
 143 void prim_rem () {
 144 #ifdef INFINITE_PRECISION_BIGNUMS
 145   if (obj_eq(arg2, ZERO))
 146     ERROR("remainder", "divide by 0");
 147   if (negp(arg1) || negp(arg2))
 148     ERROR("remainder", "only positive numbers are supported");
 149   // TODO fix this to handle negatives
 150   // TODO logic quite similar to mul and div (likely, once we fix), abstract ?
 151   arg3 = divnonneg (arg1, arg2);
 152   arg4 = mulnonneg (arg2, arg3);
 153   arg1 = sub(arg1, arg4);
 154   arg3 = OBJ_FALSE;
 155   arg4 = OBJ_FALSE;
 156 #else
 157   decode_2_int_args ();
 158   if (a2 == 0)
 159     ERROR("remainder", "divide by 0");
 160   arg1 = encode_int (a1 % a2);
 161 #endif
 162   arg2 = OBJ_FALSE;
 163 }
 164
 165 void prim_eq () {
 166 #ifdef INFINITE_PRECISION_BIGNUMS
 167   arg1 = encode_bool(cmp (arg1, arg2) == 1);
 168 #else
 169   decode_2_int_args ();
 170   arg1 = encode_bool(a1 == a2);
 171 #endif
 172   arg2 = OBJ_FALSE;
 173 }
 174
 175 void prim_lt () {
 176 #ifdef INFINITE_PRECISION_BIGNUMS
 177   arg1 = encode_bool(cmp (arg1, arg2) < 1);
 178 #else
 179   decode_2_int_args ();
 180   arg1 = encode_bool(a1 < a2);
 181 #endif
 182   arg2 = OBJ_FALSE;
 183 }
 184
 185 void prim_gt () {
 186 #ifdef INFINITE_PRECISION_BIGNUMS
 187   arg1 = encode_bool(cmp (arg1, arg2) > 1);
 188 #else
 189   decode_2_int_args ();
 190   arg1 = encode_bool(a1 > a2);
 191 #endif
 192   arg2 = OBJ_FALSE;
 193 }
 194
 195 void prim_ior () {
 196 #ifdef INFINITE_PRECISION_BIGNUMS
 197   arg1 = bitwise_ior(arg1, arg2);
 198 #else
 199   decode_2_int_args ();
 200   arg1 = encode_int (a1 | a2);
 201 #endif
 202   arg2 = OBJ_FALSE;
 203 }
 204
 205 void prim_xor () {
 206 #ifdef INFINITE_PRECISION_BIGNUMS
 207   arg1 = bitwise_xor(arg1, arg2);
 208 #else
 209   decode_2_int_args ();
 210   arg1 = encode_int (a1 ^ a2);
 211 #endif
 212   arg2 = OBJ_FALSE;
 213 }
 214
 215 // TODO primitives for shifting ?
 216
 217 /*---------------------------------------------------------------------------*/
 218
 219 // list primitives
 220
 221 void prim_pairp () {
 222   if (IN_RAM(arg1))
 223     arg1 = encode_bool (RAM_PAIR(arg1));
 224   else if (IN_ROM(arg1))
 225     arg1 = encode_bool (ROM_PAIR(arg1));
 226   else
 227     arg1 = OBJ_FALSE;
 228 }
 229
 230 obj cons (obj car, obj cdr) {
 231   return alloc_ram_cell_init (COMPOSITE_FIELD0 | (car >> 8),
 232                               car & 0xff,
 233                               PAIR_FIELD2 | (cdr >> 8),
 234                               cdr & 0xff);
 235 }
 236
 237 void prim_cons () {
 238   arg1 = cons (arg1, arg2);
 239   arg2 = OBJ_FALSE;
 240 }
 241
 242 void prim_car () {
 243   if (IN_RAM(arg1)) {
 244     if (!RAM_PAIR(arg1))
 245       TYPE_ERROR("car.0", "pair");
 246     arg1 = ram_get_car (arg1);
 247   }
 248   else if (IN_ROM(arg1)) {
 249     if (!ROM_PAIR(arg1))
 250       TYPE_ERROR("car.1", "pair");
 251     arg1 = rom_get_car (arg1);
 252   }
 253   else
 254     TYPE_ERROR("car.2", "pair");
 255 }
 256
 257 void prim_cdr () {
 258   if (IN_RAM(arg1)) {
 259     if (!RAM_PAIR(arg1))
 260       TYPE_ERROR("cdr.0", "pair");
 261     arg1 = ram_get_cdr (arg1);
 262   }
 263   else if (IN_ROM(arg1)) {
 264     if (!ROM_PAIR(arg1))
 265       TYPE_ERROR("cdr.1", "pair");
 266     arg1 = rom_get_cdr (arg1);
 267   }
 268   else
 269     TYPE_ERROR("cdr.2", "pair");
 270 }
 271
 272 void prim_set_car () {
 273   if (IN_RAM(arg1)) {
 274     if (!RAM_PAIR(arg1))
 275       TYPE_ERROR("set-car!.0", "pair");
 276
 277     ram_set_car (arg1, arg2);
 278     arg1 = OBJ_FALSE;
 279     arg2 = OBJ_FALSE;
 280   }
 281   else
 282     TYPE_ERROR("set-car!.1", "pair");
 283 }
 284
 285 void prim_set_cdr () {
 286   if (IN_RAM(arg1)) {
 287     if (!RAM_PAIR(arg1))
 288       TYPE_ERROR("set-cdr!.0", "pair");
 289
 290     ram_set_cdr (arg1, arg2);
 291     arg1 = OBJ_FALSE;
 292     arg2 = OBJ_FALSE;
 293   }
 294   else
 295     TYPE_ERROR("set-cdr!.1", "pair");
 296 }
 297
 298 void prim_nullp () {
 299   arg1 = encode_bool (arg1 == OBJ_NULL);
 300 }
 301
 302 /*---------------------------------------------------------------------------*/
 303
 304 // vector primitives
 305
 306 void prim_u8vectorp () {
 307   if (IN_RAM(arg1))
 308     arg1 = encode_bool (RAM_VECTOR(arg1));
 309   else if (IN_ROM(arg1))
 310     arg1 = encode_bool (ROM_VECTOR(arg1));
 311   else
 312     arg1 = OBJ_FALSE;
 313 }
 314
 315 void prim_make_u8vector () {
 316   a1 = decode_int (arg1); // arg1 is length
 317   // TODO adapt for the new bignums
 318
 319   arg2 = alloc_vec_cell (a1);
 320   arg1 = alloc_ram_cell_init (COMPOSITE_FIELD0 | (a1 >> 8),
 321                               a1 & 0xff,
 322                               VECTOR_FIELD2 | (arg2 >> 8),
 323                               arg2 & 0xff);
 324   arg2 = OBJ_FALSE;
 325 }
 326
 327 void prim_u8vector_ref () {
 328   a2 = decode_int (arg2);
 329   // TODO adapt for the new bignums
 330   if (IN_RAM(arg1)) {
 331     if (!RAM_VECTOR(arg1))
 332       TYPE_ERROR("u8vector-ref.0", "vector");
 333     if (ram_get_car (arg1) <= a2)
 334       ERROR("u8vector-ref.0", "vector index invalid");
 335     arg1 = ram_get_cdr (arg1);
 336   }
 337   else if (IN_ROM(arg1)) {
 338     if (!ROM_VECTOR(arg1))
 339       TYPE_ERROR("u8vector-ref.1", "vector");
 340     if (rom_get_car (arg1) <= a2)
 341       ERROR("u8vector-ref.1", "vector index invalid");
 342     arg1 = rom_get_cdr (arg1);
 343   }
 344   else
 345     TYPE_ERROR("u8vector-ref.2", "vector");
 346
 347   if (IN_VEC(arg1)) {
 348     arg1 += (a2 >> 2);
 349     a2 %= 4;
 350
 351     arg1 = encode_int (ram_get_fieldn (arg1, a2));
 352   }
 353   else { // rom vector, stored as a list
 354     while (a2--)
 355       arg1 = rom_get_cdr (arg1);
 356
 357     // the contents are already encoded as fixnums
 358     arg1 = rom_get_car (arg1);
 359   }
 360
 361   arg2 = OBJ_FALSE;
 362   arg3 = OBJ_FALSE;
 363   arg4 = OBJ_FALSE;
 364 }
 365
 366 void prim_u8vector_set () { // TODO a lot in common with ref, abstract that
 367   a2 = decode_int (arg2); // TODO adapt for bignums
 368   a3 = decode_int (arg3);
 369
 370   if (a3 > 255)
 371     ERROR("u8vector-set!", "byte vectors can only contain bytes");
 372
 373   if (IN_RAM(arg1)) {
 374     if (!RAM_VECTOR(arg1))
 375       TYPE_ERROR("u8vector-set!.0", "vector");
 376     if (ram_get_car (arg1) <= a2)
 377       ERROR("u8vector-set!", "vector index invalid");
 378     arg1 = ram_get_cdr (arg1);
 379   }
 380   else
 381     TYPE_ERROR("u8vector-set!.1", "vector");
 382
 383   arg1 += (a2 >> 2);
 384   a2 %= 4;
 385
 386   ram_set_fieldn (arg1, a2, a3);
 387
 388   arg1 = OBJ_FALSE;
 389   arg2 = OBJ_FALSE;
 390   arg3 = OBJ_FALSE;
 391 }
 392
 393 void prim_u8vector_length () {
 394   if (IN_RAM(arg1)) {
 395     if (!RAM_VECTOR(arg1))
 396       TYPE_ERROR("u8vector-length.0", "vector");
 397     arg1 = encode_int (ram_get_car (arg1));
 398   }
 399   else if (IN_ROM(arg1)) {
 400     if (!ROM_VECTOR(arg1))
 401       TYPE_ERROR("u8vector-length.1", "vector");
 402     arg1 = encode_int (rom_get_car (arg1));
 403   }
 404   else
 405     TYPE_ERROR("u8vector-length.2", "vector");
 406 }
 407
 408
 409 /*---------------------------------------------------------------------------*/
 410
 411 // miscellaneous primitives
 412
 413 void prim_eqp () {
 414   arg1 = encode_bool (arg1 == arg2);
 415   arg2 = OBJ_FALSE;
 416 }
 417
 418 void prim_not () {
 419   arg1 = encode_bool (arg1 == OBJ_FALSE);
 420 }
 421
 422 void prim_symbolp () {
 423   if (IN_RAM(arg1))
 424     arg1 = encode_bool (RAM_SYMBOL(arg1));
 425   else if (IN_ROM(arg1))
 426     arg1 = encode_bool (ROM_SYMBOL(arg1));
 427   else
 428     arg1 = OBJ_FALSE;
 429 }
 430
 431 void prim_stringp () {
 432   if (IN_RAM(arg1))
 433     arg1 = encode_bool (RAM_STRING(arg1));
 434   else if (IN_ROM(arg1))
 435     arg1 = encode_bool (ROM_STRING(arg1));
 436   else
 437     arg1 = OBJ_FALSE;
 438 }
 439
 440 void prim_string2list () {
 441   if (IN_RAM(arg1)) {
 442     if (!RAM_STRING(arg1))
 443       TYPE_ERROR("string->list.0", "string");
 444
 445     arg1 = ram_get_car (arg1);
 446   }
 447   else if (IN_ROM(arg1)) {
 448     if (!ROM_STRING(arg1))
 449       TYPE_ERROR("string->list.1", "string");
 450
 451     arg1 = rom_get_car (arg1);
 452     }
 453   else
 454     TYPE_ERROR("string->list.2", "string");
 455 }
 456
 457 void prim_list2string () {
 458   arg1 = alloc_ram_cell_init (COMPOSITE_FIELD0 | ((arg1 & 0x1f00) >> 8),
 459                               arg1 & 0xff,
 460                               STRING_FIELD2,
 461                               0);
 462 }
 463
 464 void prim_booleanp () {
 465   arg1 = encode_bool (arg1 < 2);
 466 }
 467
 468 /*---------------------------------------------------------------------------*/
 469
 470 // robot-specific primitives
 471
 472 #ifdef WORKSTATION
 473
 474 void show (obj o) {
 475 #if 0
 476   printf ("[%d]", o);
 477 #endif
 478
 479   if (o == OBJ_FALSE)
 480     printf ("#f");
 481   else if (o == OBJ_TRUE)
 482     printf ("#t");
 483   else if (o == OBJ_NULL)
 484     printf ("()");
 485   else if (o <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM)))
 486     printf ("%d", DECODE_FIXNUM(o));
 487   else {
 488     uint8 in_ram;
 489
 490     if (IN_RAM(o))
 491       in_ram = 1;
 492     else
 493       in_ram = 0;
 494
 495     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
 496       printf ("%d", decode_int (o));
 497     else if ((in_ram && RAM_COMPOSITE(o)) || (!in_ram && ROM_COMPOSITE(o))) {
 498       obj car;
 499       obj cdr;
 500
 501       if ((in_ram && RAM_PAIR(o)) || (!in_ram && ROM_PAIR(o))) {
 502         if (in_ram) {
 503           car = ram_get_car (o);
 504           cdr = ram_get_cdr (o);
 505         }
 506         else {
 507           car = rom_get_car (o);
 508           cdr = rom_get_cdr (o);
 509         }
 510
 511         printf ("(");
 512
 513       loop:
 514
 515         show (car);
 516
 517         if (cdr == OBJ_NULL)
 518           printf (")");
 519         else if ((IN_RAM(cdr) && RAM_PAIR(cdr))
 520                  || (IN_ROM(cdr) && ROM_PAIR(cdr))) {
 521           if (IN_RAM(cdr)) {
 522             car = ram_get_car (cdr);
 523             cdr = ram_get_cdr (cdr);
 524           }
 525           else {
 526             car = rom_get_car (cdr);
 527             cdr = rom_get_cdr (cdr);
 528           }
 529
 530           printf (" ");
 531           goto loop;
 532         }
 533         else {
 534           printf (" . ");
 535           show (cdr);
 536           printf (")");
 537         }
 538       }
 539       else if ((in_ram && RAM_SYMBOL(o)) || (!in_ram && ROM_SYMBOL(o)))
 540         printf ("#<symbol>");
 541       else if ((in_ram && RAM_STRING(o)) || (!in_ram && ROM_STRING(o)))
 542         printf ("#<string>");
 543       else if ((in_ram && RAM_VECTOR(o)) || (!in_ram && ROM_VECTOR(o)))
 544         printf ("#<vector %d>", o);
 545       else {
 546         printf ("(");
 547         cdr = ram_get_car (o);
 548         car = ram_get_cdr (o);
 549         // ugly hack, takes advantage of the fact that pairs and
 550         // continuations have the same layout
 551         goto loop;
 552       }
 553     }
 554     else { // closure
 555       obj env;
 556       rom_addr pc;
 557
 558       if (IN_RAM(o))
 559         env = ram_get_cdr (o);
 560       else
 561         env = rom_get_cdr (o);
 562
 563       if (IN_RAM(o))
 564         pc = ram_get_entry (o);
 565       else
 566         pc = rom_get_entry (o);
 567
 568       printf ("{0x%04x ", pc);
 569       show (env);
 570       printf ("}");
 571     }
 572   }
 573
 574   fflush (stdout);
 575 }
 576
 577 void print (obj o) {
 578   show (o);
 579   printf ("\n");
 580   fflush (stdout);
 581 }
 582
 583 #endif
 584
 585 void prim_print () {
 586 #ifdef WORKSTATION
 587   print (arg1);
 588 #endif
 589
 590   arg1 = OBJ_FALSE;
 591 }
 592
 593 uint32 read_clock () {
 594   uint32 now = 0;
 595
 596 #ifdef  PICOBOARD2
 597   now = from_now( 0 );
 598 #endif
 599
 600 #ifdef WORKSTATION
 601 #ifdef _WIN32
 602   static int32 start = 0;
 603   struct timeb tb;
 604   ftime (&tb);
 605   now = tb.time * 1000 + tb.millitm;
 606   if (start == 0)
 607     start = now;
 608   now -= start;
 609 #else
 610   static int32 start = 0;
 611   struct timeval tv;
 612   if (gettimeofday (&tv, NULL) == 0) {
 613     now = tv.tv_sec * 1000 + tv.tv_usec / 1000;
 614     if (start == 0)
 615       start = now;
 616     now -= start;
 617   }
 618 #endif
 619 #endif
 620
 621   return now;
 622 }
 623
 624 void prim_clock () {
 625   arg1 = encode_int (read_clock ());
 626 }
 627
 628 void prim_motor () {
 629   decode_2_int_args ();
 630
 631   if (a1 < 1 || a1 > 2 || a2 < -100 || a2 > 100) // TODO since we now use undigned values, we can't go backwards anymore
 632     ERROR("motor", "argument out of range");
 633
 634 #ifdef  PICOBOARD2
 635   MOTOR_set( a1, a2 );
 636 #endif
 637
 638 #ifdef WORKSTATION
 639   printf ("motor %d -> power=%d\n", a1, a2);
 640   fflush (stdout);
 641 #endif
 642
 643   arg1 = OBJ_FALSE;
 644   arg2 = OBJ_FALSE;
 645 }
 646
 647
 648 void prim_led () {
 649   decode_2_int_args ();
 650   a3 = decode_int (arg3);
 651
 652   if (a1 < 1 || a1 > 3)
 653     ERROR("led", "argument out of range");
 654
 655 #ifdef  PICOBOARD2
 656   LED_set( a1, a2, a3 );
 657 #endif
 658
 659 #ifdef WORKSTATION
 660   printf ("led %d -> duty=%d period=%d\n", a1, a2, a3 );
 661   fflush (stdout);
 662 #endif
 663
 664   arg1 = OBJ_FALSE;
 665   arg2 = OBJ_FALSE;
 666   arg3 = OBJ_FALSE;
 667 }
 668
 669
 670 void prim_led2_color () {
 671   a1 = decode_int (arg1);
 672
 673   if (a1 > 1)
 674     ERROR("led2-colors", "argument out of range");
 675
 676 #ifdef PICOBOARD2
 677   LED2_color_set( a1 );
 678 #endif
 679
 680 #ifdef WORKSTATION
 681   printf ("led2-color -> %s\n", (a1==0)?"green":"red");
 682   fflush (stdout);
 683 #endif
 684
 685   arg1 = OBJ_FALSE;
 686 }
 687
 688
 689 void prim_getchar_wait () {
 690   decode_2_int_args();
 691   a1 = read_clock () + a1;
 692
 693   if (a2 < 1 || a2 > 3)
 694     ERROR("getchar-wait", "argument out of range");
 695
 696   arg1 = OBJ_FALSE;
 697
 698 #ifdef PICOBOARD2
 699   {
 700     serial_port_set ports;
 701     ports = serial_rx_wait_with_timeout( a2, a1 );
 702     if (ports != 0)
 703       arg1 = encode_int (serial_rx_read( ports ));
 704   }
 705 #endif
 706
 707 #ifdef WORKSTATION
 708 #ifdef _WIN32
 709   arg1 = OBJ_FALSE;
 710   do {
 711     if (_kbhit ())  {
 712       arg1 = encode_int (_getch ());
 713       break;
 714     }
 715   } while (read_clock () < a1);
 716 #else
 717   arg1 = encode_int (getchar ());
 718 #endif
 719 #endif
 720 }
 721
 722
 723 void prim_putchar () {
 724   decode_2_int_args ();
 725
 726   if (a1 > 255 || a2 < 1 || a2 > 3)
 727     ERROR("putchar", "argument out of range");
 728
 729 #ifdef  PICOBOARD2
 730   serial_tx_write( a2, a1 );
 731 #endif
 732 #ifdef SIXPIC
 733   uart_write(a1);
 734 #endif
 735
 736 #ifdef WORKSTATION
 737   putchar (a1);
 738   fflush (stdout);
 739 #endif
 740
 741   arg1 = OBJ_FALSE;
 742   arg2 = OBJ_FALSE;
 743 }
 744
 745
 746 void prim_beep () {
 747   decode_2_int_args ();
 748
 749   if (a1 < 1 || a1 > 255)
 750     ERROR("beep", "argument out of range");
 751
 752 #ifdef  PICOBOARD2
 753   beep( a1, from_now( a2 ) );
 754 #endif
 755
 756 #ifdef WORKSTATION
 757   printf ("beep -> freq-div=%d duration=%d\n", a1, a2 );
 758   fflush (stdout);
 759 #endif
 760
 761   arg1 = OBJ_FALSE;
 762   arg2 = OBJ_FALSE;
 763 }
 764
 765
 766 void prim_adc () {
 767   uint16 x;
 768
 769   a1 = decode_int (arg1);
 770
 771   if (a1 < 1 || a1 > 3)
 772     ERROR("adc", "argument out of range");
 773
 774 #ifdef  PICOBOARD2
 775   x = adc( a1 );
 776 #endif
 777
 778 #ifdef WORKSTATION
 779   x = read_clock () & 255;
 780   if (x > 127) x = 256 - x;
 781   x += 200;
 782 #endif
 783
 784   arg1 = encode_int (x);
 785 }
 786
 787 void prim_sernum () {
 788   uint16 x;
 789
 790 #ifdef  PICOBOARD2
 791   x = serial_num ();
 792 #endif
 793
 794 #ifdef WORKSTATION
 795   x = 0;
 796 #endif
 797
 798   arg1 = encode_int (x);
 799 }
 800
 801 /*---------------------------------------------------------------------------*/
 802
 803 // networking primitives
 804
 805 void prim_network_init () { // TODO maybe put in the initialization of the vm
 806 #ifdef NETWORKING
 807   handle = pcap_open_live(INTERFACE, MAX_PACKET_SIZE, PROMISC, TO_MSEC, errbuf);
 808   if (handle == NULL)
 809     ERROR("network-init", "interface not responding");
 810 #endif
 811 }
 812
 813 void prim_network_cleanup () { // TODO maybe put in halt ?
 814 #ifdef NETWORKING
 815   pcap_close(handle);
 816 #endif
 817 }
 818
 819 void prim_receive_packet_to_u8vector () {
 820   // arg1 is the vector in which to put the received packet
 821   if (!RAM_VECTOR(arg1))
 822     TYPE_ERROR("receive-packet-to-u8vector", "vector");
 823
 824 #ifdef NETWORKING
 825   // receive the packet in the buffer
 826   struct pcap_pkthdr header;
 827   const u_char *packet;
 828
 829   packet = pcap_next(handle, &header);
 830
 831   if (packet == NULL)
 832     header.len = 0;
 833
 834   if (ram_get_car (arg1) < header.len)
 835     ERROR("receive-packet-to-u8vector", "packet longer than vector");
 836
 837   if (header.len > 0) { // we have received a packet, write it in the vector
 838     arg2 = rom_get_cdr (arg1);
 839     arg1 = header.len; // we return the length of the received packet
 840     a1 = 0;
 841
 842     while (a1 < arg1) {
 843       ram_set_fieldn (arg2, a1 % 4, (char)packet[a1]);
 844       a1++;
 845       arg2 += (a1 % 4) ? 0 : 1;
 846     }
 847
 848     arg2 = OBJ_FALSE;
 849   }
 850   else // no packet to be read
 851     arg1 = OBJ_FALSE;
 852 #endif
 853 }
 854
 855 void prim_send_packet_from_u8vector () {
 856   // arg1 is the vector which contains the packet to be sent
 857   // arg2 is the length of the packet
 858   // TODO only works with ram vectors for now
 859   if (!RAM_VECTOR(arg1))
 860     TYPE_ERROR("send-packet-from-vector!", "vector");
 861
 862   a2 = decode_int (arg2); // TODO fix for bignums
 863   a1 = 0;
 864
 865   // TODO test if the length of the packet is longer than the length of the vector
 866   if (ram_get_car (arg1) < a2)
 867     ERROR("send-packet-from-u8vector", "packet cannot be longer than vector");
 868
 869   arg1 = ram_get_cdr (arg1);
 870
 871 #ifdef NETWORKING
 872   // copy the packet to the output buffer
 873   while (a1 < a2)
 874     buf[a1] = ram_get_fieldn (arg1, a1 % 4);
 875   // TODO maybe I could just give pcap the pointer to the memory
 876
 877   if (pcap_sendpacket(handle, buf, a2) < 0) // TODO an error has occurred, can we reuse the interface ?
 878     arg1 = OBJ_FALSE;
 879   else
 880     arg1 = OBJ_TRUE;
 881 #endif
 882
 883   arg2 = OBJ_FALSE;
 884 }