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