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