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