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 #%mul-non-neg",
  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_non_neg () {
 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_non_neg () {
 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       env = ram_get_car (o);
 559       pc = ram_get_entry (o);
 560
 561       printf ("{0x%04x ", pc);
 562       show (env);
 563       printf ("}");
 564     }
 565   }
 566
 567   fflush (stdout);
 568 }
 569
 570 void print (obj o) {
 571   show (o);
 572   printf ("\n");
 573   fflush (stdout);
 574 }
 575
 576 #endif
 577
 578 void prim_print () {
 579 #ifdef WORKSTATION
 580   print (arg1);
 581 #endif
 582
 583   arg1 = OBJ_FALSE;
 584 }
 585
 586 uint32 read_clock () {
 587   uint32 now = 0;
 588
 589 #ifdef  PICOBOARD2
 590   now = from_now( 0 );
 591 #endif
 592
 593 #ifdef WORKSTATION
 594 #ifdef _WIN32
 595   static int32 start = 0;
 596   struct timeb tb;
 597   ftime (&tb);
 598   now = tb.time * 1000 + tb.millitm;
 599   if (start == 0)
 600     start = now;
 601   now -= start;
 602 #else
 603   static int32 start = 0;
 604   struct timeval tv;
 605   if (gettimeofday (&tv, NULL) == 0) {
 606     now = tv.tv_sec * 1000 + tv.tv_usec / 1000;
 607     if (start == 0)
 608       start = now;
 609     now -= start;
 610   }
 611 #endif
 612 #endif
 613
 614   return now;
 615 }
 616
 617 void prim_clock () {
 618   arg1 = encode_int (read_clock ());
 619 }
 620
 621 void prim_motor () {
 622   decode_2_int_args ();
 623
 624   if (a1 < 1 || a1 > 2 || a2 < -100 || a2 > 100) // TODO since we now use undigned values, we can't go backwards anymore
 625     ERROR("motor", "argument out of range");
 626
 627 #ifdef  PICOBOARD2
 628   MOTOR_set( a1, a2 );
 629 #endif
 630
 631 #ifdef WORKSTATION
 632   printf ("motor %d -> power=%d\n", a1, a2);
 633   fflush (stdout);
 634 #endif
 635
 636   arg1 = OBJ_FALSE;
 637   arg2 = OBJ_FALSE;
 638 }
 639
 640
 641 void prim_led () {
 642   decode_2_int_args ();
 643   a3 = decode_int (arg3);
 644
 645   if (a1 < 1 || a1 > 3)
 646     ERROR("led", "argument out of range");
 647
 648 #ifdef  PICOBOARD2
 649   LED_set( a1, a2, a3 );
 650 #endif
 651
 652 #ifdef WORKSTATION
 653   printf ("led %d -> duty=%d period=%d\n", a1, a2, a3 );
 654   fflush (stdout);
 655 #endif
 656
 657   arg1 = OBJ_FALSE;
 658   arg2 = OBJ_FALSE;
 659   arg3 = OBJ_FALSE;
 660 }
 661
 662
 663 void prim_led2_color () {
 664   a1 = decode_int (arg1);
 665
 666   if (a1 > 1)
 667     ERROR("led2-colors", "argument out of range");
 668
 669 #ifdef PICOBOARD2
 670   LED2_color_set( a1 );
 671 #endif
 672
 673 #ifdef WORKSTATION
 674   printf ("led2-color -> %s\n", (a1==0)?"green":"red");
 675   fflush (stdout);
 676 #endif
 677
 678   arg1 = OBJ_FALSE;
 679 }
 680
 681
 682 void prim_getchar_wait () {
 683   decode_2_int_args();
 684   a1 = read_clock () + a1;
 685
 686   if (a2 < 1 || a2 > 3)
 687     ERROR("getchar-wait", "argument out of range");
 688
 689   arg1 = OBJ_FALSE;
 690
 691 #ifdef PICOBOARD2
 692   {
 693     serial_port_set ports;
 694     ports = serial_rx_wait_with_timeout( a2, a1 );
 695     if (ports != 0)
 696       arg1 = encode_int (serial_rx_read( ports ));
 697   }
 698 #endif
 699
 700 #ifdef WORKSTATION
 701 #ifdef _WIN32
 702   arg1 = OBJ_FALSE;
 703   do {
 704     if (_kbhit ())  {
 705       arg1 = encode_int (_getch ());
 706       break;
 707     }
 708   } while (read_clock () < a1);
 709 #else
 710   arg1 = encode_int (getchar ());
 711 #endif
 712 #endif
 713 }
 714
 715
 716 void prim_putchar () {
 717   decode_2_int_args ();
 718
 719   if (a1 > 255 || a2 < 1 || a2 > 3)
 720     ERROR("putchar", "argument out of range");
 721
 722 #ifdef  PICOBOARD2
 723   serial_tx_write( a2, a1 );
 724 #endif
 725 #ifdef SIXPIC
 726   uart_write(a1);
 727 #endif
 728
 729 #ifdef WORKSTATION
 730   putchar (a1);
 731   fflush (stdout);
 732 #endif
 733
 734   arg1 = OBJ_FALSE;
 735   arg2 = OBJ_FALSE;
 736 }
 737
 738
 739 void prim_beep () {
 740   decode_2_int_args ();
 741
 742   if (a1 < 1 || a1 > 255)
 743     ERROR("beep", "argument out of range");
 744
 745 #ifdef  PICOBOARD2
 746   beep( a1, from_now( a2 ) );
 747 #endif
 748
 749 #ifdef WORKSTATION
 750   printf ("beep -> freq-div=%d duration=%d\n", a1, a2 );
 751   fflush (stdout);
 752 #endif
 753
 754   arg1 = OBJ_FALSE;
 755   arg2 = OBJ_FALSE;
 756 }
 757
 758
 759 void prim_adc () {
 760   uint16 x;
 761
 762   a1 = decode_int (arg1);
 763
 764   if (a1 < 1 || a1 > 3)
 765     ERROR("adc", "argument out of range");
 766
 767 #ifdef  PICOBOARD2
 768   x = adc( a1 );
 769 #endif
 770
 771 #ifdef WORKSTATION
 772   x = read_clock () & 255;
 773   if (x > 127) x = 256 - x;
 774   x += 200;
 775 #endif
 776
 777   arg1 = encode_int (x);
 778 }
 779
 780 void prim_sernum () {
 781   uint16 x;
 782
 783 #ifdef  PICOBOARD2
 784   x = serial_num ();
 785 #endif
 786
 787 #ifdef WORKSTATION
 788   x = 0;
 789 #endif
 790
 791   arg1 = encode_int (x);
 792 }
 793
 794 /*---------------------------------------------------------------------------*/
 795
 796 // networking primitives
 797
 798 void prim_network_init () { // TODO maybe put in the initialization of the vm
 799 #ifdef NETWORKING
 800   handle = pcap_open_live(INTERFACE, MAX_PACKET_SIZE, PROMISC, TO_MSEC, errbuf);
 801   if (handle == NULL)
 802     ERROR("network-init", "interface not responding");
 803 #endif
 804 }
 805
 806 void prim_network_cleanup () { // TODO maybe put in halt ?
 807 #ifdef NETWORKING
 808   pcap_close(handle);
 809 #endif
 810 }
 811
 812 void prim_receive_packet_to_u8vector () {
 813   // arg1 is the vector in which to put the received packet
 814   if (!RAM_VECTOR(arg1))
 815     TYPE_ERROR("receive-packet-to-u8vector", "vector");
 816
 817 #ifdef NETWORKING
 818   // receive the packet in the buffer
 819   struct pcap_pkthdr header;
 820   const u_char *packet;
 821
 822   packet = pcap_next(handle, &header);
 823
 824   if (packet == NULL)
 825     header.len = 0;
 826
 827   if (ram_get_car (arg1) < header.len)
 828     ERROR("receive-packet-to-u8vector", "packet longer than vector");
 829
 830   if (header.len > 0) { // we have received a packet, write it in the vector
 831     arg2 = rom_get_cdr (arg1);
 832     arg1 = header.len; // we return the length of the received packet
 833     a1 = 0;
 834
 835     while (a1 < arg1) {
 836       ram_set_fieldn (arg2, a1 % 4, (char)packet[a1]);
 837       a1++;
 838       arg2 += (a1 % 4) ? 0 : 1;
 839     }
 840
 841     arg2 = OBJ_FALSE;
 842   }
 843   else // no packet to be read
 844     arg1 = OBJ_FALSE;
 845 #endif
 846 }
 847
 848 void prim_send_packet_from_u8vector () {
 849   // arg1 is the vector which contains the packet to be sent
 850   // arg2 is the length of the packet
 851   // TODO only works with ram vectors for now
 852   if (!RAM_VECTOR(arg1))
 853     TYPE_ERROR("send-packet-from-vector!", "vector");
 854
 855   a2 = decode_int (arg2); // TODO fix for bignums
 856   a1 = 0;
 857
 858   // TODO test if the length of the packet is longer than the length of the vector
 859   if (ram_get_car (arg1) < a2)
 860     ERROR("send-packet-from-u8vector", "packet cannot be longer than vector");
 861
 862   arg1 = ram_get_cdr (arg1);
 863
 864 #ifdef NETWORKING
 865   // copy the packet to the output buffer
 866   while (a1 < a2)
 867     buf[a1] = ram_get_fieldn (arg1, a1 % 4);
 868   // TODO maybe I could just give pcap the pointer to the memory
 869
 870   if (pcap_sendpacket(handle, buf, a2) < 0) // TODO an error has occurred, can we reuse the interface ?
 871     arg1 = OBJ_FALSE;
 872   else
 873     arg1 = OBJ_TRUE;
 874 #endif
 875
 876   arg2 = OBJ_FALSE;
 877 }