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