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
 433 obj get_global (uint8 i)
 434 {
 435   return globals[i];
 436 }
 437
 438 void set_global (uint8 i, obj o)
 439 {
 440   globals[i] = o;
 441 }
 442
 443 /*---------------------------------------------------------------------------*/
 444
 445 /* Interface to GC */
 446
 447 /* GC tags are in the top 2 bits of field 0 */
 448 #define GC_TAG_0_LEFT   (1<<5)
 449 // TODO was 3<<5, changed to play nice with procedures and bignums, but should actually set only this bit, not clear the other
 450 #define GC_TAG_1_LEFT   (2<<5)
 451 #define GC_TAG_UNMARKED (0<<5)  /* must be 0 */ // TODO FOOBAR is it ok ? eevn for bignums ?
 452
 453 /* Number of object fields of objects in ram */
 454 #define HAS_2_OBJECT_FIELDS(visit) (RAM_PAIR(visit) || RAM_CONTINUATION(visit))
 455 #define HAS_1_OBJECT_FIELD(visit)  (RAM_COMPOSITE(visit) || RAM_CLOSURE(visit))
 456 // 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)
 457 // TODO if we ever have true bignums, bignums will have 1 object field
 458
 459 #define NIL OBJ_FALSE
 460
 461 /*---------------------------------------------------------------------------*/
 462
 463 /* Garbage collector */
 464
 465 obj free_list; /* list of unused cells */
 466
 467 obj arg1; /* root set */
 468 obj arg2;
 469 obj arg3;
 470 obj arg4;
 471 obj cont;
 472 obj env;
 473
 474 uint8 na; /* interpreter variables */ // TODO what's na ?
 475 rom_addr pc;
 476 rom_addr entry;
 477 uint8 bytecode;
 478 uint8 bytecode_hi4;
 479 uint8 bytecode_lo4;
 480 obj second_half; /* the second half of continuations */
 481 int32 a1;
 482 int32 a2;
 483 int32 a3;
 484
 485 void init_ram_heap (void)
 486 {
 487   uint8 i;
 488   obj o = MAX_RAM_ENCODING;
 489
 490   free_list = 0;
 491
 492   while (o >= MIN_RAM_ENCODING)
 493     {
 494       ram_set_gc_tags (o, GC_TAG_UNMARKED);
 495       ram_set_car (o, free_list);
 496       free_list = o;
 497       o--;
 498     }
 499
 500   for (i=0; i<GLOVARS; i++)
 501     set_global (i, OBJ_FALSE);
 502
 503   arg1 = OBJ_FALSE;
 504   arg2 = OBJ_FALSE;
 505   arg3 = OBJ_FALSE;
 506   arg4 = OBJ_FALSE;
 507   cont = OBJ_FALSE;
 508   env  = OBJ_NULL;
 509   second_half = OBJ_FALSE;
 510 }
 511
 512 void mark (obj temp)
 513 {
 514   /* mark phase */
 515
 516   obj stack; // TODO do we need a stack ? since we have 0-1-2 children, we could do deutsche schorr waite
 517   obj visit;
 518
 519   if (IN_RAM(temp))
 520     {
 521       visit = NIL;
 522
 523     push:
 524
 525       stack = visit;
 526       visit = temp;
 527
 528       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));
 529
 530       /*
 531        * Four cases are possible:
 532        *
 533        * A)
 534        *                          stack  visit tag F1  F2  F3
 535        *                           NIL    |   +---+---+---+---+
 536        *                                  +-> | ? |   |   |   |
 537        *                                      +---+---+---+---+
 538        *
 539        * B)
 540        *          tag F1  F2  F3  stack  visit tag F1  F2  F3
 541        *         +---+---+---+---+   |    |   +---+---+---+---+
 542        *         | 1 |   |   |   | <-+    +-> | ? |   |   |   |
 543        *         +---+---+---+-|-+            +---+---+---+---+
 544        *     <-----------------+
 545        *
 546        * C)
 547        *          tag F1  F2  F3  stack  visit tag F1  F2  F3
 548        *         +---+---+---+---+   |    |   +---+---+---+---+
 549        *         | 2 |   |   |   | <-+    +-> | ? |   |   |   |
 550        *         +---+---+-|-+---+            +---+---+---+---+
 551        *     <-------------+
 552        *
 553        * D)
 554        *          tag F1  F2  F3  stack  visit tag F1  F2  F3
 555        *         +---+---+---+---+   |    |   +---+---+---+---+
 556        *         | 3 |   |   |   | <-+    +-> | ? |   |   |   |
 557        *         +---+-|-+---+---+            +---+---+---+---+
 558        *     <---------+
 559        */
 560       // TODO since no-one has 3 fields anymore, not really 4 cases ?
 561
 562       //      if (ram_get_gc_tags (visit) != GC_TAG_UNMARKED) // TODO always matches procedures, WRONG, maybe check only the right gc bit ?/
 563       if (ram_get_gc_tags (visit) & 0x2f) // TODO we check only the last gc bit
 564         IF_GC_TRACE(printf ("case 1\n")); // TODO are there cases where checking only the last gc bit is wrong ?
 565       // TODO FOOBAR ok, with our new way, what do we check here ?
 566       else
 567         {
 568           if (HAS_2_OBJECT_FIELDS(visit))
 569             {
 570               IF_GC_TRACE(printf ("case 5\n"));
 571               // TODO we don't have cases 2-4 anymore
 572
 573             visit_field2:
 574
 575               temp = ram_get_cdr (visit);
 576
 577               if (IN_RAM(temp))
 578                 {
 579                   IF_GC_TRACE(printf ("case 6\n"));
 580                   ram_set_gc_tags (visit, GC_TAG_1_LEFT);
 581                   ram_set_cdr (visit, stack);
 582                   goto push;
 583                 }
 584
 585               IF_GC_TRACE(printf ("case 7\n"));
 586
 587               goto visit_field1;
 588             }
 589
 590           if (HAS_1_OBJECT_FIELD(visit))
 591             {
 592               IF_GC_TRACE(printf ("case 8\n"));
 593
 594             visit_field1:
 595
 596               temp = ram_get_car (visit);
 597
 598               if (IN_RAM(temp))
 599                 {
 600                   IF_GC_TRACE(printf ("case 9\n"));
 601                   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
 602                   ram_set_car (visit, stack);
 603                   goto push;
 604                 }
 605
 606               IF_GC_TRACE(printf ("case 10\n"));
 607             }
 608           else
 609             IF_GC_TRACE(printf ("case 11\n"));
 610
 611           ram_set_gc_tag0 (visit, GC_TAG_0_LEFT); // TODO changed, same as above
 612         }
 613
 614     pop:
 615
 616       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));
 617
 618       if (stack != NIL)
 619         {
 620           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
 621             {
 622               IF_GC_TRACE(printf ("case 13\n"));
 623
 624               temp = ram_get_cdr (stack);  /* pop through field 2 */
 625               ram_set_cdr (stack, visit);
 626               visit = stack;
 627               stack = temp;
 628
 629               goto visit_field1;
 630             }
 631
 632           IF_GC_TRACE(printf ("case 14\n"));
 633
 634           temp = ram_get_car (stack);  /* pop through field 1 */
 635           ram_set_car (stack, visit);
 636           visit = stack;
 637           stack = temp;
 638
 639           goto pop;
 640         }
 641     }
 642 }
 643
 644 #ifdef DEBUG_GC
 645 int max_live = 0;
 646 #endif
 647
 648 void sweep (void)
 649 {
 650   /* sweep phase */
 651
 652 #ifdef DEBUG_GC
 653   int n = 0;
 654 #endif
 655
 656   obj visit = MAX_RAM_ENCODING;
 657
 658   free_list = 0;
 659
 660   while (visit >= MIN_RAM_ENCODING)
 661     {
 662       if ((RAM_COMPOSITE(visit) && (ram_get_gc_tags (visit) == GC_TAG_UNMARKED)) || (ram_get_gc_tags (visit) & GC_TAG_0_LEFT)) /* unmarked? */
 663         // TODO now we check only 1 bit if the object has only 1 mark bit
 664         {
 665           ram_set_car (visit, free_list);
 666           free_list = visit;
 667         }
 668       else
 669         {
 670           if (RAM_COMPOSITE(visit))
 671             ram_set_gc_tags (visit, GC_TAG_UNMARKED);
 672           else // only 1 mark bit to unset
 673             ram_set_gc_tag0 (visit, GC_TAG_UNMARKED);
 674 #ifdef DEBUG_GC
 675           n++;
 676 #endif
 677         }
 678       visit--;
 679     }
 680
 681 #ifdef DEBUG_GC
 682   if (n > max_live)
 683     {
 684       max_live = n;
 685       printf ("**************** memory needed = %d\n", max_live+1);
 686       fflush (stdout);
 687     }
 688 #endif
 689 }
 690
 691 void gc (void)
 692 {
 693   uint8 i;
 694
 695   mark (arg1);
 696   mark (arg2);
 697   mark (arg3);
 698   mark (arg4);
 699   mark (cont);
 700   mark (env);
 701
 702   for (i=0; i<GLOVARS; i++)
 703     mark (get_global (i));
 704
 705   sweep ();
 706 }
 707
 708 obj alloc_ram_cell (void)
 709 {
 710   obj o;
 711
 712 #ifdef DEBUG_GC
 713   gc ();
 714 #endif
 715
 716   if (free_list == 0)
 717     {
 718 #ifndef DEBUG_GC
 719       gc ();
 720       if (free_list == 0)
 721 #endif
 722         ERROR("memory is full");
 723     }
 724
 725   o = free_list;
 726
 727   free_list = ram_get_field1 (o);
 728
 729   return o;
 730 }
 731
 732 obj alloc_ram_cell_init (uint8 f0, uint8 f1, uint8 f2, uint8 f3)
 733 {
 734   obj o = alloc_ram_cell ();
 735
 736   ram_set_field0 (o, f0);
 737   ram_set_field1 (o, f1);
 738   ram_set_field2 (o, f2);
 739   ram_set_field3 (o, f3);
 740
 741   return o;
 742 }
 743
 744 /*---------------------------------------------------------------------------*/
 745
 746 int32 decode_int (obj o)
 747 {
 748   uint8 u;
 749   uint8 h;
 750   uint8 l;
 751
 752   if (o < MIN_FIXNUM_ENCODING)
 753     TYPE_ERROR("integer");
 754
 755   if (o <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM)))
 756     return DECODE_FIXNUM(o);
 757
 758   if (IN_RAM(o))
 759     {
 760       if (!RAM_BIGNUM(o))
 761         TYPE_ERROR("integer");
 762
 763       u = ram_get_field1 (o);
 764       h = ram_get_field2 (o);
 765       l = ram_get_field3 (o);
 766     }
 767   else if (IN_ROM(o))
 768     {
 769       if (!ROM_BIGNUM(o))
 770         TYPE_ERROR("integer");
 771
 772       u = rom_get_field1 (o);
 773       h = rom_get_field2 (o);
 774       l = rom_get_field3 (o);
 775     }
 776   else
 777     TYPE_ERROR("integer");
 778
 779   if (u >= 128)
 780     return ((int32)((((int16)u - 256) << 8) + h) << 8) + l;
 781
 782   return ((int32)(((int16)u << 8) + h) << 8) + l;
 783 }
 784
 785 obj encode_int (int32 n)
 786 {
 787   if (n >= MIN_FIXNUM && n <= MAX_FIXNUM)
 788     return ENCODE_FIXNUM(n);
 789
 790   return alloc_ram_cell_init (BIGNUM_FIELD0, n >> 16, n >> 8, n);
 791 }
 792
 793 /*---------------------------------------------------------------------------*/
 794
 795 #ifdef WORKSTATION
 796
 797 void show (obj o)
 798 {
 799 #if 0
 800   printf ("[%d]", o);
 801 #endif
 802
 803   if (o == OBJ_FALSE)
 804     printf ("#f");
 805   else if (o == OBJ_TRUE)
 806     printf ("#t");
 807   else if (o == OBJ_NULL)
 808     printf ("()");
 809   else if (o <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM)))
 810     printf ("%d", DECODE_FIXNUM(o));
 811   else
 812     {
 813       uint8 in_ram;
 814
 815       if (IN_RAM(o))
 816         in_ram = 1;
 817       else
 818         in_ram = 0;
 819
 820       if ((in_ram && RAM_BIGNUM(o)) || (!in_ram && ROM_BIGNUM(o)))
 821         {
 822           printf ("\n%d\n", ROM_BIGNUM(o)); // TODO debug
 823           printf ("%d", decode_int (o)); // TODO gets here, but shouldn't, with test-globals
 824         }
 825       else if ((in_ram && RAM_COMPOSITE(o)) || ROM_COMPOSITE(o))
 826         {
 827           obj car;
 828           obj cdr;
 829
 830           if (in_ram && RAM_PAIR(o))
 831             {
 832               car = ram_get_car (o);
 833               cdr = ram_get_cdr (o);
 834               printf ("(");
 835
 836             loop_ram:
 837               show (car);
 838
 839               if (cdr == OBJ_NULL)
 840                 printf (")");
 841               else if (RAM_PAIR(cdr))
 842                 {
 843                   car = ram_get_car (cdr);
 844                   cdr = ram_get_cdr (cdr);
 845
 846                   printf (" ");
 847                   goto loop_ram;
 848                 }
 849               else
 850                 {
 851                   printf (" . ");
 852                   show (cdr);
 853                   printf (")");
 854                 }
 855             }
 856           else if (!in_ram && ROM_PAIR(o))
 857             {
 858               car = rom_get_car (o);
 859               cdr = rom_get_cdr (o);
 860               printf ("(");
 861             loop_rom:
 862               show (car);
 863
 864               if (cdr == OBJ_NULL)
 865                 printf (")");
 866               else if (ROM_PAIR(cdr))
 867                 {
 868                   car = rom_get_car (cdr);
 869                   cdr = rom_get_cdr (cdr);
 870
 871                   printf (" ");
 872                   goto loop_rom;
 873                 }
 874               else // TODO lots of repetition
 875                 {
 876                   printf (" . ");
 877                   show (cdr);
 878                   printf (")");
 879                 }
 880             }
 881           else if ((in_ram && RAM_SYMBOL(o)) || (!in_ram && ROM_SYMBOL(o)))
 882             printf ("#<symbol>");
 883           else if ((in_ram && RAM_STRING(o)) || (!in_ram && ROM_STRING(o)))
 884             printf ("#<string>");
 885           else if ((in_ram && RAM_VECTOR(o)) || (!in_ram && ROM_VECTOR(o)))
 886             printf ("#<vector>");
 887         }
 888       else
 889         {
 890           /* obj env; */
 891           /* obj parent_cont; */
 892           /* rom_addr pc; */
 893
 894           /* if (IN_RAM(o)) */
 895           /*   env = ram_get_car (o); */
 896           /* else */
 897           /*   env = rom_get_cdr (o); */
 898
 899           /* if (IN_RAM(o)) */
 900           /*   parent_cont = ram_get_field2 (o); */
 901           /* else */
 902           /*   parent_cont = rom_get_field2 (o); */
 903
 904           /* if (IN_RAM(o)) */
 905           /*   pc = ((rom_addr)(field0 + ((CODE_START>>8) - CLOSURE_FIELD0)) << 8) + ram_get_field3 (o); */
 906           /* else */
 907           /*   pc = ((rom_addr)(field0 + ((CODE_START>>8) - CLOSURE_FIELD0)) << 8) + rom_get_field3 (o); */
 908
 909           /* printf ("{0x%04x ", pc); */
 910           /* show (env); */
 911           /* printf (" "); */
 912           /* show (parent_cont); */
 913           /* printf ("}"); */ // TODO the representation of procedures changed
 914           printf ("#<procedure>");
 915         }
 916     }
 917
 918   fflush (stdout);
 919 }
 920
 921 void show_state (rom_addr pc)
 922 {
 923   printf ("pc=0x%04x bytecode=0x%02x env=", pc, rom_get (pc));
 924   show (env);
 925   printf (" cont=");
 926   show (cont);
 927   printf ("\n");
 928   fflush (stdout);
 929 }
 930
 931 void print (obj o)
 932 {
 933   show (o);
 934   printf ("\n");
 935   fflush (stdout);
 936 }
 937
 938 #endif
 939
 940 /*---------------------------------------------------------------------------*/
 941
 942 /* Integer operations */
 943
 944 #define encode_bool(x) ((obj)(x))
 945
 946 void prim_numberp (void)
 947 {
 948   if (arg1 >= MIN_FIXNUM_ENCODING
 949       && arg1 <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM)))
 950     arg1 = OBJ_TRUE;
 951   else
 952     {
 953       if (IN_RAM(arg1))
 954         arg1 = encode_bool (RAM_BIGNUM(arg1));
 955       else if (IN_ROM(arg1))
 956         arg1 = encode_bool (ROM_BIGNUM(arg1));
 957       else
 958         arg1 = OBJ_FALSE;
 959     }
 960 }
 961
 962 void decode_2_int_args (void)
 963 {
 964   a1 = decode_int (arg1);
 965   a2 = decode_int (arg2);
 966 }
 967
 968 void prim_add (void)
 969 {
 970   decode_2_int_args ();
 971   arg1 = encode_int (a1 + a2);
 972   arg2 = OBJ_FALSE;
 973 }
 974
 975 void prim_sub (void)
 976 {
 977   decode_2_int_args ();
 978   arg1 = encode_int (a1 - a2);
 979   arg2 = OBJ_FALSE;
 980 }
 981
 982 void prim_mul (void)
 983 {
 984   decode_2_int_args ();
 985   arg1 = encode_int (a1 * a2);
 986   arg2 = OBJ_FALSE;
 987 }
 988
 989 void prim_div (void)
 990 {
 991   decode_2_int_args ();
 992   if (a2 == 0)
 993     ERROR("divide by 0");
 994   arg1 = encode_int (a1 / a2);
 995   arg2 = OBJ_FALSE;
 996 }
 997
 998 void prim_rem (void)
 999 {
1000   decode_2_int_args ();
1001   if (a2 == 0)
1002     ERROR("divide by 0");
1003   arg1 = encode_int (a1 % a2);
1004   arg2 = OBJ_FALSE;
1005 }
1006
1007 void prim_neg (void)
1008 {
1009   a1 = decode_int (arg1);
1010   arg1 = encode_int (- a1);
1011 }
1012
1013 void prim_eq (void)
1014 {
1015   decode_2_int_args ();
1016   arg1 = encode_bool (a1 == a2);
1017   arg2 = OBJ_FALSE;
1018 }
1019
1020 void prim_lt (void)
1021 {
1022   decode_2_int_args ();
1023   arg1 = encode_bool (a1 < a2);
1024   arg2 = OBJ_FALSE;
1025 }
1026
1027 void prim_gt (void)
1028 {
1029   decode_2_int_args ();
1030   arg1 = encode_bool (a1 > a2);
1031   arg2 = OBJ_FALSE;
1032 }
1033
1034 void prim_ior (void)
1035 {
1036   a1 = decode_int (arg1);
1037   a2 = decode_int (arg2);
1038   arg1 = encode_int (a1 | a2);
1039   arg2 = OBJ_FALSE;
1040 }
1041
1042 void prim_xor (void)
1043 {
1044   a1 = decode_int (arg1);
1045   a2 = decode_int (arg2);
1046   arg1 = encode_int (a1 ^ a2);
1047   arg2 = OBJ_FALSE;
1048 }
1049
1050
1051 /*---------------------------------------------------------------------------*/
1052
1053 /* List operations */
1054
1055 void prim_pairp (void)
1056 {
1057   if (IN_RAM(arg1))
1058     arg1 = encode_bool (RAM_PAIR(arg1));
1059   else if (IN_ROM(arg1))
1060     arg1 = encode_bool (ROM_PAIR(arg1));
1061   else
1062     arg1 = OBJ_FALSE;
1063 }
1064
1065 obj cons (obj car, obj cdr)
1066 {
1067   return alloc_ram_cell_init (COMPOSITE_FIELD0 | ((car & 0x1f00) >> 8),
1068                               car & 0xff,
1069                               PAIR_FIELD2 | ((cdr & 0x1f00) >> 8),
1070                               cdr & 0xff);
1071 }
1072
1073 void prim_cons (void)
1074 {
1075   arg1 = cons (arg1, arg2);
1076   arg2 = OBJ_FALSE;
1077 }
1078
1079 void prim_car (void)
1080 {
1081   if (IN_RAM(arg1))
1082     {
1083       if (!RAM_PAIR(arg1))
1084         TYPE_ERROR("pair");
1085       arg1 = ram_get_car (arg1);
1086     }
1087   else if (IN_ROM(arg1))
1088     {
1089       if (!ROM_PAIR(arg1))
1090         TYPE_ERROR("pair");
1091       arg1 = rom_get_car (arg1);
1092     }
1093   else
1094     {
1095       TYPE_ERROR("pair");
1096     }
1097 }
1098
1099 void prim_cdr (void)
1100 {
1101   if (IN_RAM(arg1))
1102     {
1103       if (!RAM_PAIR(arg1))
1104         TYPE_ERROR("pair");
1105       arg1 = ram_get_cdr (arg1);
1106     }
1107   else if (IN_ROM(arg1))
1108     {
1109       if (!ROM_PAIR(arg1))
1110         TYPE_ERROR("pair");
1111       arg1 = rom_get_cdr (arg1);
1112     }
1113   else
1114     {
1115       TYPE_ERROR("pair");
1116     }
1117 }
1118
1119 void prim_set_car (void)
1120 {
1121   if (IN_RAM(arg1))
1122     {
1123       if (!RAM_PAIR(arg1))
1124         TYPE_ERROR("pair");
1125
1126       ram_set_car (arg1, arg2);
1127       arg1 = OBJ_FALSE;
1128       arg2 = OBJ_FALSE;
1129     }
1130   else
1131     {
1132       TYPE_ERROR("pair");
1133     }
1134 }
1135
1136 void prim_set_cdr (void)
1137 {
1138   if (IN_RAM(arg1))
1139     {
1140       if (!RAM_PAIR(arg1))
1141         TYPE_ERROR("pair");
1142
1143       ram_set_cdr (arg1, arg2);
1144       arg1 = OBJ_FALSE;
1145       arg2 = OBJ_FALSE;
1146     }
1147   else
1148     {
1149       TYPE_ERROR("pair");
1150     }
1151 }
1152
1153 void prim_nullp (void)
1154 {
1155   arg1 = encode_bool (arg1 == OBJ_NULL);
1156 }
1157
1158 /*---------------------------------------------------------------------------*/
1159
1160 /* Miscellaneous operations */
1161
1162 void prim_eqp (void)
1163 {
1164   arg1 = encode_bool (arg1 == arg2);
1165   arg2 = OBJ_FALSE;
1166 }
1167
1168 void prim_not (void)
1169 {
1170   arg1 = encode_bool (arg1 == OBJ_FALSE);
1171 }
1172
1173 void prim_symbolp (void)
1174 {
1175   if (IN_RAM(arg1))
1176     arg1 = encode_bool (RAM_SYMBOL(arg1));
1177   else if (IN_ROM(arg1))
1178     arg1 = encode_bool (ROM_SYMBOL(arg1));
1179   else
1180     arg1 = OBJ_FALSE;
1181 }
1182
1183 void prim_stringp (void)
1184 {
1185   if (IN_RAM(arg1))
1186     arg1 = encode_bool (RAM_STRING(arg1));
1187   else if (IN_ROM(arg1))
1188     arg1 = encode_bool (ROM_STRING(arg1));
1189   else
1190     arg1 = OBJ_FALSE;
1191 }
1192
1193 void prim_string2list (void)
1194 {
1195   if (IN_RAM(arg1))
1196     {
1197       if (!RAM_STRING(arg1))
1198         TYPE_ERROR("string");
1199
1200       arg1 = ram_get_car (arg1);
1201     }
1202   else if (IN_ROM(arg1))
1203     {
1204       if (!ROM_STRING(arg1))
1205         TYPE_ERROR("string");
1206
1207       arg1 = rom_get_car (arg1);
1208     }
1209   else
1210     TYPE_ERROR("string");
1211 }
1212
1213  void prim_list2string (void)
1214 {
1215   arg1 = alloc_ram_cell_init (COMPOSITE_FIELD0 | ((arg1 & 0x1f00) >> 8),
1216                               arg1 & 0xff,
1217                               STRING_FIELD2,
1218                               0);
1219 }
1220
1221
1222 /*---------------------------------------------------------------------------*/
1223
1224 /* Robot specific operations */
1225
1226
1227 void prim_print (void)
1228 {
1229 #ifdef PICOBOARD2
1230 #endif
1231
1232 #ifdef WORKSTATION
1233
1234   print (arg1);
1235
1236 #endif
1237
1238   arg1 = OBJ_FALSE;
1239 }
1240
1241
1242 int32 read_clock (void)
1243 {
1244   int32 now = 0;
1245
1246 #ifdef PICOBOARD2
1247
1248   now = from_now( 0 );
1249
1250 #endif
1251
1252 #ifdef WORKSTATION
1253
1254 #ifdef _WIN32
1255
1256   static int32 start = 0;
1257   struct timeb tb;
1258
1259   ftime (&tb);
1260
1261   now = tb.time * 1000 + tb.millitm;
1262   if (start == 0)
1263     start = now;
1264   now -= start;
1265
1266 #else
1267
1268   static int32 start = 0;
1269   struct timeval tv;
1270
1271   if (gettimeofday (&tv, NULL) == 0)
1272     {
1273       now = tv.tv_sec * 1000 + tv.tv_usec / 1000;
1274       if (start == 0)
1275         start = now;
1276       now -= start;
1277     }
1278
1279 #endif
1280
1281 #endif
1282
1283   return now;
1284 }
1285
1286
1287 void prim_clock (void)
1288 {
1289   arg1 = encode_int (read_clock ());
1290 }
1291
1292
1293 void prim_motor (void)
1294 {
1295   decode_2_int_args ();
1296
1297   if (a1 < 1 || a1 > 2 || a2 < -100 || a2 > 100)
1298     ERROR("argument out of range to procedure \"motor\"");
1299
1300 #ifdef PICOBOARD2
1301
1302   fw_motor ();
1303
1304 #endif
1305
1306 #ifdef WORKSTATION
1307
1308   printf ("motor %d -> power=%d\n", a1, a2);
1309   fflush (stdout);
1310
1311 #endif
1312
1313   arg1 = OBJ_FALSE;
1314   arg2 = OBJ_FALSE;
1315 }
1316
1317
1318 void prim_led (void)
1319 {
1320   decode_2_int_args ();
1321   a3 = decode_int (arg3);
1322
1323   if (a1 < 1 || a1 > 3 || a2 < 0 || a3 < 0)
1324     ERROR("argument out of range to procedure \"led\"");
1325
1326 #ifdef PICOBOARD2
1327
1328   LED_set( a1, a2, a3 );
1329
1330 #endif
1331
1332 #ifdef WORKSTATION
1333
1334   printf ("led %d -> duty=%d period=%d\n", a1, a2, a3 );
1335   fflush (stdout);
1336
1337 #endif
1338
1339   arg1 = OBJ_FALSE;
1340   arg2 = OBJ_FALSE;
1341   arg3 = OBJ_FALSE;
1342 }
1343
1344
1345 void prim_led2_color (void)
1346 {
1347   a1 = decode_int (arg1);
1348
1349   if (a1 < 0 || a1 > 1)
1350     ERROR("argument out of range to procedure \"led2-color\"");
1351
1352 #ifdef PICOBOARD2
1353
1354   LED2_color_set( a1 );
1355
1356 #endif
1357
1358 #ifdef WORKSTATION
1359
1360   printf ("led2-color -> %s\n", (a1==0)?"green":"red");
1361   fflush (stdout);
1362
1363 #endif
1364
1365   arg1 = OBJ_FALSE;
1366 }
1367
1368
1369 void prim_getchar_wait (void)
1370 {
1371   decode_2_int_args();
1372   a1 = read_clock () + a1;
1373
1374   if (a1 < 0 || a2 < 1 || a2 > 3)
1375     ERROR("argument out of range to procedure \"getchar-wait\"");
1376
1377 #ifdef PICOBOARD2
1378
1379   arg1 = OBJ_FALSE;
1380
1381   {
1382     serial_port_set ports;
1383     ports = serial_rx_wait_with_timeout( a2, a1 );
1384     if (ports != 0)
1385       arg1 = encode_int (serial_rx_read( ports ));
1386   }
1387
1388 #endif
1389
1390 #ifdef WORKSTATION
1391
1392 #ifdef _WIN32
1393
1394   arg1 = OBJ_FALSE;
1395
1396   do
1397     {
1398       if (_kbhit ())
1399         {
1400           arg1 = encode_int (_getch ());
1401           break;
1402         }
1403     } while (read_clock () < a1);
1404
1405
1406 #else
1407
1408   arg1 = encode_int (getchar ());
1409
1410 #endif
1411
1412 #endif
1413 }
1414
1415
1416 void prim_putchar (void)
1417 {
1418   decode_2_int_args ();
1419
1420   if (a1 < 0 || a1 > 255 || a2 < 1 || a2 > 3)
1421     ERROR("argument out of range to procedure \"putchar\"");
1422
1423 #ifdef PICOBOARD2
1424
1425   serial_tx_write( a2, a1 );
1426
1427 #endif
1428
1429 #ifdef WORKSTATION
1430
1431   putchar (a1);
1432   fflush (stdout);
1433
1434 #endif
1435
1436   arg1 = OBJ_FALSE;
1437   arg2 = OBJ_FALSE;
1438 }
1439
1440
1441 void prim_beep (void)
1442 {
1443   decode_2_int_args ();
1444
1445   if (a1 < 1 || a1 > 255 || a2 < 0)
1446     ERROR("argument out of range to procedure \"beep\"");
1447
1448 #ifdef PICOBOARD2
1449
1450   beep( a1, from_now( a2 ) );
1451
1452 #endif
1453
1454 #ifdef WORKSTATION
1455
1456   printf ("beep -> freq-div=%d duration=%d\n", a1, a2 );
1457   fflush (stdout);
1458
1459 #endif
1460
1461   arg1 = OBJ_FALSE;
1462   arg2 = OBJ_FALSE;
1463 }
1464
1465
1466 void prim_adc (void)
1467 {
1468   short x;
1469
1470   a1 = decode_int (arg1);
1471
1472   if (a1 < 1 || a1 > 3)
1473     ERROR("argument out of range to procedure \"adc\"");
1474
1475 #ifdef PICOBOARD2
1476
1477   x = adc( a1 );
1478
1479 #endif
1480
1481 #ifdef WORKSTATION
1482
1483   x = read_clock () & 255;
1484
1485   if (x > 127) x = 256 - x;
1486
1487   x += 200;
1488
1489 #endif
1490
1491   arg1 = encode_int (x);
1492 }
1493
1494
1495 void prim_dac (void)
1496 {
1497   a1 = decode_int (arg1);
1498
1499   if (a1 < 0 || a1 > 255)
1500     ERROR("argument out of range to procedure \"dac\"");
1501
1502 #ifdef PICOBOARD2
1503
1504   dac( a1 );
1505
1506 #endif
1507
1508 #ifdef WORKSTATION
1509
1510   printf ("dac -> %d\n", a1 );
1511   fflush (stdout);
1512
1513 #endif
1514
1515   arg1 = OBJ_FALSE;
1516 }
1517
1518
1519 void prim_sernum (void)
1520 {
1521   short x;
1522
1523 #ifdef PICOBOARD2
1524
1525   x = serial_num ();
1526
1527 #endif
1528
1529 #ifdef WORKSTATION
1530
1531   x = 0;
1532
1533 #endif
1534
1535   arg1 = encode_int (x);
1536 }
1537
1538
1539 /*---------------------------------------------------------------------------*/
1540
1541 #ifdef WORKSTATION
1542
1543 int hidden_fgetc (FILE *f)
1544 {
1545   int c = fgetc (f);
1546 #if 0
1547   printf ("{%d}",c);
1548   fflush (stdout);
1549 #endif
1550   return c;
1551 }
1552
1553 #define fgetc(f) hidden_fgetc(f)
1554
1555 void write_hex_nibble (int n)
1556 {
1557   putchar ("0123456789ABCDEF"[n]);
1558 }
1559
1560 void write_hex (uint8 n)
1561 {
1562   write_hex_nibble (n >> 4);
1563   write_hex_nibble (n & 0x0f);
1564 }
1565
1566 int hex (int c)
1567 {
1568   if (c >= '0' && c <= '9')
1569     return (c - '0');
1570
1571   if (c >= 'A' && c <= 'F')
1572     return (c - 'A' + 10);
1573
1574   if (c >= 'a' && c <= 'f')
1575     return (c - 'a' + 10);
1576
1577   return -1;
1578 }
1579
1580 int read_hex_byte (FILE *f)
1581 {
1582   int h1 = hex (fgetc (f));
1583   int h2 = hex (fgetc (f));
1584
1585   if (h1 >= 0 && h2 >= 0)
1586     return (h1<<4) + h2;
1587
1588   return -1;
1589 }
1590
1591 int read_hex_file (char *filename)
1592 {
1593   int c;
1594   FILE *f = fopen (filename, "r");
1595   int result = 0;
1596   int len;
1597   int a, a1, a2;
1598   int t;
1599   int b;
1600   int i;
1601   uint8 sum;
1602   int hi16 = 0;
1603
1604   for (i=0; i<ROM_BYTES; i++)
1605     rom_mem[i] = 0xff;
1606
1607   if (f != NULL)
1608     {
1609       while ((c = fgetc (f)) != EOF)
1610         {
1611           if ((c == '\r') || (c == '\n'))
1612             continue;
1613
1614           if (c != ':' ||
1615               (len = read_hex_byte (f)) < 0 ||
1616               (a1 = read_hex_byte (f)) < 0 ||
1617               (a2 = read_hex_byte (f)) < 0 ||
1618               (t = read_hex_byte (f)) < 0)
1619             break;
1620
1621           a = (a1 << 8) + a2;
1622
1623           i = 0;
1624           sum = len + a1 + a2 + t;
1625
1626           if (t == 0)
1627             {
1628             next0:
1629
1630               if (i < len)
1631                 {
1632                   unsigned long adr = ((unsigned long)hi16 << 16) + a - CODE_START;
1633
1634                   if ((b = read_hex_byte (f)) < 0)
1635                     break;
1636
1637                   if (adr >= 0 && adr < ROM_BYTES)
1638                     rom_mem[adr] = b;
1639
1640                   a = (a + 1) & 0xffff;
1641                   i++;
1642                   sum += b;
1643
1644                   goto next0;
1645                 }
1646             }
1647           else if (t == 1)
1648             {
1649               if (len != 0)
1650                 break;
1651             }
1652           else if (t == 4)
1653             {
1654               if (len != 2)
1655                 break;
1656
1657               if ((a1 = read_hex_byte (f)) < 0 ||
1658                   (a2 = read_hex_byte (f)) < 0)
1659                 break;
1660
1661               sum += a1 + a2;
1662
1663               hi16 = (a1<<8) + a2;
1664             }
1665           else
1666             break;
1667
1668           if ((b = read_hex_byte (f)) < 0)
1669             break;
1670
1671           sum = -sum;
1672
1673           if (sum != b)
1674             {
1675               printf ("*** HEX file checksum error (expected 0x%02x)\n", sum);
1676               break;
1677             }
1678
1679           c = fgetc (f);
1680
1681           if ((c != '\r') && (c != '\n'))
1682             break;
1683
1684           if (t == 1)
1685             {
1686               result = 1;
1687               break;
1688             }
1689         }
1690
1691       if (result == 0)
1692         printf ("*** HEX file syntax error\n");
1693
1694       fclose (f);
1695     }
1696
1697   return result;
1698 }
1699
1700 #endif
1701
1702 /*---------------------------------------------------------------------------*/
1703
1704 #define FETCH_NEXT_BYTECODE() bytecode = rom_get (pc++)
1705
1706 #define BEGIN_DISPATCH()                        \
1707   dispatch:                                     \
1708   IF_TRACE(show_state (pc));                    \
1709   FETCH_NEXT_BYTECODE();                        \
1710   bytecode_hi4 = bytecode & 0xf0;               \
1711   bytecode_lo4 = bytecode & 0x0f;               \
1712   switch (bytecode_hi4 >> 4) {
1713
1714 #define END_DISPATCH() }
1715
1716 #define CASE(opcode) case (opcode>>4):;
1717
1718 #define DISPATCH(); goto dispatch;
1719
1720 #if 0
1721 #define pc FSR1
1722 #define sp FSR2
1723 #define bytecode TABLAT
1724 #define bytecode_hi4 WREG
1725 #endif
1726
1727 #define PUSH_CONSTANT1 0x00
1728 #define PUSH_CONSTANT2 0x10
1729 #define PUSH_STACK1    0x20
1730 #define PUSH_STACK2    0x30
1731 #define PUSH_GLOBAL    0x40
1732 #define SET_GLOBAL     0x50
1733 #define CALL           0x60
1734 #define JUMP           0x70
1735 #define CALL_TOPLEVEL  0x80
1736 #define JUMP_TOPLEVEL  0x90
1737 #define GOTO           0xa0
1738 #define GOTO_IF_FALSE  0xb0
1739 #define CLOSURE        0xc0
1740 #define PRIM1          0xd0
1741 #define PRIM2          0xe0
1742 #define PRIM3          0xf0
1743
1744 #ifdef WORKSTATION
1745
1746 char *prim_name[48] =
1747   {
1748     "prim #%number?",
1749     "prim #%+",
1750     "prim #%-",
1751     "prim #%*",
1752     "prim #%quotient",
1753     "prim #%remainder",
1754     "prim #%neg",
1755     "prim #%=",
1756     "prim #%<",
1757     "prim #%ior",
1758     "prim #%>",
1759     "prim #%xor",
1760     "prim #%pair?",
1761     "prim #%cons",
1762     "prim #%car",
1763     "prim #%cdr",
1764     "prim #%set-car!",
1765     "prim #%set-cdr!",
1766     "prim #%null?",
1767     "prim #%eq?",
1768     "prim #%not",
1769     "prim #%get-cont",
1770     "prim #%graft-to-cont",
1771     "prim #%return-to-cont",
1772     "prim #%halt",
1773     "prim #%symbol?",
1774     "prim #%string?",
1775     "prim #%string->list",
1776     "prim #%list->string",
1777     "prim #%prim29",
1778     "prim #%prim30",
1779     "prim #%prim31",
1780     "prim #%print",
1781     "prim #%clock",
1782     "prim #%motor",
1783     "prim #%led",
1784     "prim #%led2-color",
1785     "prim #%getchar-wait",
1786     "prim #%putchar",
1787     "prim #%beep",
1788     "prim #%adc",
1789     "prim #%dac",
1790     "prim #%sernum",
1791     "prim #%prim43",
1792     "push-constant [long]",
1793     "shift",
1794     "pop",
1795     "return",
1796   };
1797
1798 #endif
1799
1800 #define PUSH_ARG1() push_arg1 ()
1801 #define POP() pop()
1802
1803 void push_arg1 (void)
1804 {
1805   env = cons (arg1, env);
1806   arg1 = OBJ_FALSE;
1807 }
1808
1809 obj pop (void)
1810 {
1811   obj o = ram_get_car (env);
1812   env = ram_get_cdr (env);
1813   return o;
1814 }
1815
1816 void pop_procedure (void)
1817 { // TODO BARF what to do when continuations end up here ?
1818   arg1 = POP();
1819
1820   if (IN_RAM(arg1))
1821     {
1822       if (RAM_CONTINUATION(arg1))
1823         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
1824
1825       if (!RAM_CLOSURE(arg1))
1826         TYPE_ERROR("procedure");
1827
1828       entry = (((ram_get_field0 (arg1) & 0x1f) << 11)
1829                | (ram_get_field1 (arg1) << 3)
1830                | (ram_get_field2 (arg1) >> 5)) + CODE_START;
1831     }
1832   else if (IN_ROM(arg1))
1833     {
1834       if (ROM_CONTINUATION(arg1))
1835         ERROR("continuation in pop_procedure"); // TODO same as above
1836
1837       if (!ROM_CLOSURE(arg1))
1838         TYPE_ERROR("procedure");
1839
1840       entry = (((rom_get_field0 (arg1) & 0x1f) << 11)
1841                | (rom_get_field1 (arg1) << 3)
1842                | (rom_get_field2 (arg1) >> 5)) + CODE_START;
1843     }
1844   else
1845     TYPE_ERROR("procedure");
1846 }
1847
1848 void handle_arity_and_rest_param (void)
1849 {
1850   uint8 np;
1851
1852   np = rom_get (entry++);
1853
1854   if ((np & 0x80) == 0)
1855     {
1856       if (na != np)
1857         ERROR("wrong number of arguments");
1858     }
1859   else
1860     {
1861       np = ~np;
1862
1863       if (na < np)
1864         ERROR("wrong number of arguments");
1865
1866       arg3 = OBJ_NULL;
1867
1868       while (na > np)
1869         {
1870           arg4 = POP();
1871
1872           arg3 = cons (arg4, arg3);
1873           arg4 = OBJ_FALSE;
1874
1875           na--;
1876         }
1877
1878       arg1 = cons (arg3, arg1);
1879       arg3 = OBJ_FALSE; // TODO changed nothing with the new new closures, everything looks ok
1880     }
1881 }
1882
1883 void build_env (void)
1884 {
1885   while (na != 0)
1886     {
1887       arg3 = POP();
1888
1889       arg1 = cons (arg3, arg1);
1890
1891       na--;
1892     }
1893
1894   arg3 = OBJ_FALSE; // TODO changed nothing here either
1895 }
1896
1897 void save_cont (void)
1898 {
1899   // the second half is a closure
1900   second_half = alloc_ram_cell_init (CLOSURE_FIELD0 | ((pc & 0xf800) >> 11),
1901                                      (pc & 0x07f8) >> 3,
1902                                      ((pc & 0x0007) << 5) | (env >> 8),
1903                                      env & 0xff);
1904   cont = alloc_ram_cell_init (COMPOSITE_FIELD0 | (cont >> 8),
1905                               cont & 0xff,
1906                               CONTINUATION_FIELD2 | (second_half >> 8),
1907                               second_half & 0xff);
1908   // TODO was :
1909   /* cont = alloc_ram_cell_init (CLOSURE_FIELD0 | ((second_half &0x1f00) >> 8), */
1910   /*                             second_half & 0xff, */
1911   /*                             (pc & 0xff00) >> 8, */
1912   /*                             pc & 0xff); */
1913 }
1914
1915 void interpreter (void)
1916 {
1917   init_ram_heap ();
1918
1919   pc = (CODE_START + 4) + ((rom_addr)rom_get (CODE_START+2) << 2);
1920
1921   BEGIN_DISPATCH();
1922
1923   /***************************************************************************/
1924   CASE(PUSH_CONSTANT1);
1925
1926   IF_TRACE(printf("  (push-constant "); show (bytecode_lo4); printf (")\n"));
1927
1928   arg1 = bytecode_lo4;
1929
1930   PUSH_ARG1();
1931
1932   DISPATCH();
1933
1934   /***************************************************************************/
1935   CASE(PUSH_CONSTANT2);
1936
1937   IF_TRACE(printf("  (push-constant "); show (bytecode_lo4+16); printf (")\n"));
1938   arg1 = bytecode_lo4+16;
1939
1940   PUSH_ARG1();
1941
1942   DISPATCH();
1943
1944   /***************************************************************************/
1945   CASE(PUSH_STACK1);
1946
1947   IF_TRACE(printf("  (push-stack %d)\n", bytecode_lo4));
1948
1949   arg1 = env;
1950
1951   while (bytecode_lo4 != 0)
1952     {
1953       arg1 = ram_get_cdr (arg1);
1954       bytecode_lo4--;
1955     }
1956
1957   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
1958
1959   PUSH_ARG1();
1960
1961   DISPATCH();
1962
1963   /***************************************************************************/
1964   CASE(PUSH_STACK2);
1965
1966   IF_TRACE(printf("  (push-stack %d)\n", bytecode_lo4+16));
1967
1968   bytecode_lo4 += 16;
1969
1970   arg1 = env;
1971
1972   while (bytecode_lo4 != 0)
1973     {
1974       arg1 = ram_get_cdr (arg1);
1975       bytecode_lo4--;
1976     }
1977
1978   arg1 = ram_get_car (arg1);
1979
1980   PUSH_ARG1();
1981
1982   DISPATCH();
1983
1984   /***************************************************************************/
1985   CASE(PUSH_GLOBAL);
1986
1987   IF_TRACE(printf("  (push-global %d)\n", bytecode_lo4));
1988
1989   arg1 = get_global (bytecode_lo4);
1990
1991   PUSH_ARG1();
1992
1993   DISPATCH();
1994
1995   /***************************************************************************/
1996   CASE(SET_GLOBAL);
1997
1998   IF_TRACE(printf("  (set-global %d)\n", bytecode_lo4));
1999
2000   set_global (bytecode_lo4, POP());
2001
2002   DISPATCH();
2003
2004   /***************************************************************************/
2005   CASE(CALL);
2006
2007   IF_TRACE(printf("  (call %d)\n", bytecode_lo4));
2008
2009   na = bytecode_lo4;
2010
2011   pop_procedure (); // TODO FOOBAR can we call a continuation ? if so, fix pop_procedure
2012   handle_arity_and_rest_param ();
2013   build_env ();
2014   save_cont ();
2015
2016   env = arg1;
2017   pc = entry;
2018
2019   arg1 = OBJ_FALSE;
2020
2021   DISPATCH();
2022
2023   /***************************************************************************/
2024   CASE(JUMP);
2025
2026   IF_TRACE(printf("  (jump %d)\n", bytecode_lo4));
2027
2028   na = bytecode_lo4;
2029
2030   pop_procedure ();
2031   handle_arity_and_rest_param ();
2032   build_env ();
2033
2034   env = arg1;
2035   pc = entry;
2036
2037   arg1 = OBJ_FALSE;
2038
2039   DISPATCH();
2040
2041   /***************************************************************************/
2042   CASE(CALL_TOPLEVEL);
2043
2044   FETCH_NEXT_BYTECODE();
2045   second_half = bytecode; // TODO make sure second_half is not already in use
2046
2047   FETCH_NEXT_BYTECODE();
2048
2049   IF_TRACE(printf("  (call-toplevel 0x%04x)\n", ((second_half << 8) | bytecode) + CODE_START));
2050
2051   entry = ((second_half << 8) | bytecode) + CODE_START; // TODO FOOBAR we have the last 4 bits of the opcode free, to do pretty much anything
2052   arg1 = OBJ_NULL;
2053
2054   na = rom_get (entry++);
2055
2056   build_env ();
2057   save_cont ();
2058
2059   env = arg1;
2060   pc = entry;
2061
2062   arg1 = OBJ_FALSE;
2063
2064   DISPATCH();
2065
2066   /***************************************************************************/
2067   CASE(JUMP_TOPLEVEL);
2068
2069   FETCH_NEXT_BYTECODE();
2070   second_half = bytecode; // TODO make sure second_half is not already in use
2071
2072   FETCH_NEXT_BYTECODE();
2073
2074   IF_TRACE(printf("  (jump-toplevel 0x%04x)\n", ((second_half << 8) | bytecode) + CODE_START));
2075
2076   entry = ((second_half << 8) | bytecode) + CODE_START;
2077   arg1 = OBJ_NULL;
2078
2079   na = rom_get (entry++);
2080
2081   build_env ();
2082
2083   env = arg1;
2084   pc = entry;
2085
2086   arg1 = OBJ_FALSE;
2087
2088   DISPATCH();
2089
2090   /***************************************************************************/
2091   CASE(GOTO);
2092
2093   FETCH_NEXT_BYTECODE();
2094   // TODO goto's use 12-bit addresses, unlike calls and jumps, which use 16, is it ok ?
2095   IF_TRACE(printf("  (goto 0x%04x)\n", ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode));
2096
2097   pc = ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode;
2098
2099   DISPATCH();
2100
2101   /***************************************************************************/
2102   CASE(GOTO_IF_FALSE);
2103
2104   FETCH_NEXT_BYTECODE();
2105
2106   IF_TRACE(printf("  (goto-if-false 0x%04x)\n", ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode));
2107
2108   if (POP() == OBJ_FALSE)
2109     pc = ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode;
2110
2111   DISPATCH();
2112
2113   /***************************************************************************/
2114   CASE(CLOSURE);
2115
2116   FETCH_NEXT_BYTECODE();
2117   second_half = bytecode;
2118
2119   FETCH_NEXT_BYTECODE();
2120
2121   IF_TRACE(printf("  (closure 0x%04x)\n", (second_half << 8) | bytecode));
2122   // TODO original had CODE_START, while the real code below didn't
2123
2124   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
2125   arg3 = POP(); // env
2126
2127   entry = (second_half << 8) | bytecode; // TODO original had no CODE_START, why ?
2128
2129   arg1 = alloc_ram_cell_init (CLOSURE_FIELD0 | (second_half >> 3),
2130                               ((second_half & 0x07) << 5) | (bytecode >> 3),
2131                               ((bytecode & 0x07) << 5) |((arg3 & 0x1f00) >> 8),
2132                               arg3 & 0xff);
2133
2134   PUSH_ARG1();
2135
2136   arg2 = OBJ_FALSE;
2137   arg3 = OBJ_FALSE;
2138
2139   DISPATCH();
2140
2141   /***************************************************************************/
2142   CASE(PRIM1);
2143
2144   IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4]));
2145
2146   switch (bytecode_lo4)
2147     {
2148     case 0:
2149       arg1 = POP();  prim_numberp ();  PUSH_ARG1();  break;
2150     case 1:
2151       arg2 = POP();  arg1 = POP();  prim_add ();      PUSH_ARG1();  break;
2152     case 2:
2153       arg2 = POP();  arg1 = POP();  prim_sub ();      PUSH_ARG1();  break;
2154     case 3:
2155       arg2 = POP();  arg1 = POP();  prim_mul ();      PUSH_ARG1();  break;
2156     case 4:
2157       arg2 = POP();  arg1 = POP();  prim_div ();      PUSH_ARG1();  break;
2158     case 5:
2159       arg2 = POP();  arg1 = POP();  prim_rem ();      PUSH_ARG1();  break;
2160     case 6:
2161       arg1 = POP();  prim_neg ();      PUSH_ARG1();  break;
2162     case 7:
2163       arg2 = POP();  arg1 = POP();  prim_eq ();       PUSH_ARG1();  break;
2164     case 8:
2165       arg2 = POP();  arg1 = POP();  prim_lt ();       PUSH_ARG1();  break;
2166     case 9:
2167       arg2 = POP(); arg1 = POP(); prim_ior (); PUSH_ARG1(); break;
2168     case 10:
2169       arg2 = POP();  arg1 = POP();  prim_gt ();       PUSH_ARG1();  break;
2170     case 11:
2171       arg2 = POP(); arg1 = POP(); prim_xor (); PUSH_ARG1(); break;
2172     case 12:
2173       arg1 = POP();  prim_pairp ();    PUSH_ARG1();  break;
2174     case 13:
2175       arg2 = POP();  arg1 = POP();  prim_cons ();     PUSH_ARG1();  break;
2176     case 14:
2177       arg1 = POP();  prim_car ();      PUSH_ARG1();  break;
2178     case 15:
2179       arg1 = POP();  prim_cdr ();      PUSH_ARG1();  break;
2180     }
2181
2182   DISPATCH();
2183
2184   /***************************************************************************/
2185   CASE(PRIM2);
2186
2187   IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4+16]));
2188
2189   switch (bytecode_lo4)
2190     {
2191     case 0:
2192       arg2 = POP();  arg1 = POP();  prim_set_car ();                break;
2193     case 1:
2194       arg2 = POP();  arg1 = POP();  prim_set_cdr ();                break;
2195     case 2:
2196       arg1 = POP();  prim_nullp ();    PUSH_ARG1();  break;
2197     case 3:
2198       arg2 = POP();  arg1 = POP();  prim_eqp ();      PUSH_ARG1();  break;
2199     case 4:
2200       arg1 = POP();  prim_not ();      PUSH_ARG1();  break;
2201     case 5:
2202       /* prim #%get-cont */
2203       arg1 = cont;
2204       PUSH_ARG1();
2205       break;
2206     case 6:
2207       /* prim #%graft-to-cont */
2208
2209       arg1 = POP(); /* thunk to call */
2210       cont = POP(); /* continuation */
2211
2212       PUSH_ARG1(); // TODO we don't call the continuation, no change was needed
2213
2214       na = 0;
2215
2216       pop_procedure ();
2217       handle_arity_and_rest_param ();
2218       build_env ();
2219
2220       env = arg1;
2221       pc = entry;
2222
2223       arg1 = OBJ_FALSE;
2224
2225       break;
2226     case 7:
2227       /* prim #%return-to-cont */
2228
2229       arg1 = POP(); /* value to return */
2230       cont = POP(); /* continuation */
2231
2232       second_half = ram_get_cdr (cont);
2233
2234       pc = ((ram_get_field0 (second_half) >> 11) // TODO have a function for that
2235             | ((ram_get_field1 (second_half) >> 3) & 0xff)
2236             | (ram_get_field2 (second_half) & 0x07)) + CODE_START;
2237
2238       env = ram_get_cdr (second_half);
2239       cont = ram_get_car (cont);
2240
2241       PUSH_ARG1();
2242
2243       break;
2244     case 8:
2245       /* prim #%halt */
2246       return;
2247     case 9:
2248       /* prim #%symbol? */
2249       arg1 = POP();  prim_symbolp ();  PUSH_ARG1();  break;
2250     case 10:
2251       /* prim #%string? */
2252       arg1 = POP();  prim_stringp ();  PUSH_ARG1();  break;
2253     case 11:
2254       /* prim #%string->list */
2255       arg1 = POP();  prim_string2list ();  PUSH_ARG1();  break;
2256     case 12:
2257       /* prim #%list->string */
2258       arg1 = POP();  prim_list2string ();  PUSH_ARG1();  break;
2259 #if 0
2260     case 13:
2261       break;
2262     case 14:
2263       break;
2264     case 15:
2265       break;
2266 #endif
2267     }
2268
2269   DISPATCH();
2270
2271   /***************************************************************************/
2272   CASE(PRIM3);
2273
2274   IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4+32]));
2275
2276   switch (bytecode_lo4)
2277     {
2278     case 0:
2279       /* prim #%print */
2280       arg1 = POP();
2281       prim_print ();
2282       break;
2283     case 1:
2284       /* prim #%clock */
2285       prim_clock ();  PUSH_ARG1();  break;
2286     case 2:
2287       /* prim #%motor */
2288       arg2 = POP();  arg1 = POP();  prim_motor ();  break;
2289     case 3:
2290       /* prim #%led */
2291       arg3 = POP();  arg2 = POP();  arg1 = POP();  prim_led ();  ;break;
2292     case 4:
2293       /* prim #%led2-color */
2294       arg1 = POP();  prim_led2_color ();  break;
2295     case 5:
2296       /* prim #%getchar-wait */
2297       arg2 = POP();  arg1 = POP();  prim_getchar_wait ();  PUSH_ARG1();  break;
2298     case 6:
2299       /* prim #%putchar */
2300       arg2 = POP();  arg1 = POP();  prim_putchar ();  break;
2301     case 7:
2302       /* prim #%beep */
2303       arg2 = POP();  arg1 = POP();  prim_beep ();  break;
2304     case 8:
2305       /* prim #%adc */
2306       arg1 = POP();  prim_adc ();  PUSH_ARG1();  break;
2307     case 9:
2308       /* prim #%dac */
2309       arg1 = POP();  prim_dac ();  break;
2310     case 10:
2311       /* prim #%sernum */
2312       prim_sernum ();  PUSH_ARG1();  break;
2313 #if 0
2314     case 11:
2315       break;
2316 #endif
2317     case 12:
2318       /* push-constant [long] */
2319       FETCH_NEXT_BYTECODE();
2320       second_half = bytecode;
2321       FETCH_NEXT_BYTECODE();
2322       arg1 = (second_half << 8) | bytecode;
2323       PUSH_ARG1();
2324       break;
2325     case 13:
2326       /* shift */
2327       arg1 = POP();
2328       POP();
2329       PUSH_ARG1();
2330       break;
2331     case 14:
2332       /* pop */
2333       POP();
2334       break;
2335     case 15:
2336       /* return */
2337       arg1 = POP();
2338       second_half = ram_get_cdr (cont);
2339       pc = ((ram_get_field0 (second_half) >> 11)
2340             | ((ram_get_field1 (second_half) >> 3) & 0xff)
2341             | (ram_get_field2 (second_half) & 0x07)) + CODE_START;
2342       env = ram_get_cdr (second_half);
2343       cont = ram_get_car (cont);
2344       PUSH_ARG1();
2345       break;
2346     }
2347
2348   DISPATCH();
2349
2350   /***************************************************************************/
2351
2352   END_DISPATCH();
2353 }
2354
2355 /*---------------------------------------------------------------------------*/
2356
2357 #ifdef WORKSTATION
2358
2359 void usage (void)
2360 {
2361   printf ("usage: sim file.hex\n");
2362   exit (1);
2363 }
2364
2365 int main (int argc, char *argv[])
2366 {
2367   int errcode = 1;
2368   rom_addr rom_start_addr = 0;
2369
2370   if (argc > 1 && argv[1][0] == '-' && argv[1][1] == 's')
2371     {
2372       int h1;
2373       int h2;
2374       int h3;
2375       int h4;
2376
2377       if ((h1 = hex (argv[1][2])) < 0 ||
2378           (h2 = hex (argv[1][3])) < 0 ||
2379           (h3 = hex (argv[1][4])) != 0 ||
2380           (h4 = hex (argv[1][5])) != 0 ||
2381           argv[1][6] != '\0')
2382         usage ();
2383
2384       rom_start_addr = (h1 << 12) | (h2 << 8) | (h3 << 4) | h4;
2385
2386       argv++;
2387       argc--;
2388     }
2389
2390 #ifdef DEBUG
2391   printf ("Start address = 0x%04x\n", rom_start_addr);
2392 #endif
2393
2394   if (argc != 2)
2395     usage ();
2396
2397   if (!read_hex_file (argv[1]))
2398     printf ("*** Could not read hex file \"%s\"\n", argv[1]);
2399   else
2400     {
2401       int i;
2402
2403       if (rom_get (CODE_START+0) != 0xfb ||
2404           rom_get (CODE_START+1) != 0xd7)
2405         printf ("*** The hex file was not compiled with PICOBIT\n");
2406       else
2407         {
2408 #if 0
2409           for (i=0; i<8192; i++)
2410             if (rom_get (i) != 0xff)
2411               printf ("rom_mem[0x%04x] = 0x%02x\n", i, rom_get (i));
2412 #endif
2413
2414           interpreter ();
2415
2416 #ifdef DEBUG_GC
2417           printf ("**************** memory needed = %d\n", max_live+1);
2418 #endif
2419         }
2420     }
2421
2422   return errcode;
2423 }
2424
2425 #endif
2426
2427 /*---------------------------------------------------------------------------*/