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