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