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