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