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 CALL_TOPLEVEL  0x80
1991 #define JUMP_TOPLEVEL  0x90
1992 #define GOTO           0xa0
1993 #define GOTO_IF_FALSE  0xb0
1994 #define CLOSURE        0xc0
1995 #define PRIM1          0xd0
1996 #define PRIM2          0xe0
1997 #define PRIM3          0xf0
1998
1999 #ifdef WORKSTATION
2000
2001 char *prim_name[48] =
2002   {
2003     "prim #%number?",
2004     "prim #%+",
2005     "prim #%-",
2006     "prim #%*",
2007     "prim #%quotient",
2008     "prim #%remainder",
2009     "prim #%neg",
2010     "prim #%=",
2011     "prim #%<",
2012     "prim #%ior",
2013     "prim #%>",
2014     "prim #%xor",
2015     "prim #%pair?",
2016     "prim #%cons",
2017     "prim #%car",
2018     "prim #%cdr",
2019     "prim #%set-car!",
2020     "prim #%set-cdr!",
2021     "prim #%null?",
2022     "prim #%eq?",
2023     "prim #%not",
2024     "prim #%get-cont",
2025     "prim #%graft-to-cont",
2026     "prim #%return-to-cont",
2027     "prim #%halt",
2028     "prim #%symbol?",
2029     "prim #%string?",
2030     "prim #%string->list",
2031     "prim #%list->string",
2032     "prim #%make-u8vector", // TODO was prim29
2033     "prim #%u8vector-ref", // TODO was prim30
2034     "prim #%u8vector-set!", // TODO was prim31
2035     "prim #%print",
2036     "prim #%clock",
2037     "prim #%motor",
2038     "prim #%led",
2039     "prim #%led2-color",
2040     "prim #%getchar-wait",
2041     "prim #%putchar",
2042     "prim #%beep",
2043     "prim #%adc",
2044     "prim #%u8vector?", // TODO was dac, but it's not plugged to anything
2045     "prim #%sernum",
2046     "prim #%u8vector-length", // TODO was prim43
2047     "push-constant [long]",
2048     "shift",
2049     "pop",
2050     "return",
2051   };
2052
2053 #endif
2054
2055 #define PUSH_ARG1() push_arg1 ()
2056 #define POP() pop()
2057
2058 void push_arg1 (void)
2059 {
2060   env = cons (arg1, env);
2061   arg1 = OBJ_FALSE;
2062 }
2063
2064 obj pop (void)
2065 {
2066   obj o = ram_get_car (env);
2067   env = ram_get_cdr (env);
2068   return o;
2069 }
2070
2071 void pop_procedure (void)
2072 {
2073   arg1 = POP();
2074
2075   if (IN_RAM(arg1))
2076     {
2077       if (!RAM_CLOSURE(arg1))
2078         TYPE_ERROR("procedure");
2079
2080       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
2081     }
2082   else if (IN_ROM(arg1))
2083     {
2084       if (!ROM_CLOSURE(arg1))
2085         TYPE_ERROR("procedure");
2086
2087       entry = rom_get_entry (arg1) + CODE_START;
2088     }
2089   else
2090     TYPE_ERROR("procedure");
2091 }
2092
2093 void handle_arity_and_rest_param (void)
2094 {
2095   uint8 np;
2096
2097   np = rom_get (entry++);
2098
2099   if ((np & 0x80) == 0)
2100     {
2101       if (na != np)
2102         ERROR("wrong number of arguments");
2103     }
2104   else
2105     {
2106       np = ~np;
2107
2108       if (na < np)
2109         ERROR("wrong number of arguments");
2110
2111       arg3 = OBJ_NULL;
2112
2113       while (na > np)
2114         {
2115           arg4 = POP();
2116
2117           arg3 = cons (arg4, arg3);
2118           arg4 = OBJ_FALSE;
2119
2120           na--;
2121         }
2122
2123       arg1 = cons (arg3, arg1);
2124       arg3 = OBJ_FALSE;
2125     }
2126 }
2127
2128 void build_env (void)
2129 {
2130   while (na != 0)
2131     {
2132       arg3 = POP();
2133
2134       arg1 = cons (arg3, arg1);
2135
2136       na--;
2137     }
2138
2139   arg3 = OBJ_FALSE;
2140 }
2141
2142 void save_cont (void)
2143 {
2144   // the second half is a closure
2145   arg3 = alloc_ram_cell_init (CLOSURE_FIELD0 | (pc >> 11),
2146                               (pc >> 3) & 0xff,
2147                               ((pc & 0x0007) << 5) | (env >> 8),
2148                               env & 0xff);
2149   cont = alloc_ram_cell_init (COMPOSITE_FIELD0 | (cont >> 8),
2150                               cont & 0xff,
2151                               CONTINUATION_FIELD2 | (arg3 >> 8),
2152                               arg3 & 0xff);
2153   arg3 = OBJ_FALSE;
2154 }
2155
2156 void interpreter (void)
2157 {
2158   init_ram_heap ();
2159
2160   pc = (CODE_START + 4) + ((rom_addr)rom_get (CODE_START+2) << 2);
2161
2162   BEGIN_DISPATCH();
2163
2164   /***************************************************************************/
2165   CASE(PUSH_CONSTANT1);
2166
2167   IF_TRACE(printf("  (push-constant "); show (bytecode_lo4); printf (")\n"));
2168
2169   arg1 = bytecode_lo4;
2170
2171   PUSH_ARG1();
2172
2173   DISPATCH();
2174
2175   /***************************************************************************/
2176   CASE(PUSH_CONSTANT2);
2177
2178   IF_TRACE(printf("  (push-constant "); show (bytecode_lo4+16); printf (")\n"));
2179   arg1 = bytecode_lo4+16;
2180
2181   PUSH_ARG1();
2182
2183   DISPATCH();
2184
2185   /***************************************************************************/
2186   CASE(PUSH_STACK1);
2187
2188   IF_TRACE(printf("  (push-stack %d)\n", bytecode_lo4));
2189
2190   arg1 = env;
2191
2192   while (bytecode_lo4 != 0)
2193     {
2194       arg1 = ram_get_cdr (arg1);
2195       bytecode_lo4--;
2196     }
2197
2198   arg1 = ram_get_car (arg1);
2199
2200   PUSH_ARG1();
2201
2202   DISPATCH();
2203
2204   /***************************************************************************/
2205   CASE(PUSH_STACK2);
2206
2207   IF_TRACE(printf("  (push-stack %d)\n", bytecode_lo4+16));
2208
2209   bytecode_lo4 += 16;
2210
2211   arg1 = env;
2212
2213   while (bytecode_lo4 != 0)
2214     {
2215       arg1 = ram_get_cdr (arg1);
2216       bytecode_lo4--;
2217     }
2218
2219   arg1 = ram_get_car (arg1);
2220
2221   PUSH_ARG1();
2222
2223   DISPATCH();
2224
2225   /***************************************************************************/
2226   CASE(PUSH_GLOBAL);
2227
2228   IF_TRACE(printf("  (push-global %d)\n", bytecode_lo4));
2229
2230   arg1 = get_global (bytecode_lo4);
2231
2232   PUSH_ARG1();
2233
2234   DISPATCH();
2235
2236   /***************************************************************************/
2237   CASE(SET_GLOBAL);
2238
2239   IF_TRACE(printf("  (set-global %d)\n", bytecode_lo4));
2240
2241   set_global (bytecode_lo4, POP());
2242
2243   DISPATCH();
2244
2245   /***************************************************************************/
2246   CASE(CALL);
2247
2248   IF_TRACE(printf("  (call %d)\n", bytecode_lo4));
2249
2250   na = bytecode_lo4;
2251
2252   pop_procedure ();
2253   handle_arity_and_rest_param ();
2254   build_env ();
2255   save_cont ();
2256
2257   env = arg1;
2258   pc = entry;
2259
2260   arg1 = OBJ_FALSE;
2261
2262   DISPATCH();
2263
2264   /***************************************************************************/
2265   CASE(JUMP);
2266
2267   IF_TRACE(printf("  (jump %d)\n", bytecode_lo4));
2268
2269   na = bytecode_lo4;
2270
2271   pop_procedure ();
2272   handle_arity_and_rest_param ();
2273   build_env ();
2274
2275   env = arg1;
2276   pc = entry;
2277
2278   arg1 = OBJ_FALSE;
2279
2280   DISPATCH();
2281
2282   /***************************************************************************/
2283   CASE(CALL_TOPLEVEL);
2284
2285   FETCH_NEXT_BYTECODE();
2286   arg2 = bytecode;
2287
2288   FETCH_NEXT_BYTECODE();
2289
2290   IF_TRACE(printf("  (call-toplevel 0x%04x)\n", ((arg2 << 8) | bytecode) + CODE_START));
2291
2292   entry = (arg2 << 8) + bytecode + CODE_START; // TODO FOOBAR we have the last 4 bits of the opcode free, to do pretty much anything
2293   arg1 = OBJ_NULL;
2294
2295   na = rom_get (entry++);
2296
2297   build_env ();
2298   save_cont ();
2299
2300   env = arg1;
2301   pc = entry;
2302
2303   arg1 = OBJ_FALSE;
2304   arg2 = OBJ_FALSE;
2305
2306   DISPATCH();
2307
2308   /***************************************************************************/
2309   CASE(JUMP_TOPLEVEL);
2310
2311   FETCH_NEXT_BYTECODE();
2312   arg2 = bytecode;
2313
2314   FETCH_NEXT_BYTECODE();
2315
2316   IF_TRACE(printf("  (jump-toplevel 0x%04x)\n", ((arg2 << 8) | bytecode) + CODE_START));
2317
2318   entry = (arg2 << 8) + bytecode + CODE_START; // TODO this is a common pattern
2319   arg1 = OBJ_NULL;
2320
2321   na = rom_get (entry++);
2322
2323   build_env ();
2324
2325   env = arg1;
2326   pc = entry;
2327
2328   arg1 = OBJ_FALSE;
2329   arg2 = OBJ_FALSE;
2330
2331   DISPATCH();
2332
2333   /***************************************************************************/
2334   CASE(GOTO);
2335
2336   FETCH_NEXT_BYTECODE();
2337   arg2 = bytecode;
2338
2339   FETCH_NEXT_BYTECODE();
2340
2341   IF_TRACE(printf("  (goto 0x%04x)\n", (rom_addr)((arg2 << 8) + bytecode + CODE_START)));
2342
2343   pc = (arg2 << 8) + bytecode + CODE_START;
2344
2345   DISPATCH();
2346
2347   /***************************************************************************/
2348   CASE(GOTO_IF_FALSE);
2349
2350   FETCH_NEXT_BYTECODE();
2351   arg2 = bytecode;
2352
2353   FETCH_NEXT_BYTECODE();
2354
2355   IF_TRACE(printf("  (goto-if-false 0x%04x)\n", (rom_addr)((arg2 << 8) + bytecode + CODE_START)));
2356
2357   if (POP() == OBJ_FALSE)
2358     pc = (arg2 << 8) + bytecode + CODE_START;
2359
2360   DISPATCH();
2361
2362   /***************************************************************************/
2363   CASE(CLOSURE);
2364
2365   FETCH_NEXT_BYTECODE();
2366   arg2 = bytecode;
2367
2368   FETCH_NEXT_BYTECODE();
2369
2370   IF_TRACE(printf("  (closure 0x%04x)\n", (arg2 << 8) | bytecode));
2371
2372   arg3 = POP(); // env
2373
2374   entry = (arg2 << 8) | bytecode; // TODO original had no CODE_START, why ?
2375
2376   arg1 = alloc_ram_cell_init (CLOSURE_FIELD0 | (arg2 >> 3),
2377                               ((arg2 & 0x07) << 5) | (bytecode >> 3),
2378                               ((bytecode & 0x07) << 5) |((arg3 & 0x1f00) >> 8),
2379                               arg3 & 0xff);
2380
2381   PUSH_ARG1();
2382
2383   arg2 = OBJ_FALSE;
2384   arg3 = OBJ_FALSE;
2385
2386   DISPATCH();
2387
2388   /***************************************************************************/
2389   CASE(PRIM1);
2390
2391   IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4]));
2392
2393   switch (bytecode_lo4)
2394     {
2395     case 0:
2396       arg1 = POP();  prim_numberp ();  PUSH_ARG1();  break;
2397     case 1:
2398       arg2 = POP();  arg1 = POP();  prim_add ();      PUSH_ARG1();  break;
2399     case 2:
2400       arg2 = POP();  arg1 = POP();  prim_sub ();      PUSH_ARG1();  break;
2401     case 3:
2402       arg2 = POP();  arg1 = POP();  prim_mul ();      PUSH_ARG1();  break;
2403     case 4:
2404       arg2 = POP();  arg1 = POP();  prim_div ();      PUSH_ARG1();  break;
2405     case 5:
2406       arg2 = POP();  arg1 = POP();  prim_rem ();      PUSH_ARG1();  break;
2407     case 6:
2408       arg1 = POP();  prim_neg ();      PUSH_ARG1();  break;
2409     case 7:
2410       arg2 = POP();  arg1 = POP();  prim_eq ();       PUSH_ARG1();  break;
2411     case 8:
2412       arg2 = POP();  arg1 = POP();  prim_lt ();       PUSH_ARG1();  break;
2413     case 9:
2414       arg2 = POP(); arg1 = POP(); prim_ior (); PUSH_ARG1(); break;
2415     case 10:
2416       arg2 = POP();  arg1 = POP();  prim_gt ();       PUSH_ARG1();  break;
2417     case 11:
2418       arg2 = POP(); arg1 = POP(); prim_xor (); PUSH_ARG1(); break;
2419     case 12:
2420       arg1 = POP();  prim_pairp ();    PUSH_ARG1();  break;
2421     case 13:
2422       arg2 = POP();  arg1 = POP();  prim_cons ();     PUSH_ARG1();  break;
2423     case 14:
2424       arg1 = POP();  prim_car ();      PUSH_ARG1();  break;
2425     case 15:
2426       arg1 = POP();  prim_cdr ();      PUSH_ARG1();  break;
2427     }
2428
2429   DISPATCH();
2430
2431   /***************************************************************************/
2432   CASE(PRIM2);
2433
2434   IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4+16]));
2435
2436   switch (bytecode_lo4)
2437     {
2438     case 0:
2439       arg2 = POP();  arg1 = POP();  prim_set_car ();                break;
2440     case 1:
2441       arg2 = POP();  arg1 = POP();  prim_set_cdr ();                break;
2442     case 2:
2443       arg1 = POP();  prim_nullp ();    PUSH_ARG1();  break;
2444     case 3:
2445       arg2 = POP();  arg1 = POP();  prim_eqp ();      PUSH_ARG1();  break;
2446     case 4:
2447       arg1 = POP();  prim_not ();      PUSH_ARG1();  break;
2448     case 5:
2449       /* prim #%get-cont */
2450       arg1 = cont;
2451       PUSH_ARG1();
2452       break;
2453     case 6:
2454       /* prim #%graft-to-cont */
2455
2456       arg1 = POP(); /* thunk to call */
2457       cont = POP(); /* continuation */
2458
2459       PUSH_ARG1();
2460
2461       na = 0;
2462
2463       pop_procedure ();
2464       handle_arity_and_rest_param ();
2465       build_env ();
2466
2467       env = arg1;
2468       pc = entry;
2469
2470       arg1 = OBJ_FALSE;
2471
2472       break;
2473     case 7:
2474       /* prim #%return-to-cont */
2475
2476       arg1 = POP(); /* value to return */
2477       cont = POP(); /* continuation */
2478
2479       arg2 = ram_get_cdr (cont);
2480
2481       pc = ram_get_entry (arg2);
2482
2483       env = ram_get_cdr (arg2);
2484       cont = ram_get_car (cont);
2485
2486       PUSH_ARG1();
2487       arg2 = OBJ_FALSE;
2488
2489       break;
2490     case 8:
2491       /* prim #%halt */
2492       return;
2493     case 9:
2494       /* prim #%symbol? */
2495       arg1 = POP();  prim_symbolp ();  PUSH_ARG1();  break;
2496     case 10:
2497       /* prim #%string? */
2498       arg1 = POP();  prim_stringp ();  PUSH_ARG1();  break;
2499     case 11:
2500       /* prim #%string->list */
2501       arg1 = POP();  prim_string2list ();  PUSH_ARG1();  break;
2502     case 12:
2503       /* prim #%list->string */
2504       arg1 = POP();  prim_list2string ();  PUSH_ARG1();  break;
2505     case 13:
2506       /* prim #%make-u8vector */
2507       arg1 = POP(); prim_make_u8vector (); PUSH_ARG1(); break;
2508     case 14:
2509       /* prim #%u8vector-ref */
2510       arg2 = POP(); arg1 = POP(); prim_u8vector_ref (); PUSH_ARG1(); break;
2511     case 15:
2512       /* prim #%u8vector-set! */
2513       arg3 = POP(); arg2 = POP(); arg1 = POP(); prim_u8vector_set (); break;
2514     }
2515
2516   DISPATCH();
2517
2518   /***************************************************************************/
2519   CASE(PRIM3);
2520
2521   IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4+32]));
2522
2523   switch (bytecode_lo4)
2524     {
2525     case 0:
2526       /* prim #%print */
2527       arg1 = POP();
2528       prim_print ();
2529       break;
2530     case 1:
2531       /* prim #%clock */
2532       prim_clock ();  PUSH_ARG1();  break;
2533     case 2:
2534       /* prim #%motor */
2535       arg2 = POP();  arg1 = POP();  prim_motor ();  break;
2536     case 3:
2537       /* prim #%led */
2538       arg3 = POP();  arg2 = POP();  arg1 = POP();  prim_led ();  ;break;
2539     case 4:
2540       /* prim #%led2-color */
2541       arg1 = POP();  prim_led2_color ();  break;
2542     case 5:
2543       /* prim #%getchar-wait */
2544       arg2 = POP();  arg1 = POP();  prim_getchar_wait ();  PUSH_ARG1();  break;
2545     case 6:
2546       /* prim #%putchar */
2547       arg2 = POP();  arg1 = POP();  prim_putchar ();  break;
2548     case 7:
2549       /* prim #%beep */
2550       arg2 = POP();  arg1 = POP();  prim_beep ();  break;
2551     case 8:
2552       /* prim #%adc */
2553       arg1 = POP();  prim_adc ();  PUSH_ARG1();  break;
2554     case 9:
2555       /* prim #%u8vector? */
2556       arg1 = POP(); prim_u8vectorp (); PUSH_ARG1(); break;
2557     case 10:
2558       /* prim #%sernum */
2559       prim_sernum ();  PUSH_ARG1();  break;
2560     case 11:
2561       /* prim #%u8vector-length */
2562       arg1 = POP(); prim_u8vector_length (); PUSH_ARG1(); break;
2563     case 12:
2564       /* push-constant [long] */
2565       FETCH_NEXT_BYTECODE(); // TODO BREGG this is a test, the compiler only knows what's in rom or lower, so we only need a byte, unless we change the number of rom addresses OOPS, 8 bits is not enough even for fixnums, we'd probably be ok with 12, though (actually 9, but that's harder to have and 12 gives us more room should we increase the number of rom addresses)
2566       arg2 = bytecode;
2567       FETCH_NEXT_BYTECODE();
2568       arg1 = (arg2 << 8) | bytecode;
2569       PUSH_ARG1();
2570       arg2 = OBJ_FALSE;
2571       break;
2572     case 13:
2573       /* shift */
2574       arg1 = POP();
2575       POP();
2576       PUSH_ARG1();
2577       break;
2578     case 14:
2579       /* pop */
2580       POP();
2581       break;
2582     case 15:
2583       /* return */
2584       arg1 = POP();
2585       arg2 = ram_get_cdr (cont);
2586       pc = ram_get_entry (arg2);
2587       env = ram_get_cdr (arg2);
2588       cont = ram_get_car (cont);
2589       PUSH_ARG1();
2590       arg2 = OBJ_FALSE;
2591       break;
2592     }
2593
2594   DISPATCH();
2595
2596   /***************************************************************************/
2597
2598   END_DISPATCH();
2599 }
2600
2601 /*---------------------------------------------------------------------------*/
2602
2603 #ifdef WORKSTATION
2604
2605 void usage (void)
2606 {
2607   printf ("usage: sim file.hex\n");
2608   exit (1);
2609 }
2610
2611 int main (int argc, char *argv[])
2612 {
2613   int errcode = 1;
2614   rom_addr rom_start_addr = 0;
2615
2616   if (argc > 1 && argv[1][0] == '-' && argv[1][1] == 's')
2617     {
2618       int h1;
2619       int h2;
2620       int h3;
2621       int h4;
2622
2623       if ((h1 = hex (argv[1][2])) < 0 ||
2624           (h2 = hex (argv[1][3])) < 0 ||
2625           (h3 = hex (argv[1][4])) != 0 ||
2626           (h4 = hex (argv[1][5])) != 0 ||
2627           argv[1][6] != '\0')
2628         usage ();
2629
2630       rom_start_addr = (h1 << 12) | (h2 << 8) | (h3 << 4) | h4;
2631
2632       argv++;
2633       argc--;
2634     }
2635
2636 #ifdef DEBUG
2637   printf ("Start address = 0x%04x\n", rom_start_addr); // TODO says 0, but should be CODE_START ?
2638 #endif
2639
2640   if (argc != 2)
2641     usage ();
2642
2643   if (!read_hex_file (argv[1]))
2644     printf ("*** Could not read hex file \"%s\"\n", argv[1]);
2645   else
2646     {
2647       int i;
2648
2649       if (rom_get (CODE_START+0) != 0xfb ||
2650           rom_get (CODE_START+1) != 0xd7)
2651         printf ("*** The hex file was not compiled with PICOBIT\n");
2652       else
2653         {
2654 #if 0
2655           for (i=0; i<8192; i++)
2656             if (rom_get (i) != 0xff)
2657               printf ("rom_mem[0x%04x] = 0x%02x\n", i, rom_get (i));
2658 #endif
2659
2660           interpreter ();
2661
2662 #ifdef DEBUG_GC
2663           printf ("**************** memory needed = %d\n", max_live+1);
2664 #endif
2665         }
2666     }
2667
2668   return errcode;
2669 }
2670
2671 #endif
2672
2673 /*---------------------------------------------------------------------------*/