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