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