picobit-vm.c

   1 /* file: "picobit-vm.c" */
   2
   3 /*
   4  * Copyright 2004 by Marc Feeley, All Rights Reserved.
   5  *
   6  * History:
   7  *
   8  *   15/08/2004  Release of version 1
   9  *   6/07/2008  Modified for PICOBOARD2_R3
  10  */
  11
  12 #define DEBUG_not
  13 #define DEBUG_GC_not
  14
  15 /*---------------------------------------------------------------------------*/
  16
  17 typedef char int8;
  18 typedef short int16;
  19 typedef long int32;
  20 typedef unsigned char uint8;
  21 typedef unsigned short uint16;
  22 typedef unsigned long uint32;
  23
  24 /*---------------------------------------------------------------------------*/
  25
  26
  27 #ifdef PICOBOARD2
  28 #define ROBOT
  29 #endif
  30
  31 #ifdef HI_TECH_C
  32 #define ROBOT
  33 #endif
  34
  35 #ifndef ROBOT
  36 #define WORKSTATION
  37 #endif
  38
  39
  40 #ifdef HI_TECH_C
  41
  42 #include <pic18.h>
  43
  44 static volatile near uint8 FW_VALUE_UP       @ 0x33;
  45 static volatile near uint8 FW_VALUE_HI       @ 0x33;
  46 static volatile near uint8 FW_VALUE_LO       @ 0x33;
  47
  48 #define ACTIVITY_LED1_LAT LATB
  49 #define ACTIVITY_LED1_BIT 5
  50 #define ACTIVITY_LED2_LAT LATB
  51 #define ACTIVITY_LED2_BIT 4
  52 static volatile near bit ACTIVITY_LED1 @ ((unsigned)&ACTIVITY_LED1_LAT*8)+ACTIVITY_LED1_BIT;
  53 static volatile near bit ACTIVITY_LED2 @ ((unsigned)&ACTIVITY_LED2_LAT*8)+ACTIVITY_LED2_BIT;
  54
  55 #endif
  56
  57
  58 #ifdef WORKSTATION
  59
  60 #include <stdio.h>
  61 #include <stdlib.h>
  62
  63 #ifdef _WIN32
  64 #include <sys/types.h>
  65 #include <sys/timeb.h>
  66 #include <conio.h>
  67 #else
  68 #include <sys/time.h>
  69 #endif
  70
  71 #endif
  72
  73
  74 /*---------------------------------------------------------------------------*/
  75
  76 #define WORD_BITS 8
  77
  78 #define CODE_START 0x5000
  79
  80 #define GLOVARS 16
  81
  82 #ifdef DEBUG
  83 #define IF_TRACE(x) x
  84 #define IF_GC_TRACE(x)
  85 #else
  86 #define IF_TRACE(x)
  87 #define IF_GC_TRACE(x)
  88 #endif
  89
  90 /*---------------------------------------------------------------------------*/
  91
  92
  93 #ifdef PICOBOARD2
  94
  95 #define ERROR(msg) halt_with_error()
  96 #define TYPE_ERROR(type) halt_with_error()
  97
  98 #endif
  99
 100
 101 #ifdef WORKSTATION
 102
 103 #define ERROR(msg) error (msg)
 104 #define TYPE_ERROR(type) type_error (type)
 105
 106 void error (char *msg)
 107 {
 108   printf ("ERROR: %s\n", msg);
 109   exit (1);
 110 }
 111
 112 void type_error (char *type)
 113 {
 114   printf ("ERROR: An argument of type %s was expected\n", type);
 115   exit (1);
 116 }
 117
 118 #endif
 119
 120
 121 /*---------------------------------------------------------------------------*/
 122
 123 #if WORD_BITS <= 8
 124 typedef uint8 word;
 125 #else
 126 typedef uint16 word;
 127 #endif
 128
 129 typedef uint16 ram_addr;
 130 typedef uint16 rom_addr;
 131
 132 typedef uint16 obj;
 133
 134 /*---------------------------------------------------------------------------*/
 135
 136 #define MIN_RAM_ENCODING 128
 137 #define MAX_RAM_ENCODING 8192
 138 // TODO some space in rom is not used, use for fixnums ?
 139 #define RAM_BYTES ((MAX_RAM_ENCODING - MIN_RAM_ENCODING + 1)*4)
 140
 141 // TODO change if we change the proportion of rom and ram addresses
 142 #if WORD_BITS == 8
 143 #define OBJ_TO_RAM_ADDR(o,f) (((ram_addr)((uint16)(o) - MIN_RAM_ENCODING) << 2) + (f))
 144 #define OBJ_TO_ROM_ADDR(o,f) (((rom_addr)((uint8)(o) - MIN_ROM_ENCODING) << 2) + (CODE_START + 4 + (f)))
 145 #endif
 146
 147
 148 #ifdef PICOBOARD2
 149
 150 #if 0
 151 #pragma udata picobit_heap=0x200
 152 uint8 ram_mem[RAM_BYTES];
 153 #pragma udata
 154 #endif
 155
 156 #define ram_get(a) *(uint8*)(a+0x200)
 157 #define ram_set(a,x) *(uint8*)(a+0x200) = (x)
 158
 159 #endif
 160
 161
 162 #ifdef WORKSTATION
 163
 164 uint8 ram_mem[RAM_BYTES];
 165
 166 #define ram_get(a) ram_mem[a]
 167 #define ram_set(a,x) ram_mem[a] = (x)
 168
 169 #endif
 170
 171
 172 /*---------------------------------------------------------------------------*/
 173
 174 #ifdef PICOBOARD2
 175
 176 #if WORD_BITS == 8
 177 #endif
 178
 179 uint8 rom_get (rom_addr a)
 180 {
 181   return *(rom uint8*)a;
 182 }
 183
 184 #endif
 185
 186
 187 #ifdef WORKSTATION
 188
 189 #define ROM_BYTES 8192
 190
 191 uint8 rom_mem[ROM_BYTES] =
 192   {
 193 #define RED_GREEN
 194 #define PUTCHAR_LIGHT_not
 195
 196 #ifdef RED_GREEN
 197     0xFB, 0xD7, 0x03, 0x00, 0x00, 0x00, 0x00, 0x32
 198     , 0x03, 0x00, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00
 199     , 0x08, 0x50, 0x80, 0x16, 0xFE, 0xE8, 0x00, 0xFC
 200     , 0x32, 0x80, 0x2D, 0xFE, 0xFC, 0x31, 0x80, 0x43
 201     , 0xFE, 0xFC, 0x33, 0x80, 0x2D, 0xFE, 0xFC, 0x31
 202     , 0x80, 0x43, 0xFE, 0x90, 0x16, 0x01, 0x20, 0xFC
 203     , 0x32, 0xE3, 0xB0, 0x37, 0x09, 0xF3, 0xFF, 0x20
 204     , 0xFC, 0x33, 0xE3, 0xB0, 0x40, 0x0A, 0xF3, 0xFF
 205     , 0x08, 0xF3, 0xFF, 0x01, 0x40, 0x21, 0xD1, 0x00
 206     , 0x02, 0xC0, 0x4C, 0x71, 0x01, 0x20, 0x50, 0x90
 207     , 0x51, 0x00, 0xF1, 0x40, 0xD8, 0xB0, 0x59, 0x90
 208     , 0x51, 0x00, 0xFF
 209 #endif
 210 #ifdef PUTCHAR_LIGHT
 211     0xFB, 0xD7, 0x00, 0x00, 0x80, 0x08, 0xFE, 0xE8
 212     , 0x00, 0xF6, 0xF5, 0x90, 0x08
 213 #endif
 214   };
 215
 216 uint8 rom_get (rom_addr a)
 217 {
 218   return rom_mem[a-CODE_START];
 219 }
 220
 221 #endif
 222
 223 obj globals[GLOVARS];
 224
 225 /*---------------------------------------------------------------------------*/
 226
 227 /*
 228   OBJECT ENCODING:
 229
 230   #f           0
 231   #t           1
 232   ()           2
 233   fixnum n     MIN_FIXNUM -> 3 ... MAX_FIXNUM -> 3 + (MAX_FIXNUM-MIN_FIXNUM)
 234   TODO do we want 0..127 as fixnums ? would reduce number of ra/om objects
 235   rom object   4 + (MAX_FIXNUM-MIN_FIXNUM) ... MIN_RAM_ENCODING-1
 236   ram object   MIN_RAM_ENCODING ... 4095 TODO was 255, now we have 12 bits
 237
 238   layout of memory allocated objects:
 239
 240   G's represent mark bits used by the gc TODO change GC, and does not use the same bits
 241
 242   bignum n     00G00000 uuuuuuuu hhhhhhhh llllllll  (24 bit signed integer)
 243   TODO we could have 29-bit integers
 244
 245   pair         1GGaaaaa aaaaaaaa 000ddddd dddddddd
 246   TODO was 00000010 aaaaaaaa aaaadddd dddddddd
 247   a is car
 248   d is cdr
 249   gives an address space of 2^13 * 4 = 32k (not all of it is for RAM, though)
 250
 251   symbol       1GG00000 00000000 00100000 00000000
 252
 253   string       1GG***** *chars** 01000000 00000000
 254
 255   vector       1GG***** *elems** 01100000 00000000 TODO not used yet
 256
 257   closure      01Gxxxxx xxxxxxxx aaaaaaaa aaaaaaaa TODO OLD
 258   closure      01Gaaaaa aaaaaaaa aaaxxxxx xxxxxxxx
 259   0x5ff<a<0x4000 is entry
 260   x is pointer to environment
 261   the reason why the environment is on the cdr (and the entry is split on 3
 262   bytes) is that, when looking for a variable, a closure is considered to be a
 263   pair. The compiler adds an extra offset to any variable in the closure's
 264   environment, so the car of the closure (which doesn't really exist) is never
 265   checked, but the cdr is followed to find the other bindings
 266
 267   continuation 01Gxxxxx xxxxxxxx aaaaaaaa aaaaaaaa  0x5ff<a<0x4000 is pc TODO old
 268   continuation 01Gxxxxx xxxxxxxx 100yyyyy yyyyyyyy
 269   x is parent continuation
 270   y is pointer to the second half, which is a closure (contains env and entry)
 271
 272   An environment is a list of objects built out of pairs.  On entry to
 273   a procedure the environment is the list of parameters to which is
 274   added the environment of the closure being called.
 275
 276   The first byte at the entry point of a procedure gives the arity of
 277   the procedure:
 278
 279   n = 0 to 127    -> procedure has n parameters (no rest parameter)
 280   n = -128 to -1  -> procedure has -n parameters, the last is
 281   a rest parameter
 282 */
 283
 284 #define OBJ_FALSE 0
 285 #define OBJ_TRUE  1
 286 #define OBJ_NULL  2
 287
 288 #define MIN_FIXNUM_ENCODING 3
 289 #define MIN_FIXNUM (-5)
 290 #define MAX_FIXNUM 40
 291 #define MIN_ROM_ENCODING (MIN_FIXNUM_ENCODING+MAX_FIXNUM-MIN_FIXNUM+1)
 292
 293 #define ENCODE_FIXNUM(n) ((obj)(n) + (MIN_FIXNUM_ENCODING - MIN_FIXNUM))
 294 #define DECODE_FIXNUM(o) ((int32)(o) - (MIN_FIXNUM_ENCODING - MIN_FIXNUM))
 295
 296 #if WORD_BITS == 8
 297 #define IN_RAM(o) ((o) >= MIN_RAM_ENCODING)
 298 #define IN_ROM(o) ((int8)(o) >= MIN_ROM_ENCODING)
 299 #endif
 300
 301 // bignum first byte : 00G00000
 302 #define BIGNUM_FIELD0 0
 303 #define RAM_BIGNUM(o) ((ram_get_field0 (o) & 0xc0) == BIGNUM_FIELD0)
 304 #define ROM_BIGNUM(o) ((rom_get_field0 (o) & 0xc0) == BIGNUM_FIELD0)
 305
 306 // composite first byte : 1GGxxxxx
 307 #define COMPOSITE_FIELD0 0x80
 308 #define RAM_COMPOSITE(o) ((ram_get_field0 (o) & 0x80) == COMPOSITE_FIELD0)
 309 #define ROM_COMPOSITE(o) ((rom_get_field0 (o) & 0x80) == COMPOSITE_FIELD0)
 310
 311 // pair third byte : 000xxxxx
 312 #define PAIR_FIELD2 0
 313 #define RAM_PAIR(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == PAIR_FIELD2))
 314 #define ROM_PAIR(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == PAIR_FIELD2))
 315
 316 // symbol third byte : 001xxxxx
 317 #define SYMBOL_FIELD2 0x20
 318 #define RAM_SYMBOL(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == SYMBOL_FIELD2))
 319 #define ROM_SYMBOL(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == SYMBOL_FIELD2))
 320
 321 // string third byte : 010xxxxx
 322 #define STRING_FIELD2 0x40
 323 #define RAM_STRING(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == STRING_FIELD2))
 324 #define ROM_STRING(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == STRING_FIELD2))
 325
 326 // vector third byte : 011xxxxx
 327 #define VECTOR_FIELD2 0x60
 328 #define RAM_VECTOR(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == VECTOR_FIELD2))
 329 #define ROM_VECTOR(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == VECTOR_FIELD2))
 330
 331 // continuation third byte : 100xxxxx
 332 #define CONTINUATION_FIELD2 0x80
 333 #define RAM_CONTINUATION(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == CONTINUATION_FIELD2))
 334 #define ROM_CONTINUATION(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == CONTINUATION_FIELD2))
 335
 336 // closure first byte : 01Gxxxxx
 337 #define CLOSURE_FIELD0 0x40
 338 #define RAM_CLOSURE(o) ((ram_get_field0 (o) & 0xc0) == CLOSURE_FIELD0)
 339 #define ROM_CLOSURE(o) ((rom_get_field0 (o) & 0xc0) == CLOSURE_FIELD0)
 340
 341 /*---------------------------------------------------------------------------*/
 342
 343 #define RAM_GET_FIELD0_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,0))
 344 #define RAM_SET_FIELD0_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,0), val)
 345 #define ROM_GET_FIELD0_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,0))
 346
 347 #define RAM_GET_GC_TAGS_MACRO(o) (RAM_GET_FIELD0_MACRO(o) & 0x60)
 348 #define RAM_SET_GC_TAGS_MACRO(o,tags)                                      \
 349   (RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0x9f) | (tags)))
 350 #define RAM_SET_GC_TAG0_MACRO(o,tag)                                    \
 351   RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xdf) | (tag))
 352 #define RAM_SET_GC_TAG1_MACRO(o,tag)                                    \
 353   RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xbf) | (tag))
 354
 355 #if WORD_BITS == 8
 356 #define RAM_GET_FIELD1_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,1))
 357 #define RAM_GET_FIELD2_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,2))
 358 #define RAM_GET_FIELD3_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,3))
 359 #define RAM_SET_FIELD1_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,1), val)
 360 #define RAM_SET_FIELD2_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,2), val)
 361 #define RAM_SET_FIELD3_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,3), val)
 362 #define ROM_GET_FIELD1_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,1))
 363 #define ROM_GET_FIELD2_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,2))
 364 #define ROM_GET_FIELD3_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,3))
 365 #endif
 366
 367 #if WORD_BITS == 10
 368 #define RAM_GET_FIELD1_MACRO(o)                                         \
 369   (ram_get (OBJ_TO_RAM_ADDR(o,1)) + ((RAM_GET_FIELD0_MACRO(o) & 0x03)<<8))
 370 #define RAM_GET_FIELD2_MACRO(o)                                         \
 371   (ram_get (OBJ_TO_RAM_ADDR(o,2)) + ((RAM_GET_FIELD0_MACRO(o) & 0x0c)<<6))
 372 #define RAM_GET_FIELD3_MACRO(o)                                         \
 373   (ram_get (OBJ_TO_RAM_ADDR(o,3)) + ((RAM_GET_FIELD0_MACRO(o) & 0x30)<<4))
 374 #define RAM_SET_FIELD1_MACRO(o,val)                                     \
 375   do {                                                                  \
 376     ram_set (OBJ_TO_RAM_ADDR(o,1), (val) & 0xff);                       \
 377     RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xfc) + (((val) >> 8) & 0x03)); \
 378   } while (0)
 379 #define RAM_SET_FIELD2_MACRO(o,val)                                     \
 380   do {                                                                  \
 381     ram_set (OBJ_TO_RAM_ADDR(o,2), (val) & 0xff);                       \
 382     RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xf3) + (((val) >> 6) & 0x0c)); \
 383   } while (0)
 384 #define RAM_SET_FIELD3_MACRO(o,val)                                     \
 385   do {                                                                  \
 386     ram_set (OBJ_TO_RAM_ADDR(o,3), (val) & 0xff);                       \
 387     RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xcf) + (((val) >> 4) & 0x30)); \
 388   } while (0)
 389 #define ROM_GET_FIELD1_MACRO(o)                                         \
 390   (rom_get (OBJ_TO_ROM_ADDR(o,1)) + ((ROM_GET_FIELD0_MACRO(o) & 0x03)<<8))
 391 #define ROM_GET_FIELD2_MACRO(o)                                         \
 392   (rom_get (OBJ_TO_ROM_ADDR(o,2)) + ((ROM_GET_FIELD0_MACRO(o) & 0x0c)<<6))
 393 #define ROM_GET_FIELD3_MACRO(o)                                         \
 394   (rom_get (OBJ_TO_ROM_ADDR(o,3)) + ((ROM_GET_FIELD0_MACRO(o) & 0x30)<<4))
 395 #endif
 396
 397 uint8 ram_get_gc_tags (obj o) { return RAM_GET_GC_TAGS_MACRO(o); }
 398 void ram_set_gc_tags  (obj o, uint8 tags) { RAM_SET_GC_TAGS_MACRO(o, tags); }
 399 void ram_set_gc_tag0 (obj o, uint8 tag) { RAM_SET_GC_TAG0_MACRO(o,tag); }
 400 void ram_set_gc_tag1 (obj o, uint8 tag) { RAM_SET_GC_TAG1_MACRO(o,tag); }
 401 uint8 ram_get_field0 (obj o) { return RAM_GET_FIELD0_MACRO(o); }
 402 word ram_get_field1 (obj o) { return RAM_GET_FIELD1_MACRO(o); } // TODO used to return obj, which used to be the same as words
 403 word ram_get_field2 (obj o) { return RAM_GET_FIELD2_MACRO(o); }
 404 word ram_get_field3 (obj o) { return RAM_GET_FIELD3_MACRO(o); }
 405 void ram_set_field0 (obj o, uint8 val) { RAM_SET_FIELD0_MACRO(o,val); }
 406 void ram_set_field1 (obj o, word val) { RAM_SET_FIELD1_MACRO(o,val); }
 407 void ram_set_field2 (obj o, word val) { RAM_SET_FIELD2_MACRO(o,val); }
 408 void ram_set_field3 (obj o, word val) { RAM_SET_FIELD3_MACRO(o,val); }
 409 uint8 rom_get_field0 (obj o) { return ROM_GET_FIELD0_MACRO(o); }
 410 word rom_get_field1 (obj o) { return ROM_GET_FIELD1_MACRO(o); }
 411 word rom_get_field2 (obj o) { return ROM_GET_FIELD2_MACRO(o); }
 412 word rom_get_field3 (obj o) { return ROM_GET_FIELD3_MACRO(o); }
 413
 414 obj ram_get_car (obj o)
 415 { return ((ram_get_field0 (o) & 0x1f) << 8) | ram_get_field1 (o); }
 416 obj rom_get_car (obj o)
 417 { return ((rom_get_field0 (o) & 0x1f) << 8) | rom_get_field1 (o); }
 418 obj ram_get_cdr (obj o)
 419 { return ((ram_get_field2 (o) & 0x1f) << 8) | ram_get_field3 (o); }
 420 obj rom_get_cdr (obj o)
 421 { return ((rom_get_field2 (o) & 0x1f) << 8) | rom_get_field3 (o); }
 422 void ram_set_car (obj o, obj val)
 423 {
 424   ram_set_field0 (o, ((val & 0x1f00) >> 8) | (ram_get_field0 (o) & 0xc0));
 425   ram_set_field1 (o, val & 0xff);
 426 }
 427 void ram_set_cdr (obj o, obj val)
 428 {
 429   ram_set_field2 (o, ((val & 0x1f00) >> 8) | (ram_get_field2 (o) & 0xc0));
 430   ram_set_field3 (o, val & 0xff);
 431 }
 432 obj ram_get_entry (obj o)
 433 {
 434   return (((ram_get_field0 (o) & 0x1f) << 11)
 435           | (ram_get_field1 (o) << 3)
 436           | (ram_get_field2 (o) >> 5));
 437 }
 438 obj rom_get_entry (obj o)
 439 {
 440   return (((rom_get_field0 (o) & 0x1f) << 11)
 441           | (rom_get_field1 (o) << 3)
 442           | (rom_get_field2 (o) >> 5));
 443 }
 444
 445 obj get_global (uint8 i)
 446 {
 447   return globals[i];
 448 }
 449
 450 void set_global (uint8 i, obj o)
 451 {
 452   globals[i] = o;
 453 }
 454
 455 /*---------------------------------------------------------------------------*/
 456
 457 /* Interface to GC */
 458
 459 /* GC tags are in the top 2 bits of field 0 */
 460 #define GC_TAG_0_LEFT   (1<<5)
 461 // TODO was 3<<5, changed to play nice with procedures and bignums, but should actually set only this bit, not clear the other
 462 #define GC_TAG_1_LEFT   (2<<5)
 463 #define GC_TAG_UNMARKED (0<<5)  /* must be 0 */ // TODO FOOBAR is it ok ? eevn for bignums ?
 464
 465 /* Number of object fields of objects in ram */
 466 #define HAS_2_OBJECT_FIELDS(visit) (RAM_PAIR(visit) || RAM_CONTINUATION(visit))
 467 #define HAS_1_OBJECT_FIELD(visit)  (RAM_COMPOSITE(visit) || RAM_CLOSURE(visit))
 468 // TODO now we consider that all composites have at least 1 field, even symbols, as do procedures. no problem for symbols, since the car is always #f (make sure)
 469 // TODO if we ever have true bignums, bignums will have 1 object field
 470
 471 #define NIL OBJ_FALSE
 472
 473 /*---------------------------------------------------------------------------*/
 474
 475 /* Garbage collector */
 476
 477 obj free_list; /* list of unused cells */
 478
 479 obj arg1; /* root set */
 480 obj arg2;
 481 obj arg3;
 482 obj arg4;
 483 obj cont;
 484 obj env;
 485
 486 uint8 na; /* interpreter variables */ // TODO what's na ?
 487 rom_addr pc;
 488 rom_addr entry;
 489 uint8 bytecode;
 490 uint8 bytecode_hi4;
 491 uint8 bytecode_lo4;
 492 obj second_half; /* the second half of continuations */
 493 int32 a1;
 494 int32 a2;
 495 int32 a3;
 496
 497 void init_ram_heap (void)
 498 {
 499   uint8 i;
 500   obj o = MAX_RAM_ENCODING;
 501
 502   free_list = 0;
 503
 504   while (o >= MIN_RAM_ENCODING)
 505     {
 506       ram_set_gc_tags (o, GC_TAG_UNMARKED);
 507       ram_set_car (o, free_list);
 508       free_list = o;
 509       o--;
 510     }
 511
 512   for (i=0; i<GLOVARS; i++)
 513     set_global (i, OBJ_FALSE);
 514
 515   arg1 = OBJ_FALSE;
 516   arg2 = OBJ_FALSE;
 517   arg3 = OBJ_FALSE;
 518   arg4 = OBJ_FALSE;
 519   cont = OBJ_FALSE;
 520   env  = OBJ_NULL;
 521   second_half = OBJ_FALSE;
 522 }
 523
 524 void mark (obj temp)
 525 {
 526   /* mark phase */
 527
 528   obj stack; // TODO do we need a stack ? since we have 0-1-2 children, we could do deutsche schorr waite
 529   obj visit;
 530
 531   if (IN_RAM(temp))
 532     {
 533       visit = NIL;
 534
 535     push:
 536
 537       stack = visit;
 538       visit = temp;
 539
 540       IF_GC_TRACE(printf ("push   stack=%d (tag=%d)  visit=%d (tag=%d)\n", stack, ram_get_gc_tags (stack)>>6, visit, ram_get_gc_tags (visit)>>6));
 541
 542       /*
 543        * Four cases are possible:
 544        *
 545        * A)
 546        *                          stack  visit tag F1  F2  F3
 547        *                           NIL    |   +---+---+---+---+
 548        *                                  +-> | ? |   |   |   |
 549        *                                      +---+---+---+---+
 550        *
 551        * B)
 552        *          tag F1  F2  F3  stack  visit tag F1  F2  F3
 553        *         +---+---+---+---+   |    |   +---+---+---+---+
 554        *         | 1 |   |   |   | <-+    +-> | ? |   |   |   |
 555        *         +---+---+---+-|-+            +---+---+---+---+
 556        *     <-----------------+
 557        *
 558        * C)
 559        *          tag F1  F2  F3  stack  visit tag F1  F2  F3
 560        *         +---+---+---+---+   |    |   +---+---+---+---+
 561        *         | 2 |   |   |   | <-+    +-> | ? |   |   |   |
 562        *         +---+---+-|-+---+            +---+---+---+---+
 563        *     <-------------+
 564        *
 565        * D)
 566        *          tag F1  F2  F3  stack  visit tag F1  F2  F3
 567        *         +---+---+---+---+   |    |   +---+---+---+---+
 568        *         | 3 |   |   |   | <-+    +-> | ? |   |   |   |
 569        *         +---+-|-+---+---+            +---+---+---+---+
 570        *     <---------+
 571        */
 572       // TODO since no-one has 3 fields anymore, not really 4 cases ?
 573
 574       //      if (ram_get_gc_tags (visit) != GC_TAG_UNMARKED) // TODO always matches procedures, WRONG, maybe check only the right gc bit ?/
 575       if (ram_get_gc_tags (visit) & 0x2f) // TODO we check only the last gc bit
 576         IF_GC_TRACE(printf ("case 1\n")); // TODO are there cases where checking only the last gc bit is wrong ?
 577       // TODO FOOBAR ok, with our new way, what do we check here ?
 578       else
 579         {
 580           if (HAS_2_OBJECT_FIELDS(visit))
 581             {
 582               IF_GC_TRACE(printf ("case 5\n"));
 583               // TODO we don't have cases 2-4 anymore
 584
 585             visit_field2:
 586
 587               temp = ram_get_cdr (visit);
 588
 589               if (IN_RAM(temp))
 590                 {
 591                   IF_GC_TRACE(printf ("case 6\n"));
 592                   ram_set_gc_tags (visit, GC_TAG_1_LEFT);
 593                   ram_set_cdr (visit, stack);
 594                   goto push;
 595                 }
 596
 597               IF_GC_TRACE(printf ("case 7\n"));
 598
 599               goto visit_field1;
 600             }
 601
 602           if (HAS_1_OBJECT_FIELD(visit))
 603             {
 604               IF_GC_TRACE(printf ("case 8\n"));
 605
 606             visit_field1:
 607
 608               temp = ram_get_car (visit);
 609
 610               if (IN_RAM(temp))
 611                 {
 612                   IF_GC_TRACE(printf ("case 9\n"));
 613                   ram_set_gc_tag0 (visit, GC_TAG_0_LEFT); // TODO changed, now we only set bit 0, we don't change bit 1, since some objets have only 1 mark bit
 614                   ram_set_car (visit, stack);
 615                   goto push;
 616                 }
 617
 618               IF_GC_TRACE(printf ("case 10\n"));
 619             }
 620           else
 621             IF_GC_TRACE(printf ("case 11\n"));
 622
 623           ram_set_gc_tag0 (visit, GC_TAG_0_LEFT); // TODO changed, same as above
 624         }
 625
 626     pop:
 627
 628       IF_GC_TRACE(printf ("pop    stack=%d (tag=%d)  visit=%d (tag=%d)\n", stack, ram_get_gc_tags (stack)>>6, visit, ram_get_gc_tags (visit)>>6));
 629
 630       if (stack != NIL)
 631         {
 632           if (ram_get_gc_tags (stack) == GC_TAG_1_LEFT) // TODO FOOBAR, this is always true for closures that have not been marked, can such an object get here ? probably not, since when a procedure is popped, it has already been visited, so will be at 0 left
 633             {
 634               IF_GC_TRACE(printf ("case 13\n"));
 635
 636               temp = ram_get_cdr (stack);  /* pop through field 2 */
 637               ram_set_cdr (stack, visit);
 638               visit = stack;
 639               stack = temp;
 640
 641               goto visit_field1;
 642             }
 643
 644           IF_GC_TRACE(printf ("case 14\n"));
 645
 646           temp = ram_get_car (stack);  /* pop through field 1 */
 647           ram_set_car (stack, visit);
 648           visit = stack;
 649           stack = temp;
 650
 651           goto pop;
 652         }
 653     }
 654 }
 655
 656 #ifdef DEBUG_GC
 657 int max_live = 0;
 658 #endif
 659
 660 void sweep (void)
 661 {
 662   /* sweep phase */
 663
 664 #ifdef DEBUG_GC
 665   int n = 0;
 666 #endif
 667
 668   obj visit = MAX_RAM_ENCODING;
 669
 670   free_list = 0;
 671
 672   while (visit >= MIN_RAM_ENCODING)
 673     {
 674       if ((RAM_COMPOSITE(visit) && (ram_get_gc_tags (visit) == GC_TAG_UNMARKED)) || (ram_get_gc_tags (visit) & GC_TAG_0_LEFT)) /* unmarked? */
 675         // TODO now we check only 1 bit if the object has only 1 mark bit
 676         {
 677           ram_set_car (visit, free_list);
 678           free_list = visit;
 679         }
 680       else
 681         {
 682           if (RAM_COMPOSITE(visit))
 683             ram_set_gc_tags (visit, GC_TAG_UNMARKED);
 684           else // only 1 mark bit to unset
 685             ram_set_gc_tag0 (visit, GC_TAG_UNMARKED);
 686 #ifdef DEBUG_GC
 687           n++;
 688 #endif
 689         }
 690       visit--;
 691     }
 692
 693 #ifdef DEBUG_GC
 694   if (n > max_live)
 695     {
 696       max_live = n;
 697       printf ("**************** memory needed = %d\n", max_live+1);
 698       fflush (stdout);
 699     }
 700 #endif
 701 }
 702
 703 void gc (void)
 704 {
 705   uint8 i;
 706
 707   mark (arg1);
 708   mark (arg2);
 709   mark (arg3);
 710   mark (arg4);
 711   mark (cont);
 712   mark (env);
 713
 714   for (i=0; i<GLOVARS; i++)
 715     mark (get_global (i));
 716
 717   sweep ();
 718 }
 719
 720 obj alloc_ram_cell (void)
 721 {
 722   obj o;
 723
 724 #ifdef DEBUG_GC
 725   gc ();
 726 #endif
 727
 728   if (free_list == 0)
 729     {
 730 #ifndef DEBUG_GC
 731       gc ();
 732       if (free_list == 0)
 733 #endif
 734         ERROR("memory is full");
 735     }
 736
 737   o = free_list;
 738
 739   free_list = ram_get_field1 (o);
 740
 741   return o;
 742 }
 743
 744 obj alloc_ram_cell_init (uint8 f0, uint8 f1, uint8 f2, uint8 f3)
 745 {
 746   obj o = alloc_ram_cell ();
 747
 748   ram_set_field0 (o, f0);
 749   ram_set_field1 (o, f1);
 750   ram_set_field2 (o, f2);
 751   ram_set_field3 (o, f3);
 752
 753   return o;
 754 }
 755
 756 /*---------------------------------------------------------------------------*/
 757
 758 int32 decode_int (obj o)
 759 {
 760   uint8 u;
 761   uint8 h;
 762   uint8 l;
 763
 764   if (o < MIN_FIXNUM_ENCODING)
 765     TYPE_ERROR("integer");
 766
 767   if (o <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM)))
 768     return DECODE_FIXNUM(o);
 769
 770   if (IN_RAM(o))
 771     {
 772       if (!RAM_BIGNUM(o))
 773         TYPE_ERROR("integer");
 774
 775       u = ram_get_field1 (o);
 776       h = ram_get_field2 (o);
 777       l = ram_get_field3 (o);
 778     }
 779   else if (IN_ROM(o))
 780     {
 781       if (!ROM_BIGNUM(o))
 782         TYPE_ERROR("integer");
 783
 784       u = rom_get_field1 (o);
 785       h = rom_get_field2 (o);
 786       l = rom_get_field3 (o);
 787     }
 788   else
 789     TYPE_ERROR("integer");
 790
 791   if (u >= 128)
 792     return ((int32)((((int16)u - 256) << 8) + h) << 8) + l;
 793
 794   return ((int32)(((int16)u << 8) + h) << 8) + l;
 795 }
 796
 797 obj encode_int (int32 n)
 798 {
 799   if (n >= MIN_FIXNUM && n <= MAX_FIXNUM)
 800     return ENCODE_FIXNUM(n);
 801
 802   return alloc_ram_cell_init (BIGNUM_FIELD0, n >> 16, n >> 8, n);
 803 }
 804
 805 /*---------------------------------------------------------------------------*/
 806
 807 #ifdef WORKSTATION
 808
 809 void show (obj o)
 810 {
 811 #if 0
 812   printf ("[%d]", o);
 813 #endif
 814
 815   if (o == OBJ_FALSE)
 816     printf ("#f");
 817   else if (o == OBJ_TRUE)
 818     printf ("#t");
 819   else if (o == OBJ_NULL)
 820     printf ("()");
 821   else if (o <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM)))
 822     printf ("%d", DECODE_FIXNUM(o));
 823   else
 824     {
 825       uint8 in_ram;
 826
 827       if (IN_RAM(o))
 828         in_ram = 1;
 829       else
 830         in_ram = 0;
 831
 832       if ((in_ram && RAM_BIGNUM(o)) || (!in_ram && ROM_BIGNUM(o)))
 833         printf ("%d", decode_int (o));
 834       else if ((in_ram && RAM_COMPOSITE(o)) || (!in_ram && ROM_COMPOSITE(o)))
 835         {
 836           obj car;
 837           obj cdr;
 838
 839           if (in_ram && RAM_PAIR(o))
 840             {
 841               car = ram_get_car (o);
 842               cdr = ram_get_cdr (o);
 843               printf ("(");
 844
 845             loop_ram:
 846               show (car);
 847
 848               if (cdr == OBJ_NULL)
 849                 printf (")");
 850               else if (RAM_PAIR(cdr))
 851                 {
 852                   car = ram_get_car (cdr);
 853                   cdr = ram_get_cdr (cdr);
 854
 855                   printf (" ");
 856                   goto loop_ram;
 857                 }
 858               else
 859                 {
 860                   printf (" . ");
 861                   show (cdr);
 862                   printf (")");
 863                 }
 864             }
 865           else if (!in_ram && ROM_PAIR(o))
 866             {
 867               car = rom_get_car (o);
 868               cdr = rom_get_cdr (o);
 869               printf ("(");
 870             loop_rom:
 871               show (car);
 872
 873               if (cdr == OBJ_NULL)
 874                 printf (")");
 875               else if (ROM_PAIR(cdr))
 876                 {
 877                   car = rom_get_car (cdr);
 878                   cdr = rom_get_cdr (cdr);
 879
 880                   printf (" ");
 881                   goto loop_rom;
 882                 }
 883               else // TODO lots of repetition
 884                 {
 885                   printf (" . ");
 886                   show (cdr);
 887                   printf (")");
 888                 }
 889             }
 890           else if ((in_ram && RAM_SYMBOL(o)) || (!in_ram && ROM_SYMBOL(o)))
 891             printf ("#<symbol>");
 892           else if ((in_ram && RAM_STRING(o)) || (!in_ram && ROM_STRING(o)))
 893             printf ("#<string>");
 894           else if ((in_ram && RAM_VECTOR(o)) || (!in_ram && ROM_VECTOR(o)))
 895             printf ("#<vector>");
 896           else
 897             {
 898               printf ("(");
 899               car = ram_get_car (o);
 900               cdr = ram_get_cdr (o);
 901               goto loop_ram; // TODO ugly hack, takes advantage of the fact that pairs and continuations have the same layout
 902             }
 903         }
 904       else // closure
 905         {
 906           obj env;
 907           /* obj parent_cont; */
 908           rom_addr pc;
 909
 910           if (IN_RAM(o)) // TODO can closures be in rom ? I don't think so
 911             env = ram_get_cdr (o); // TODO was car, but representation changed
 912           else
 913             env = rom_get_cdr (o);
 914
 915           /* if (IN_RAM(o)) */
 916           /*   parent_cont = ram_get_field2 (o); */
 917           /* else */
 918           /*   parent_cont = rom_get_field2 (o); */
 919
 920           if (IN_RAM(o))
 921             pc = ram_get_entry (o);
 922           else
 923             pc = rom_get_entry (o);
 924
 925           printf ("{0x%04x ", pc);
 926           show (env);
 927           /* printf (" "); */
 928           /* show (parent_cont); */
 929           printf ("}");
 930           /* printf ("#<procedure>"); */
 931         }
 932     }
 933
 934   fflush (stdout);
 935 }
 936
 937 void show_state (rom_addr pc)
 938 {
 939   printf ("pc=0x%04x bytecode=0x%02x env=", pc, rom_get (pc));
 940   show (env);
 941   printf (" cont=");
 942   show (cont);
 943   printf ("\n");
 944   fflush (stdout);
 945 }
 946
 947 void print (obj o)
 948 {
 949   show (o);
 950   printf ("\n");
 951   fflush (stdout);
 952 }
 953
 954 #endif
 955
 956 /*---------------------------------------------------------------------------*/
 957
 958 /* Integer operations */
 959
 960 #define encode_bool(x) ((obj)(x))
 961
 962 void prim_numberp (void)
 963 {
 964   if (arg1 >= MIN_FIXNUM_ENCODING
 965       && arg1 <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM)))
 966     arg1 = OBJ_TRUE;
 967   else
 968     {
 969       if (IN_RAM(arg1))
 970         arg1 = encode_bool (RAM_BIGNUM(arg1));
 971       else if (IN_ROM(arg1))
 972         arg1 = encode_bool (ROM_BIGNUM(arg1));
 973       else
 974         arg1 = OBJ_FALSE;
 975     }
 976 }
 977
 978 void decode_2_int_args (void)
 979 {
 980   a1 = decode_int (arg1);
 981   a2 = decode_int (arg2);
 982 }
 983
 984 void prim_add (void)
 985 {
 986   decode_2_int_args ();
 987   arg1 = encode_int (a1 + a2);
 988   arg2 = OBJ_FALSE;
 989 }
 990
 991 void prim_sub (void)
 992 {
 993   decode_2_int_args ();
 994   arg1 = encode_int (a1 - a2);
 995   arg2 = OBJ_FALSE;
 996 }
 997
 998 void prim_mul (void)
 999 {
1000   decode_2_int_args ();
1001   arg1 = encode_int (a1 * a2);
1002   arg2 = OBJ_FALSE;
1003 }
1004
1005 void prim_div (void)
1006 {
1007   decode_2_int_args ();
1008   if (a2 == 0)
1009     ERROR("divide by 0");
1010   arg1 = encode_int (a1 / a2);
1011   arg2 = OBJ_FALSE;
1012 }
1013
1014 void prim_rem (void)
1015 {
1016   decode_2_int_args ();
1017   if (a2 == 0)
1018     ERROR("divide by 0");
1019   arg1 = encode_int (a1 % a2);
1020   arg2 = OBJ_FALSE;
1021 }
1022
1023 void prim_neg (void)
1024 {
1025   a1 = decode_int (arg1);
1026   arg1 = encode_int (- a1);
1027 }
1028
1029 void prim_eq (void)
1030 {
1031   decode_2_int_args ();
1032   arg1 = encode_bool (a1 == a2);
1033   arg2 = OBJ_FALSE;
1034 }
1035
1036 void prim_lt (void)
1037 {
1038   decode_2_int_args ();
1039   arg1 = encode_bool (a1 < a2);
1040   arg2 = OBJ_FALSE;
1041 }
1042
1043 void prim_gt (void)
1044 {
1045   decode_2_int_args ();
1046   arg1 = encode_bool (a1 > a2);
1047   arg2 = OBJ_FALSE;
1048 }
1049
1050 void prim_ior (void)
1051 {
1052   a1 = decode_int (arg1);
1053   a2 = decode_int (arg2);
1054   arg1 = encode_int (a1 | a2);
1055   arg2 = OBJ_FALSE;
1056 }
1057
1058 void prim_xor (void)
1059 {
1060   a1 = decode_int (arg1);
1061   a2 = decode_int (arg2);
1062   arg1 = encode_int (a1 ^ a2);
1063   arg2 = OBJ_FALSE;
1064 }
1065
1066
1067 /*---------------------------------------------------------------------------*/
1068
1069 /* List operations */
1070
1071 void prim_pairp (void)
1072 {
1073   if (IN_RAM(arg1))
1074     arg1 = encode_bool (RAM_PAIR(arg1));
1075   else if (IN_ROM(arg1))
1076     arg1 = encode_bool (ROM_PAIR(arg1));
1077   else
1078     arg1 = OBJ_FALSE;
1079 }
1080
1081 obj cons (obj car, obj cdr)
1082 {
1083   return alloc_ram_cell_init (COMPOSITE_FIELD0 | ((car & 0x1f00) >> 8),
1084                               car & 0xff,
1085                               PAIR_FIELD2 | ((cdr & 0x1f00) >> 8),
1086                               cdr & 0xff);
1087 }
1088
1089 void prim_cons (void)
1090 {
1091   arg1 = cons (arg1, arg2);
1092   arg2 = OBJ_FALSE;
1093 }
1094
1095 void prim_car (void)
1096 {
1097   if (IN_RAM(arg1))
1098     {
1099       if (!RAM_PAIR(arg1))
1100         TYPE_ERROR("pair");
1101       arg1 = ram_get_car (arg1);
1102     }
1103   else if (IN_ROM(arg1))
1104     {
1105       if (!ROM_PAIR(arg1))
1106         TYPE_ERROR("pair");
1107       arg1 = rom_get_car (arg1);
1108     }
1109   else
1110     {
1111       TYPE_ERROR("pair");
1112     }
1113 }
1114
1115 void prim_cdr (void)
1116 {
1117   if (IN_RAM(arg1))
1118     {
1119       if (!RAM_PAIR(arg1))
1120         TYPE_ERROR("pair");
1121       arg1 = ram_get_cdr (arg1);
1122     }
1123   else if (IN_ROM(arg1))
1124     {
1125       if (!ROM_PAIR(arg1))
1126         TYPE_ERROR("pair");
1127       arg1 = rom_get_cdr (arg1);
1128     }
1129   else
1130     {
1131       TYPE_ERROR("pair");
1132     }
1133 }
1134
1135 void prim_set_car (void)
1136 {
1137   if (IN_RAM(arg1))
1138     {
1139       if (!RAM_PAIR(arg1))
1140         TYPE_ERROR("pair");
1141
1142       ram_set_car (arg1, arg2);
1143       arg1 = OBJ_FALSE;
1144       arg2 = OBJ_FALSE;
1145     }
1146   else
1147     {
1148       TYPE_ERROR("pair");
1149     }
1150 }
1151
1152 void prim_set_cdr (void)
1153 {
1154   if (IN_RAM(arg1))
1155     {
1156       if (!RAM_PAIR(arg1))
1157         TYPE_ERROR("pair");
1158
1159       ram_set_cdr (arg1, arg2);
1160       arg1 = OBJ_FALSE;
1161       arg2 = OBJ_FALSE;
1162     }
1163   else
1164     {
1165       TYPE_ERROR("pair");
1166     }
1167 }
1168
1169 void prim_nullp (void)
1170 {
1171   arg1 = encode_bool (arg1 == OBJ_NULL);
1172 }
1173
1174 /*---------------------------------------------------------------------------*/
1175
1176 /* Miscellaneous operations */
1177
1178 void prim_eqp (void)
1179 {
1180   arg1 = encode_bool (arg1 == arg2);
1181   arg2 = OBJ_FALSE;
1182 }
1183
1184 void prim_not (void)
1185 {
1186   arg1 = encode_bool (arg1 == OBJ_FALSE);
1187 }
1188
1189 void prim_symbolp (void)
1190 {
1191   if (IN_RAM(arg1))
1192     arg1 = encode_bool (RAM_SYMBOL(arg1));
1193   else if (IN_ROM(arg1))
1194     arg1 = encode_bool (ROM_SYMBOL(arg1));
1195   else
1196     arg1 = OBJ_FALSE;
1197 }
1198
1199 void prim_stringp (void)
1200 {
1201   if (IN_RAM(arg1))
1202     arg1 = encode_bool (RAM_STRING(arg1));
1203   else if (IN_ROM(arg1))
1204     arg1 = encode_bool (ROM_STRING(arg1));
1205   else
1206     arg1 = OBJ_FALSE;
1207 }
1208
1209 void prim_string2list (void)
1210 {
1211   if (IN_RAM(arg1))
1212     {
1213       if (!RAM_STRING(arg1))
1214         TYPE_ERROR("string");
1215
1216       arg1 = ram_get_car (arg1);
1217     }
1218   else if (IN_ROM(arg1))
1219     {
1220       if (!ROM_STRING(arg1))
1221         TYPE_ERROR("string");
1222
1223       arg1 = rom_get_car (arg1);
1224     }
1225   else
1226     TYPE_ERROR("string");
1227 }
1228
1229  void prim_list2string (void)
1230 {
1231   arg1 = alloc_ram_cell_init (COMPOSITE_FIELD0 | ((arg1 & 0x1f00) >> 8),
1232                               arg1 & 0xff,
1233                               STRING_FIELD2,
1234                               0);
1235 }
1236
1237
1238 /*---------------------------------------------------------------------------*/
1239
1240 /* Robot specific operations */
1241
1242
1243 void prim_print (void)
1244 {
1245 #ifdef PICOBOARD2
1246 #endif
1247
1248 #ifdef WORKSTATION
1249
1250   print (arg1);
1251
1252 #endif
1253
1254   arg1 = OBJ_FALSE;
1255 }
1256
1257
1258 int32 read_clock (void)
1259 {
1260   int32 now = 0;
1261
1262 #ifdef PICOBOARD2
1263
1264   now = from_now( 0 );
1265
1266 #endif
1267
1268 #ifdef WORKSTATION
1269
1270 #ifdef _WIN32
1271
1272   static int32 start = 0;
1273   struct timeb tb;
1274
1275   ftime (&tb);
1276
1277   now = tb.time * 1000 + tb.millitm;
1278   if (start == 0)
1279     start = now;
1280   now -= start;
1281
1282 #else
1283
1284   static int32 start = 0;
1285   struct timeval tv;
1286
1287   if (gettimeofday (&tv, NULL) == 0)
1288     {
1289       now = tv.tv_sec * 1000 + tv.tv_usec / 1000;
1290       if (start == 0)
1291         start = now;
1292       now -= start;
1293     }
1294
1295 #endif
1296
1297 #endif
1298
1299   return now;
1300 }
1301
1302
1303 void prim_clock (void)
1304 {
1305   arg1 = encode_int (read_clock ());
1306 }
1307
1308
1309 void prim_motor (void)
1310 {
1311   decode_2_int_args ();
1312
1313   if (a1 < 1 || a1 > 2 || a2 < -100 || a2 > 100)
1314     ERROR("argument out of range to procedure \"motor\"");
1315
1316 #ifdef PICOBOARD2
1317
1318   fw_motor ();
1319
1320 #endif
1321
1322 #ifdef WORKSTATION
1323
1324   printf ("motor %d -> power=%d\n", a1, a2);
1325   fflush (stdout);
1326
1327 #endif
1328
1329   arg1 = OBJ_FALSE;
1330   arg2 = OBJ_FALSE;
1331 }
1332
1333
1334 void prim_led (void)
1335 {
1336   decode_2_int_args ();
1337   a3 = decode_int (arg3);
1338
1339   if (a1 < 1 || a1 > 3 || a2 < 0 || a3 < 0)
1340     ERROR("argument out of range to procedure \"led\"");
1341
1342 #ifdef PICOBOARD2
1343
1344   LED_set( a1, a2, a3 );
1345
1346 #endif
1347
1348 #ifdef WORKSTATION
1349
1350   printf ("led %d -> duty=%d period=%d\n", a1, a2, a3 );
1351   fflush (stdout);
1352
1353 #endif
1354
1355   arg1 = OBJ_FALSE;
1356   arg2 = OBJ_FALSE;
1357   arg3 = OBJ_FALSE;
1358 }
1359
1360
1361 void prim_led2_color (void)
1362 {
1363   a1 = decode_int (arg1);
1364
1365   if (a1 < 0 || a1 > 1)
1366     ERROR("argument out of range to procedure \"led2-color\"");
1367
1368 #ifdef PICOBOARD2
1369
1370   LED2_color_set( a1 );
1371
1372 #endif
1373
1374 #ifdef WORKSTATION
1375
1376   printf ("led2-color -> %s\n", (a1==0)?"green":"red");
1377   fflush (stdout);
1378
1379 #endif
1380
1381   arg1 = OBJ_FALSE;
1382 }
1383
1384
1385 void prim_getchar_wait (void)
1386 {
1387   decode_2_int_args();
1388   a1 = read_clock () + a1;
1389
1390   if (a1 < 0 || a2 < 1 || a2 > 3)
1391     ERROR("argument out of range to procedure \"getchar-wait\"");
1392
1393 #ifdef PICOBOARD2
1394
1395   arg1 = OBJ_FALSE;
1396
1397   {
1398     serial_port_set ports;
1399     ports = serial_rx_wait_with_timeout( a2, a1 );
1400     if (ports != 0)
1401       arg1 = encode_int (serial_rx_read( ports ));
1402   }
1403
1404 #endif
1405
1406 #ifdef WORKSTATION
1407
1408 #ifdef _WIN32
1409
1410   arg1 = OBJ_FALSE;
1411
1412   do
1413     {
1414       if (_kbhit ())
1415         {
1416           arg1 = encode_int (_getch ());
1417           break;
1418         }
1419     } while (read_clock () < a1);
1420
1421
1422 #else
1423
1424   arg1 = encode_int (getchar ());
1425
1426 #endif
1427
1428 #endif
1429 }
1430
1431
1432 void prim_putchar (void)
1433 {
1434   decode_2_int_args ();
1435
1436   if (a1 < 0 || a1 > 255 || a2 < 1 || a2 > 3)
1437     ERROR("argument out of range to procedure \"putchar\"");
1438
1439 #ifdef PICOBOARD2
1440
1441   serial_tx_write( a2, a1 );
1442
1443 #endif
1444
1445 #ifdef WORKSTATION
1446
1447   putchar (a1);
1448   fflush (stdout);
1449
1450 #endif
1451
1452   arg1 = OBJ_FALSE;
1453   arg2 = OBJ_FALSE;
1454 }
1455
1456
1457 void prim_beep (void)
1458 {
1459   decode_2_int_args ();
1460
1461   if (a1 < 1 || a1 > 255 || a2 < 0)
1462     ERROR("argument out of range to procedure \"beep\"");
1463
1464 #ifdef PICOBOARD2
1465
1466   beep( a1, from_now( a2 ) );
1467
1468 #endif
1469
1470 #ifdef WORKSTATION
1471
1472   printf ("beep -> freq-div=%d duration=%d\n", a1, a2 );
1473   fflush (stdout);
1474
1475 #endif
1476
1477   arg1 = OBJ_FALSE;
1478   arg2 = OBJ_FALSE;
1479 }
1480
1481
1482 void prim_adc (void)
1483 {
1484   short x;
1485
1486   a1 = decode_int (arg1);
1487
1488   if (a1 < 1 || a1 > 3)
1489     ERROR("argument out of range to procedure \"adc\"");
1490
1491 #ifdef PICOBOARD2
1492
1493   x = adc( a1 );
1494
1495 #endif
1496
1497 #ifdef WORKSTATION
1498
1499   x = read_clock () & 255;
1500
1501   if (x > 127) x = 256 - x;
1502
1503   x += 200;
1504
1505 #endif
1506
1507   arg1 = encode_int (x);
1508 }
1509
1510
1511 void prim_dac (void)
1512 {
1513   a1 = decode_int (arg1);
1514
1515   if (a1 < 0 || a1 > 255)
1516     ERROR("argument out of range to procedure \"dac\"");
1517
1518 #ifdef PICOBOARD2
1519
1520   dac( a1 );
1521
1522 #endif
1523
1524 #ifdef WORKSTATION
1525
1526   printf ("dac -> %d\n", a1 );
1527   fflush (stdout);
1528
1529 #endif
1530
1531   arg1 = OBJ_FALSE;
1532 }
1533
1534
1535 void prim_sernum (void)
1536 {
1537   short x;
1538
1539 #ifdef PICOBOARD2
1540
1541   x = serial_num ();
1542
1543 #endif
1544
1545 #ifdef WORKSTATION
1546
1547   x = 0;
1548
1549 #endif
1550
1551   arg1 = encode_int (x);
1552 }
1553
1554
1555 /*---------------------------------------------------------------------------*/
1556
1557 #ifdef WORKSTATION
1558
1559 int hidden_fgetc (FILE *f)
1560 {
1561   int c = fgetc (f);
1562 #if 0
1563   printf ("{%d}",c);
1564   fflush (stdout);
1565 #endif
1566   return c;
1567 }
1568
1569 #define fgetc(f) hidden_fgetc(f)
1570
1571 void write_hex_nibble (int n)
1572 {
1573   putchar ("0123456789ABCDEF"[n]);
1574 }
1575
1576 void write_hex (uint8 n)
1577 {
1578   write_hex_nibble (n >> 4);
1579   write_hex_nibble (n & 0x0f);
1580 }
1581
1582 int hex (int c)
1583 {
1584   if (c >= '0' && c <= '9')
1585     return (c - '0');
1586
1587   if (c >= 'A' && c <= 'F')
1588     return (c - 'A' + 10);
1589
1590   if (c >= 'a' && c <= 'f')
1591     return (c - 'a' + 10);
1592
1593   return -1;
1594 }
1595
1596 int read_hex_byte (FILE *f)
1597 {
1598   int h1 = hex (fgetc (f));
1599   int h2 = hex (fgetc (f));
1600
1601   if (h1 >= 0 && h2 >= 0)
1602     return (h1<<4) + h2;
1603
1604   return -1;
1605 }
1606
1607 int read_hex_file (char *filename)
1608 {
1609   int c;
1610   FILE *f = fopen (filename, "r");
1611   int result = 0;
1612   int len;
1613   int a, a1, a2;
1614   int t;
1615   int b;
1616   int i;
1617   uint8 sum;
1618   int hi16 = 0;
1619
1620   for (i=0; i<ROM_BYTES; i++)
1621     rom_mem[i] = 0xff;
1622
1623   if (f != NULL)
1624     {
1625       while ((c = fgetc (f)) != EOF)
1626         {
1627           if ((c == '\r') || (c == '\n'))
1628             continue;
1629
1630           if (c != ':' ||
1631               (len = read_hex_byte (f)) < 0 ||
1632               (a1 = read_hex_byte (f)) < 0 ||
1633               (a2 = read_hex_byte (f)) < 0 ||
1634               (t = read_hex_byte (f)) < 0)
1635             break;
1636
1637           a = (a1 << 8) + a2;
1638
1639           i = 0;
1640           sum = len + a1 + a2 + t;
1641
1642           if (t == 0)
1643             {
1644             next0:
1645
1646               if (i < len)
1647                 {
1648                   unsigned long adr = ((unsigned long)hi16 << 16) + a - CODE_START;
1649
1650                   if ((b = read_hex_byte (f)) < 0)
1651                     break;
1652
1653                   if (adr >= 0 && adr < ROM_BYTES)
1654                     rom_mem[adr] = b;
1655
1656                   a = (a + 1) & 0xffff;
1657                   i++;
1658                   sum += b;
1659
1660                   goto next0;
1661                 }
1662             }
1663           else if (t == 1)
1664             {
1665               if (len != 0)
1666                 break;
1667             }
1668           else if (t == 4)
1669             {
1670               if (len != 2)
1671                 break;
1672
1673               if ((a1 = read_hex_byte (f)) < 0 ||
1674                   (a2 = read_hex_byte (f)) < 0)
1675                 break;
1676
1677               sum += a1 + a2;
1678
1679               hi16 = (a1<<8) + a2;
1680             }
1681           else
1682             break;
1683
1684           if ((b = read_hex_byte (f)) < 0)
1685             break;
1686
1687           sum = -sum;
1688
1689           if (sum != b)
1690             {
1691               printf ("*** HEX file checksum error (expected 0x%02x)\n", sum);
1692               break;
1693             }
1694
1695           c = fgetc (f);
1696
1697           if ((c != '\r') && (c != '\n'))
1698             break;
1699
1700           if (t == 1)
1701             {
1702               result = 1;
1703               break;
1704             }
1705         }
1706
1707       if (result == 0)
1708         printf ("*** HEX file syntax error\n");
1709
1710       fclose (f);
1711     }
1712
1713   return result;
1714 }
1715
1716 #endif
1717
1718 /*---------------------------------------------------------------------------*/
1719
1720 #define FETCH_NEXT_BYTECODE() bytecode = rom_get (pc++)
1721
1722 #define BEGIN_DISPATCH()                        \
1723   dispatch:                                     \
1724   IF_TRACE(show_state (pc));                    \
1725   FETCH_NEXT_BYTECODE();                        \
1726   bytecode_hi4 = bytecode & 0xf0;               \
1727   bytecode_lo4 = bytecode & 0x0f;               \
1728   switch (bytecode_hi4 >> 4) {
1729
1730 #define END_DISPATCH() }
1731
1732 #define CASE(opcode) case (opcode>>4):;
1733
1734 #define DISPATCH(); goto dispatch;
1735
1736 #if 0
1737 #define pc FSR1
1738 #define sp FSR2
1739 #define bytecode TABLAT
1740 #define bytecode_hi4 WREG
1741 #endif
1742
1743 #define PUSH_CONSTANT1 0x00
1744 #define PUSH_CONSTANT2 0x10
1745 #define PUSH_STACK1    0x20
1746 #define PUSH_STACK2    0x30
1747 #define PUSH_GLOBAL    0x40
1748 #define SET_GLOBAL     0x50
1749 #define CALL           0x60
1750 #define JUMP           0x70
1751 #define CALL_TOPLEVEL  0x80
1752 #define JUMP_TOPLEVEL  0x90
1753 #define GOTO           0xa0
1754 #define GOTO_IF_FALSE  0xb0
1755 #define CLOSURE        0xc0
1756 #define PRIM1          0xd0
1757 #define PRIM2          0xe0
1758 #define PRIM3          0xf0
1759
1760 #ifdef WORKSTATION
1761
1762 char *prim_name[48] =
1763   {
1764     "prim #%number?",
1765     "prim #%+",
1766     "prim #%-",
1767     "prim #%*",
1768     "prim #%quotient",
1769     "prim #%remainder",
1770     "prim #%neg",
1771     "prim #%=",
1772     "prim #%<",
1773     "prim #%ior",
1774     "prim #%>",
1775     "prim #%xor",
1776     "prim #%pair?",
1777     "prim #%cons",
1778     "prim #%car",
1779     "prim #%cdr",
1780     "prim #%set-car!",
1781     "prim #%set-cdr!",
1782     "prim #%null?",
1783     "prim #%eq?",
1784     "prim #%not",
1785     "prim #%get-cont",
1786     "prim #%graft-to-cont",
1787     "prim #%return-to-cont",
1788     "prim #%halt",
1789     "prim #%symbol?",
1790     "prim #%string?",
1791     "prim #%string->list",
1792     "prim #%list->string",
1793     "prim #%prim29",
1794     "prim #%prim30",
1795     "prim #%prim31",
1796     "prim #%print",
1797     "prim #%clock",
1798     "prim #%motor",
1799     "prim #%led",
1800     "prim #%led2-color",
1801     "prim #%getchar-wait",
1802     "prim #%putchar",
1803     "prim #%beep",
1804     "prim #%adc",
1805     "prim #%dac",
1806     "prim #%sernum",
1807     "prim #%prim43",
1808     "push-constant [long]",
1809     "shift",
1810     "pop",
1811     "return",
1812   };
1813
1814 #endif
1815
1816 #define PUSH_ARG1() push_arg1 ()
1817 #define POP() pop()
1818
1819 void push_arg1 (void)
1820 {
1821   env = cons (arg1, env);
1822   arg1 = OBJ_FALSE;
1823 }
1824
1825 obj pop (void)
1826 {
1827   obj o = ram_get_car (env);
1828   env = ram_get_cdr (env);
1829   return o;
1830 }
1831
1832 void pop_procedure (void)
1833 {
1834   arg1 = POP();
1835
1836   if (IN_RAM(arg1))
1837     {
1838       if (RAM_CONTINUATION(arg1))
1839         ERROR("continuation in pop_procedure"); // TODO this might be legitimate, but for now, we can't do this. if this error comes up, fix this function so it can handle continuations
1840
1841       if (!RAM_CLOSURE(arg1))
1842         TYPE_ERROR("procedure");
1843
1844       entry = ram_get_entry (arg1) + CODE_START; // FOO all addresses in the bytecode should be from 0, not from CODE_START, should be fixed everywhere, but might not be
1845     }
1846   else if (IN_ROM(arg1))
1847     {
1848       if (ROM_CONTINUATION(arg1))
1849         ERROR("continuation in pop_procedure"); // TODO same as above
1850
1851       if (!ROM_CLOSURE(arg1))
1852         TYPE_ERROR("procedure");
1853
1854       entry = rom_get_entry (arg1) + CODE_START;
1855     }
1856   else
1857     TYPE_ERROR("procedure");
1858 }
1859
1860 void handle_arity_and_rest_param (void)
1861 {
1862   uint8 np;
1863
1864   np = rom_get (entry++);
1865
1866   if ((np & 0x80) == 0)
1867     {
1868       if (na != np)
1869         ERROR("wrong number of arguments");
1870     }
1871   else
1872     {
1873       np = ~np;
1874
1875       if (na < np)
1876         ERROR("wrong number of arguments");
1877
1878       arg3 = OBJ_NULL;
1879
1880       while (na > np)
1881         {
1882           arg4 = POP();
1883
1884           arg3 = cons (arg4, arg3);
1885           arg4 = OBJ_FALSE;
1886
1887           na--;
1888         }
1889
1890       arg1 = cons (arg3, arg1);
1891       arg3 = OBJ_FALSE; // TODO changed nothing with the new new closures, everything looks ok
1892     }
1893 }
1894
1895 void build_env (void)
1896 {
1897   while (na != 0)
1898     {
1899       arg3 = POP();
1900
1901       arg1 = cons (arg3, arg1);
1902
1903       na--;
1904     }
1905
1906   arg3 = OBJ_FALSE; // TODO changed nothing here either
1907 }
1908
1909 void save_cont (void)
1910 { // BARF probably a problem here
1911   // the second half is a closure
1912   /* second_half = alloc_ram_cell_init (CLOSURE_FIELD0 | ((pc & 0xf800) >> 11), */
1913   /*                                 (pc & 0x07f8) >> 3, */
1914   /*                                 ((pc & 0x0007) << 5) | (env >> 8), */
1915   /*                                 env & 0xff); */
1916   second_half = alloc_ram_cell_init (CLOSURE_FIELD0 | (pc >> 11),
1917                                      (pc >> 3) & 0xff, // BREGG
1918                                      ((pc & 0x0007) << 5) | (env >> 8),
1919                                      env & 0xff);
1920   // BREGG problem is, we add the start twice, in get entry, and somewhere else, but pc doesn't have it initially
1921   cont = alloc_ram_cell_init (COMPOSITE_FIELD0 | (cont >> 8),
1922                               cont & 0xff,
1923                               CONTINUATION_FIELD2 | (second_half >> 8),
1924                               second_half & 0xff);
1925 }
1926
1927 void interpreter (void)
1928 {
1929   init_ram_heap ();
1930
1931   pc = (CODE_START + 4) + ((rom_addr)rom_get (CODE_START+2) << 2);
1932
1933   BEGIN_DISPATCH();
1934
1935   /***************************************************************************/
1936   CASE(PUSH_CONSTANT1);
1937
1938   IF_TRACE(printf("  (push-constant "); show (bytecode_lo4); printf (")\n"));
1939
1940   arg1 = bytecode_lo4;
1941
1942   PUSH_ARG1();
1943
1944   DISPATCH();
1945
1946   /***************************************************************************/
1947   CASE(PUSH_CONSTANT2);
1948
1949   IF_TRACE(printf("  (push-constant "); show (bytecode_lo4+16); printf (")\n"));
1950   arg1 = bytecode_lo4+16;
1951
1952   PUSH_ARG1();
1953
1954   DISPATCH();
1955
1956   /***************************************************************************/
1957   CASE(PUSH_STACK1);
1958
1959   IF_TRACE(printf("  (push-stack %d)\n", bytecode_lo4));
1960
1961   arg1 = env;
1962
1963   while (bytecode_lo4 != 0)
1964     {
1965       arg1 = ram_get_cdr (arg1);
1966       bytecode_lo4--;
1967     }
1968
1969   arg1 = ram_get_car (arg1); // TODO BARF what to do if we want to get something in the env of a continuation ? will it happen, or only when called, when it becomes a simple closure ? if only when a closure, we're fine, I guess, since 1 is added to the offset by the compiler to skip the closure
1970
1971   PUSH_ARG1();
1972
1973   DISPATCH();
1974
1975   /***************************************************************************/
1976   CASE(PUSH_STACK2);
1977
1978   IF_TRACE(printf("  (push-stack %d)\n", bytecode_lo4+16));
1979
1980   bytecode_lo4 += 16;
1981
1982   arg1 = env;
1983
1984   while (bytecode_lo4 != 0)
1985     {
1986       arg1 = ram_get_cdr (arg1);
1987       bytecode_lo4--;
1988     }
1989
1990   arg1 = ram_get_car (arg1);
1991
1992   PUSH_ARG1();
1993
1994   DISPATCH();
1995
1996   /***************************************************************************/
1997   CASE(PUSH_GLOBAL);
1998
1999   IF_TRACE(printf("  (push-global %d)\n", bytecode_lo4));
2000
2001   arg1 = get_global (bytecode_lo4);
2002
2003   PUSH_ARG1();
2004
2005   DISPATCH();
2006
2007   /***************************************************************************/
2008   CASE(SET_GLOBAL);
2009
2010   IF_TRACE(printf("  (set-global %d)\n", bytecode_lo4));
2011
2012   set_global (bytecode_lo4, POP());
2013
2014   DISPATCH();
2015
2016   /***************************************************************************/
2017   CASE(CALL);
2018
2019   IF_TRACE(printf("  (call %d)\n", bytecode_lo4));
2020
2021   na = bytecode_lo4;
2022
2023   pop_procedure (); // TODO FOOBAR can we call a continuation ? if so, fix pop_procedure
2024   handle_arity_and_rest_param ();
2025   build_env ();
2026   save_cont ();
2027
2028   env = arg1;
2029   pc = entry;
2030
2031   arg1 = OBJ_FALSE;
2032
2033   DISPATCH();
2034
2035   /***************************************************************************/
2036   CASE(JUMP);
2037
2038   IF_TRACE(printf("  (jump %d)\n", bytecode_lo4));
2039
2040   na = bytecode_lo4;
2041
2042   pop_procedure ();
2043   handle_arity_and_rest_param ();
2044   build_env ();
2045
2046   env = arg1;
2047   pc = entry;
2048
2049   arg1 = OBJ_FALSE;
2050
2051   DISPATCH();
2052
2053   /***************************************************************************/
2054   CASE(CALL_TOPLEVEL);
2055
2056   FETCH_NEXT_BYTECODE();
2057   second_half = bytecode; // TODO make sure second_half is not already in use
2058
2059   FETCH_NEXT_BYTECODE();
2060
2061   IF_TRACE(printf("  (call-toplevel 0x%04x)\n", ((second_half << 8) | bytecode) + CODE_START));
2062
2063   entry = (second_half << 8) + bytecode + CODE_START; // TODO FOOBAR we have the last 4 bits of the opcode free, to do pretty much anything
2064   arg1 = OBJ_NULL;
2065
2066   na = rom_get (entry++);
2067
2068   build_env ();
2069   save_cont ();
2070
2071   env = arg1;
2072   pc = entry;
2073
2074   arg1 = OBJ_FALSE;
2075
2076   DISPATCH();
2077
2078   /***************************************************************************/
2079   CASE(JUMP_TOPLEVEL);
2080
2081   FETCH_NEXT_BYTECODE();
2082   second_half = bytecode; // TODO make sure second_half is not already in use
2083
2084   FETCH_NEXT_BYTECODE();
2085
2086   IF_TRACE(printf("  (jump-toplevel 0x%04x)\n", ((second_half << 8) | bytecode) + CODE_START));
2087
2088   entry = (second_half << 8) + bytecode + CODE_START; // TODO this is a common pattern
2089   arg1 = OBJ_NULL;
2090
2091   na = rom_get (entry++);
2092
2093   build_env ();
2094
2095   env = arg1;
2096   pc = entry;
2097
2098   arg1 = OBJ_FALSE;
2099
2100   DISPATCH();
2101
2102   /***************************************************************************/
2103   CASE(GOTO);
2104
2105   FETCH_NEXT_BYTECODE();
2106   second_half = bytecode;
2107
2108   FETCH_NEXT_BYTECODE();
2109
2110   // TODO goto's use 12-bit addresses, unlike calls and jumps, which use 16, is it ok ?
2111   // actually, the compiler gives them 16 bit addresses now, it seems
2112   // that means we have even more free instructions, but that now even gotos are on 3 bytes
2113   IF_TRACE(printf("  (goto 0x%04x)\n", ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode));
2114
2115   pc = (second_half << 8) + bytecode + CODE_START;
2116   /* pc = ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode; */ // TODO not anymore
2117
2118   DISPATCH();
2119
2120   /***************************************************************************/
2121   CASE(GOTO_IF_FALSE);
2122
2123   FETCH_NEXT_BYTECODE();
2124   second_half = bytecode;
2125
2126   FETCH_NEXT_BYTECODE();
2127
2128   IF_TRACE(printf("  (goto-if-false 0x%04x)\n", ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode));
2129
2130   if (POP() == OBJ_FALSE)
2131     pc = (second_half << 8) + bytecode + CODE_START;
2132     /* pc = ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode; */
2133
2134   DISPATCH();
2135
2136   /***************************************************************************/
2137   CASE(CLOSURE);
2138
2139   FETCH_NEXT_BYTECODE();
2140   second_half = bytecode;
2141
2142   FETCH_NEXT_BYTECODE();
2143
2144   IF_TRACE(printf("  (closure 0x%04x)\n", (second_half << 8) | bytecode));
2145   // TODO original had CODE_START, while the real code below didn't
2146
2147   /* arg2 = POP(); // #f TODO should be, at least, and not used anymore, would it break anything not to use it in the compiler anymore ? maybe try, it's not urgent, but would be nice */ // TODO we got rid of this in the compiler
2148   arg3 = POP(); // env
2149
2150   entry = (second_half << 8) | bytecode; // TODO original had no CODE_START, why ?
2151
2152   arg1 = alloc_ram_cell_init (CLOSURE_FIELD0 | (second_half >> 3),
2153                               ((second_half & 0x07) << 5) | (bytecode >> 3),
2154                               ((bytecode & 0x07) << 5) |((arg3 & 0x1f00) >> 8),
2155                               arg3 & 0xff);
2156
2157   PUSH_ARG1();
2158
2159   arg2 = OBJ_FALSE;
2160   arg3 = OBJ_FALSE;
2161
2162   DISPATCH();
2163
2164   /***************************************************************************/
2165   CASE(PRIM1);
2166
2167   IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4]));
2168
2169   switch (bytecode_lo4)
2170     {
2171     case 0:
2172       arg1 = POP();  prim_numberp ();  PUSH_ARG1();  break;
2173     case 1:
2174       arg2 = POP();  arg1 = POP();  prim_add ();      PUSH_ARG1();  break;
2175     case 2:
2176       arg2 = POP();  arg1 = POP();  prim_sub ();      PUSH_ARG1();  break;
2177     case 3:
2178       arg2 = POP();  arg1 = POP();  prim_mul ();      PUSH_ARG1();  break;
2179     case 4:
2180       arg2 = POP();  arg1 = POP();  prim_div ();      PUSH_ARG1();  break;
2181     case 5:
2182       arg2 = POP();  arg1 = POP();  prim_rem ();      PUSH_ARG1();  break;
2183     case 6:
2184       arg1 = POP();  prim_neg ();      PUSH_ARG1();  break;
2185     case 7:
2186       arg2 = POP();  arg1 = POP();  prim_eq ();       PUSH_ARG1();  break;
2187     case 8:
2188       arg2 = POP();  arg1 = POP();  prim_lt ();       PUSH_ARG1();  break;
2189     case 9:
2190       arg2 = POP(); arg1 = POP(); prim_ior (); PUSH_ARG1(); break;
2191     case 10:
2192       arg2 = POP();  arg1 = POP();  prim_gt ();       PUSH_ARG1();  break;
2193     case 11:
2194       arg2 = POP(); arg1 = POP(); prim_xor (); PUSH_ARG1(); break;
2195     case 12:
2196       arg1 = POP();  prim_pairp ();    PUSH_ARG1();  break;
2197     case 13:
2198       arg2 = POP();  arg1 = POP();  prim_cons ();     PUSH_ARG1();  break;
2199     case 14:
2200       arg1 = POP();  prim_car ();      PUSH_ARG1();  break;
2201     case 15:
2202       arg1 = POP();  prim_cdr ();      PUSH_ARG1();  break;
2203     }
2204
2205   DISPATCH();
2206
2207   /***************************************************************************/
2208   CASE(PRIM2);
2209
2210   IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4+16]));
2211
2212   switch (bytecode_lo4)
2213     {
2214     case 0:
2215       arg2 = POP();  arg1 = POP();  prim_set_car ();                break;
2216     case 1:
2217       arg2 = POP();  arg1 = POP();  prim_set_cdr ();                break;
2218     case 2:
2219       arg1 = POP();  prim_nullp ();    PUSH_ARG1();  break;
2220     case 3:
2221       arg2 = POP();  arg1 = POP();  prim_eqp ();      PUSH_ARG1();  break;
2222     case 4:
2223       arg1 = POP();  prim_not ();      PUSH_ARG1();  break;
2224     case 5:
2225       /* prim #%get-cont */
2226       arg1 = cont;
2227       PUSH_ARG1();
2228       break;
2229     case 6:
2230       /* prim #%graft-to-cont */
2231
2232       arg1 = POP(); /* thunk to call */
2233       cont = POP(); /* continuation */
2234
2235       PUSH_ARG1(); // TODO we don't call the continuation, no change was needed
2236
2237       na = 0;
2238
2239       pop_procedure ();
2240       handle_arity_and_rest_param ();
2241       build_env ();
2242
2243       env = arg1;
2244       pc = entry;
2245
2246       arg1 = OBJ_FALSE;
2247
2248       break;
2249     case 7:
2250       /* prim #%return-to-cont */
2251
2252       arg1 = POP(); /* value to return */
2253       cont = POP(); /* continuation */
2254
2255       second_half = ram_get_cdr (cont);
2256
2257       pc = ram_get_entry (second_half);
2258
2259       env = ram_get_cdr (second_half);
2260       cont = ram_get_car (cont);
2261
2262       PUSH_ARG1();
2263
2264       break;
2265     case 8:
2266       /* prim #%halt */
2267       return;
2268     case 9:
2269       /* prim #%symbol? */
2270       arg1 = POP();  prim_symbolp ();  PUSH_ARG1();  break;
2271     case 10:
2272       /* prim #%string? */
2273       arg1 = POP();  prim_stringp ();  PUSH_ARG1();  break;
2274     case 11:
2275       /* prim #%string->list */
2276       arg1 = POP();  prim_string2list ();  PUSH_ARG1();  break;
2277     case 12:
2278       /* prim #%list->string */
2279       arg1 = POP();  prim_list2string ();  PUSH_ARG1();  break;
2280 #if 0
2281     case 13:
2282       break;
2283     case 14:
2284       break;
2285     case 15:
2286       break;
2287 #endif
2288     }
2289
2290   DISPATCH();
2291
2292   /***************************************************************************/
2293   CASE(PRIM3);
2294
2295   IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4+32]));
2296
2297   switch (bytecode_lo4)
2298     {
2299     case 0:
2300       /* prim #%print */
2301       arg1 = POP();
2302       prim_print ();
2303       break;
2304     case 1:
2305       /* prim #%clock */
2306       prim_clock ();  PUSH_ARG1();  break;
2307     case 2:
2308       /* prim #%motor */
2309       arg2 = POP();  arg1 = POP();  prim_motor ();  break;
2310     case 3:
2311       /* prim #%led */
2312       arg3 = POP();  arg2 = POP();  arg1 = POP();  prim_led ();  ;break;
2313     case 4:
2314       /* prim #%led2-color */
2315       arg1 = POP();  prim_led2_color ();  break;
2316     case 5:
2317       /* prim #%getchar-wait */
2318       arg2 = POP();  arg1 = POP();  prim_getchar_wait ();  PUSH_ARG1();  break;
2319     case 6:
2320       /* prim #%putchar */
2321       arg2 = POP();  arg1 = POP();  prim_putchar ();  break;
2322     case 7:
2323       /* prim #%beep */
2324       arg2 = POP();  arg1 = POP();  prim_beep ();  break;
2325     case 8:
2326       /* prim #%adc */
2327       arg1 = POP();  prim_adc ();  PUSH_ARG1();  break;
2328     case 9:
2329       /* prim #%dac */
2330       arg1 = POP();  prim_dac ();  break;
2331     case 10:
2332       /* prim #%sernum */
2333       prim_sernum ();  PUSH_ARG1();  break;
2334 #if 0
2335     case 11:
2336       break;
2337 #endif
2338     case 12:
2339       /* push-constant [long] */
2340       FETCH_NEXT_BYTECODE();
2341       second_half = bytecode;
2342       FETCH_NEXT_BYTECODE();
2343       arg1 = (second_half << 8) | bytecode;
2344       PUSH_ARG1();
2345       break;
2346     case 13:
2347       /* shift */
2348       arg1 = POP();
2349       POP();
2350       PUSH_ARG1();
2351       break;
2352     case 14:
2353       /* pop */
2354       POP();
2355       break;
2356     case 15:
2357       /* return */
2358       arg1 = POP();
2359       second_half = ram_get_cdr (cont);
2360       pc = ram_get_entry (second_half);
2361       env = ram_get_cdr (second_half);
2362       cont = ram_get_car (cont);
2363       PUSH_ARG1();
2364       break;
2365     }
2366
2367   DISPATCH();
2368
2369   /***************************************************************************/
2370
2371   END_DISPATCH();
2372 }
2373
2374 /*---------------------------------------------------------------------------*/
2375
2376 #ifdef WORKSTATION
2377
2378 void usage (void)
2379 {
2380   printf ("usage: sim file.hex\n");
2381   exit (1);
2382 }
2383
2384 int main (int argc, char *argv[])
2385 {
2386   int errcode = 1;
2387   rom_addr rom_start_addr = 0;
2388
2389   if (argc > 1 && argv[1][0] == '-' && argv[1][1] == 's')
2390     {
2391       int h1;
2392       int h2;
2393       int h3;
2394       int h4;
2395
2396       if ((h1 = hex (argv[1][2])) < 0 ||
2397           (h2 = hex (argv[1][3])) < 0 ||
2398           (h3 = hex (argv[1][4])) != 0 ||
2399           (h4 = hex (argv[1][5])) != 0 ||
2400           argv[1][6] != '\0')
2401         usage ();
2402
2403       rom_start_addr = (h1 << 12) | (h2 << 8) | (h3 << 4) | h4;
2404
2405       argv++;
2406       argc--;
2407     }
2408
2409 #ifdef DEBUG
2410   printf ("Start address = 0x%04x\n", rom_start_addr);
2411 #endif
2412
2413   if (argc != 2)
2414     usage ();
2415
2416   if (!read_hex_file (argv[1]))
2417     printf ("*** Could not read hex file \"%s\"\n", argv[1]);
2418   else
2419     {
2420       int i;
2421
2422       if (rom_get (CODE_START+0) != 0xfb ||
2423           rom_get (CODE_START+1) != 0xd7)
2424         printf ("*** The hex file was not compiled with PICOBIT\n");
2425       else
2426         {
2427 #if 0
2428           for (i=0; i<8192; i++)
2429             if (rom_get (i) != 0xff)
2430               printf ("rom_mem[0x%04x] = 0x%02x\n", i, rom_get (i));
2431 #endif
2432
2433           interpreter ();
2434
2435 #ifdef DEBUG_GC
2436           printf ("**************** memory needed = %d\n", max_live+1);
2437 #endif
2438         }
2439     }
2440
2441   return errcode;
2442 }
2443
2444 #endif
2445
2446 /*---------------------------------------------------------------------------*/