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       a3 = rom_get_car (arg1); // we'll need the length later
1340       if ((a3 <= a2) || (a2 < 0))
1341         ERROR("vector index invalid");
1342       arg1 = rom_get_cdr (arg1);
1343     }
1344   else
1345     TYPE_ERROR("u8vector-ref", "vector");
1346
1347   if (IN_VEC(arg1))
1348     {
1349       arg1 += (a2 / 4);
1350       a2 %= 4;
1351
1352       switch (a2)
1353         {
1354         case 0:
1355           arg1 = ram_get_field0 (arg1); break;
1356         case 1:
1357           arg1 = ram_get_field1 (arg1); break;
1358         case 2:
1359           arg1 = ram_get_field2 (arg1); break;
1360         case 3:
1361           arg1 = ram_get_field3 (arg1); break;
1362         }
1363
1364       arg1 = encode_int (arg1);
1365     }
1366   else // rom vector, stored as a list
1367     { // 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)
1368       a1 = a2; // we save the index
1369
1370       while (a2--)
1371         arg1 = rom_get_cdr (arg1);
1372
1373       // since rom vectors are dotted pairs, the last element is in cdr
1374       if (a1 < (a3 - 1))
1375         arg1 = rom_get_car (arg1);
1376     }
1377
1378   arg2 = OBJ_FALSE;
1379   arg3 = OBJ_FALSE;
1380   arg4 = OBJ_FALSE;
1381 }
1382
1383 void prim_u8vector_set (void)
1384 { // TODO a lot in common with ref, abstract that
1385   a2 = decode_int (arg2);
1386   a3 = decode_int (arg3);
1387
1388   if (a3 > 255)
1389     ERROR("byte vectors can only contain bytes");
1390
1391   if (IN_RAM(arg1))
1392     {
1393       if (!RAM_VECTOR(arg1))
1394         TYPE_ERROR("u8vector-set!", "vector");
1395       if ((ram_get_car (arg1) <= a2) || (a2 < 0))
1396         ERROR("vector index invalid");
1397       arg1 = ram_get_cdr (arg1);
1398     }
1399   else
1400     TYPE_ERROR("u8vector-set!", "vector");
1401
1402   arg1 += (a2 / 4);
1403   a2 %= 4;
1404
1405   switch (a2)
1406     {
1407     case 0:
1408       ram_set_field0 (arg1, a3); break;
1409     case 1:
1410       ram_set_field1 (arg1, a3); break;
1411     case 2:
1412       ram_set_field2 (arg1, a3); break;
1413     case 3:
1414       ram_set_field3 (arg1, a3); break;
1415     }
1416
1417   arg1 = OBJ_FALSE;
1418   arg2 = OBJ_FALSE;
1419   arg3 = OBJ_FALSE;
1420 }
1421
1422 void prim_u8vector_length (void)
1423 {
1424   if (IN_RAM(arg1))
1425     {
1426       if (!RAM_VECTOR(arg1))
1427         TYPE_ERROR("u8vector-length", "vector");
1428       arg1 = encode_int (ram_get_car (arg1));
1429     }
1430   else if (IN_ROM(arg1))
1431     {
1432       if (!ROM_VECTOR(arg1))
1433         TYPE_ERROR("u8vector-length", "vector");
1434       arg1 = encode_int (rom_get_car (arg1));
1435     }
1436   else
1437     TYPE_ERROR("u8vector-length", "vector");
1438 }
1439
1440 void prim_u8vector_copy (void)
1441 {
1442   // arg1 is source, arg2 is source-start, arg3 is target, arg4 is target-start
1443   // arg5 is number of bytes to copy
1444
1445   a1 = decode_int (arg2);
1446   a2 = decode_int (arg4);
1447   a3 = decode_int (arg5);
1448
1449   // case 1 : ram to ram
1450   if (IN_RAM(arg1) && IN_RAM(arg3))
1451     {
1452       if (!RAM_VECTOR(arg1) || !RAM_VECTOR(arg3))
1453         TYPE_ERROR("u8vector-copy!", "vector");
1454       if ((ram_get_car (arg1) < (a1 + a3)) || (a1 < 0) ||
1455           (ram_get_car (arg3) < (a2 + a3)) || (a2 < 0))
1456         ERROR("vector index invalid");
1457
1458       // position to the start
1459       arg1 += (a1 / 4);
1460       a1 %= 4;
1461       arg3 += (a2 / 4);
1462       a2 %= 4;
1463
1464       // copy
1465       while (a3--)
1466         {
1467           switch (a1)
1468             {
1469             case 0:
1470               arg2 = ram_get_field0 (arg1);
1471               break;
1472             case 1:
1473               arg2 = ram_get_field1 (arg1);
1474               break;
1475             case 2:
1476               arg2 = ram_get_field2 (arg1);
1477               break;
1478             case 3:
1479               arg2 = ram_get_field3 (arg1);
1480               break;
1481             }
1482
1483           switch (a2)
1484             {
1485             case 0:
1486               ram_set_field0 (arg3, arg2);
1487               break;
1488             case 1:
1489               ram_set_field1 (arg3, arg2);
1490               break;
1491             case 2:
1492               ram_set_field2 (arg3, arg2);
1493               break;
1494             case 3:
1495               ram_set_field3 (arg3, arg2);
1496               break;
1497             }
1498
1499           a1++;
1500           arg1 += (a1 / 4);
1501           a1 %= 4; // TODO any way to merge with the previous similar block ?
1502           a2++;
1503           arg3 += (a2 / 4);
1504           a2 %= 4;
1505         }
1506     }
1507   // case 2 : rom to ram
1508   else if (IN_ROM(arg1) && IN_RAM(arg3))
1509     {
1510       if (!ROM_VECTOR(arg1) || !RAM_VECTOR(arg3))
1511         TYPE_ERROR("u8vector-copy!", "vector");
1512       if ((rom_get_car (arg1) < (a1 + a3)) || (a1 < 0) ||
1513           (ram_get_car (arg3) < (a2 + a3)) || (a2 < 0))
1514         ERROR("vector index invalid");
1515
1516       while (a1--)
1517         arg1 = rom_get_cdr (arg1); // TODO get rid of pointed lists for vectors ? pain in the ass
1518
1519       // TODO position the rom vector
1520       arg3 += (a2 / 4);
1521       a2 %= 4;
1522       // TODO do ACTUAL copy
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
1598 /*---------------------------------------------------------------------------*/
1599
1600 /* Robot specific operations */
1601
1602
1603 void prim_print (void)
1604 {
1605 #ifdef PICOBOARD2
1606 #endif
1607
1608 #ifdef WORKSTATION
1609
1610   print (arg1);
1611
1612 #endif
1613
1614   arg1 = OBJ_FALSE;
1615 }
1616
1617
1618 int32 read_clock (void)
1619 {
1620   int32 now = 0;
1621
1622 #ifdef PICOBOARD2
1623
1624   now = from_now( 0 );
1625
1626 #endif
1627
1628 #ifdef WORKSTATION
1629
1630 #ifdef _WIN32
1631
1632   static int32 start = 0;
1633   struct timeb tb;
1634
1635   ftime (&tb);
1636
1637   now = tb.time * 1000 + tb.millitm;
1638   if (start == 0)
1639     start = now;
1640   now -= start;
1641
1642 #else
1643
1644   static int32 start = 0;
1645   struct timeval tv;
1646
1647   if (gettimeofday (&tv, NULL) == 0)
1648     {
1649       now = tv.tv_sec * 1000 + tv.tv_usec / 1000;
1650       if (start == 0)
1651         start = now;
1652       now -= start;
1653     }
1654
1655 #endif
1656
1657 #endif
1658
1659   return now;
1660 }
1661
1662
1663 void prim_clock (void)
1664 {
1665   arg1 = encode_int (read_clock ());
1666 }
1667
1668
1669 void prim_motor (void)
1670 {
1671   decode_2_int_args ();
1672
1673   if (a1 < 1 || a1 > 2 || a2 < -100 || a2 > 100)
1674     ERROR("argument out of range to procedure \"motor\"");
1675
1676 #ifdef PICOBOARD2
1677
1678   fw_motor ();
1679
1680 #endif
1681
1682 #ifdef WORKSTATION
1683
1684   printf ("motor %d -> power=%d\n", a1, a2);
1685   fflush (stdout);
1686
1687 #endif
1688
1689   arg1 = OBJ_FALSE;
1690   arg2 = OBJ_FALSE;
1691 }
1692
1693
1694 void prim_led (void)
1695 {
1696   decode_2_int_args ();
1697   a3 = decode_int (arg3);
1698
1699   if (a1 < 1 || a1 > 3 || a2 < 0 || a3 < 0)
1700     ERROR("argument out of range to procedure \"led\"");
1701
1702 #ifdef PICOBOARD2
1703
1704   LED_set( a1, a2, a3 );
1705
1706 #endif
1707
1708 #ifdef WORKSTATION
1709
1710   printf ("led %d -> duty=%d period=%d\n", a1, a2, a3 );
1711   fflush (stdout);
1712
1713 #endif
1714
1715   arg1 = OBJ_FALSE;
1716   arg2 = OBJ_FALSE;
1717   arg3 = OBJ_FALSE;
1718 }
1719
1720
1721 void prim_led2_color (void)
1722 {
1723   a1 = decode_int (arg1);
1724
1725   if (a1 < 0 || a1 > 1)
1726     ERROR("argument out of range to procedure \"led2-color\"");
1727
1728 #ifdef PICOBOARD2
1729
1730   LED2_color_set( a1 );
1731
1732 #endif
1733
1734 #ifdef WORKSTATION
1735
1736   printf ("led2-color -> %s\n", (a1==0)?"green":"red");
1737   fflush (stdout);
1738
1739 #endif
1740
1741   arg1 = OBJ_FALSE;
1742 }
1743
1744
1745 void prim_getchar_wait (void)
1746 {
1747   decode_2_int_args();
1748   a1 = read_clock () + a1;
1749
1750   if (a1 < 0 || a2 < 1 || a2 > 3)
1751     ERROR("argument out of range to procedure \"getchar-wait\"");
1752
1753 #ifdef PICOBOARD2
1754
1755   arg1 = OBJ_FALSE;
1756
1757   {
1758     serial_port_set ports;
1759     ports = serial_rx_wait_with_timeout( a2, a1 );
1760     if (ports != 0)
1761       arg1 = encode_int (serial_rx_read( ports ));
1762   }
1763
1764 #endif
1765
1766 #ifdef WORKSTATION
1767
1768 #ifdef _WIN32
1769
1770   arg1 = OBJ_FALSE;
1771
1772   do
1773     {
1774       if (_kbhit ())
1775         {
1776           arg1 = encode_int (_getch ());
1777           break;
1778         }
1779     } while (read_clock () < a1);
1780
1781
1782 #else
1783
1784   arg1 = encode_int (getchar ());
1785
1786 #endif
1787
1788 #endif
1789 }
1790
1791
1792 void prim_putchar (void)
1793 {
1794   decode_2_int_args ();
1795
1796   if (a1 < 0 || a1 > 255 || a2 < 1 || a2 > 3)
1797     ERROR("argument out of range to procedure \"putchar\"");
1798
1799 #ifdef PICOBOARD2
1800
1801   serial_tx_write( a2, a1 );
1802
1803 #endif
1804
1805 #ifdef WORKSTATION
1806
1807   putchar (a1);
1808   fflush (stdout);
1809
1810 #endif
1811
1812   arg1 = OBJ_FALSE;
1813   arg2 = OBJ_FALSE;
1814 }
1815
1816
1817 void prim_beep (void)
1818 {
1819   decode_2_int_args ();
1820
1821   if (a1 < 1 || a1 > 255 || a2 < 0)
1822     ERROR("argument out of range to procedure \"beep\"");
1823
1824 #ifdef PICOBOARD2
1825
1826   beep( a1, from_now( a2 ) );
1827
1828 #endif
1829
1830 #ifdef WORKSTATION
1831
1832   printf ("beep -> freq-div=%d duration=%d\n", a1, a2 );
1833   fflush (stdout);
1834
1835 #endif
1836
1837   arg1 = OBJ_FALSE;
1838   arg2 = OBJ_FALSE;
1839 }
1840
1841
1842 void prim_adc (void)
1843 {
1844   short x;
1845
1846   a1 = decode_int (arg1);
1847
1848   if (a1 < 1 || a1 > 3)
1849     ERROR("argument out of range to procedure \"adc\"");
1850
1851 #ifdef PICOBOARD2
1852
1853   x = adc( a1 );
1854
1855 #endif
1856
1857 #ifdef WORKSTATION
1858
1859   x = read_clock () & 255;
1860
1861   if (x > 127) x = 256 - x;
1862
1863   x += 200;
1864
1865 #endif
1866
1867   arg1 = encode_int (x);
1868 }
1869
1870
1871 void prim_dac (void)
1872 {
1873   a1 = decode_int (arg1);
1874
1875   if (a1 < 0 || a1 > 255)
1876     ERROR("argument out of range to procedure \"dac\"");
1877
1878 #ifdef PICOBOARD2
1879
1880   dac( a1 );
1881
1882 #endif
1883
1884 #ifdef WORKSTATION
1885
1886   printf ("dac -> %d\n", a1 );
1887   fflush (stdout);
1888
1889 #endif
1890
1891   arg1 = OBJ_FALSE;
1892 }
1893
1894
1895 void prim_sernum (void)
1896 {
1897   short x;
1898
1899 #ifdef PICOBOARD2
1900
1901   x = serial_num ();
1902
1903 #endif
1904
1905 #ifdef WORKSTATION
1906
1907   x = 0;
1908
1909 #endif
1910
1911   arg1 = encode_int (x);
1912 }
1913
1914
1915 /*---------------------------------------------------------------------------*/
1916
1917 #ifdef WORKSTATION
1918
1919 int hidden_fgetc (FILE *f)
1920 {
1921   int c = fgetc (f);
1922 #if 0
1923   printf ("{%d}",c);
1924   fflush (stdout);
1925 #endif
1926   return c;
1927 }
1928
1929 #define fgetc(f) hidden_fgetc(f)
1930
1931 void write_hex_nibble (int n)
1932 {
1933   putchar ("0123456789ABCDEF"[n]);
1934 }
1935
1936 void write_hex (uint8 n)
1937 {
1938   write_hex_nibble (n >> 4);
1939   write_hex_nibble (n & 0x0f);
1940 }
1941
1942 int hex (int c)
1943 {
1944   if (c >= '0' && c <= '9')
1945     return (c - '0');
1946
1947   if (c >= 'A' && c <= 'F')
1948     return (c - 'A' + 10);
1949
1950   if (c >= 'a' && c <= 'f')
1951     return (c - 'a' + 10);
1952
1953   return -1;
1954 }
1955
1956 int read_hex_byte (FILE *f)
1957 {
1958   int h1 = hex (fgetc (f));
1959   int h2 = hex (fgetc (f));
1960
1961   if (h1 >= 0 && h2 >= 0)
1962     return (h1<<4) + h2;
1963
1964   return -1;
1965 }
1966
1967 int read_hex_file (char *filename)
1968 {
1969   int c;
1970   FILE *f = fopen (filename, "r");
1971   int result = 0;
1972   int len;
1973   int a, a1, a2;
1974   int t;
1975   int b;
1976   int i;
1977   uint8 sum;
1978   int hi16 = 0;
1979
1980   for (i=0; i<ROM_BYTES; i++)
1981     rom_mem[i] = 0xff;
1982
1983   if (f != NULL)
1984     {
1985       while ((c = fgetc (f)) != EOF)
1986         {
1987           if ((c == '\r') || (c == '\n'))
1988             continue;
1989
1990           if (c != ':' ||
1991               (len = read_hex_byte (f)) < 0 ||
1992               (a1 = read_hex_byte (f)) < 0 ||
1993               (a2 = read_hex_byte (f)) < 0 ||
1994               (t = read_hex_byte (f)) < 0)
1995             break;
1996
1997           a = (a1 << 8) + a2;
1998
1999           i = 0;
2000           sum = len + a1 + a2 + t;
2001
2002           if (t == 0)
2003             {
2004             next0:
2005
2006               if (i < len)
2007                 {
2008                   unsigned long adr = ((unsigned long)hi16 << 16) + a - CODE_START;
2009
2010                   if ((b = read_hex_byte (f)) < 0)
2011                     break;
2012
2013                   if (adr >= 0 && adr < ROM_BYTES)
2014                     rom_mem[adr] = b;
2015
2016                   a = (a + 1) & 0xffff;
2017                   i++;
2018                   sum += b;
2019
2020                   goto next0;
2021                 }
2022             }
2023           else if (t == 1)
2024             {
2025               if (len != 0)
2026                 break;
2027             }
2028           else if (t == 4)
2029             {
2030               if (len != 2)
2031                 break;
2032
2033               if ((a1 = read_hex_byte (f)) < 0 ||
2034                   (a2 = read_hex_byte (f)) < 0)
2035                 break;
2036
2037               sum += a1 + a2;
2038
2039               hi16 = (a1<<8) + a2;
2040             }
2041           else
2042             break;
2043
2044           if ((b = read_hex_byte (f)) < 0)
2045             break;
2046
2047           sum = -sum;
2048
2049           if (sum != b)
2050             {
2051               printf ("*** HEX file checksum error (expected 0x%02x)\n", sum);
2052               break;
2053             }
2054
2055           c = fgetc (f);
2056
2057           if ((c != '\r') && (c != '\n'))
2058             break;
2059
2060           if (t == 1)
2061             {
2062               result = 1;
2063               break;
2064             }
2065         }
2066
2067       if (result == 0)
2068         printf ("*** HEX file syntax error\n");
2069
2070       fclose (f);
2071     }
2072
2073   return result;
2074 }
2075
2076 #endif
2077
2078 /*---------------------------------------------------------------------------*/
2079
2080 #define FETCH_NEXT_BYTECODE() bytecode = rom_get (pc++)
2081
2082 #define BEGIN_DISPATCH()                        \
2083   dispatch:                                     \
2084   IF_TRACE(show_state (pc));                    \
2085   FETCH_NEXT_BYTECODE();                        \
2086   bytecode_hi4 = bytecode & 0xf0;               \
2087   bytecode_lo4 = bytecode & 0x0f;               \
2088   switch (bytecode_hi4 >> 4) {
2089
2090 #define END_DISPATCH() }
2091
2092 #define CASE(opcode) case (opcode>>4):;
2093
2094 #define DISPATCH(); goto dispatch;
2095
2096 #if 0
2097 #define pc FSR1
2098 #define sp FSR2
2099 #define bytecode TABLAT
2100 #define bytecode_hi4 WREG
2101 #endif
2102
2103 #define PUSH_CONSTANT1     0x00
2104 #define PUSH_CONSTANT2     0x10
2105 #define PUSH_STACK1        0x20
2106 #define PUSH_STACK2        0x30
2107 #define PUSH_GLOBAL        0x40
2108 #define SET_GLOBAL         0x50
2109 #define CALL               0x60
2110 #define JUMP               0x70
2111 #define LABEL_INSTR        0x80
2112 #define PUSH_CONSTANT_LONG 0x90
2113
2114 // TODO these are free
2115 #define GOTO               0xa0
2116 #define GOTO_IF_FALSE      0xb0
2117
2118 #define PRIM1              0xc0
2119 #define PRIM2              0xd0
2120 #define PRIM3              0xe0
2121 #define PRIM4              0xf0
2122
2123 #ifdef WORKSTATION
2124
2125 char *prim_name[64] =
2126   {
2127     "prim #%number?",
2128     "prim #%+",
2129     "prim #%-",
2130     "prim #%*",
2131     "prim #%quotient",
2132     "prim #%remainder",
2133     "prim #%neg",
2134     "prim #%=",
2135     "prim #%<",
2136     "prim #%ior",
2137     "prim #%>",
2138     "prim #%xor",
2139     "prim #%pair?",
2140     "prim #%cons",
2141     "prim #%car",
2142     "prim #%cdr",
2143     "prim #%set-car!",
2144     "prim #%set-cdr!",
2145     "prim #%null?",
2146     "prim #%eq?",
2147     "prim #%not",
2148     "prim #%get-cont",
2149     "prim #%graft-to-cont",
2150     "prim #%return-to-cont",
2151     "prim #%halt",
2152     "prim #%symbol?",
2153     "prim #%string?",
2154     "prim #%string->list",
2155     "prim #%list->string",
2156     "prim #%make-u8vector",
2157     "prim #%u8vector-ref",
2158     "prim #%u8vector-set!",
2159     "prim #%print",
2160     "prim #%clock",
2161     "prim #%motor",
2162     "prim #%led",
2163     "prim #%led2-color",
2164     "prim #%getchar-wait",
2165     "prim #%putchar",
2166     "prim #%beep",
2167     "prim #%adc",
2168     "prim #%u8vector?", // TODO was dac, but it's not plugged to anything
2169     "prim #%sernum",
2170     "prim #%u8vector-length",
2171     "prim #%u8vector-copy!",
2172     "shift",
2173     "pop",
2174     "return",
2175     "prim 48",
2176     "prim 49",
2177     "prim 50",
2178     "prim 51",
2179     "prim 52",
2180     "prim 53",
2181     "prim 54",
2182     "prim 55",
2183     "prim 56",
2184     "prim 57",
2185     "prim 58",
2186     "prim 59",
2187     "prim 60",
2188     "prim 61",
2189     "prim 62",
2190     "prim 63"
2191   };
2192
2193 #endif
2194
2195 #define PUSH_ARG1() push_arg1 ()
2196 #define POP() pop()
2197
2198 void push_arg1 (void)
2199 {
2200   env = cons (arg1, env);
2201   arg1 = OBJ_FALSE;
2202 }
2203
2204 obj pop (void)
2205 {
2206   obj o = ram_get_car (env);
2207   env = ram_get_cdr (env);
2208   return o;
2209 }
2210
2211 void pop_procedure (void)
2212 {
2213   arg1 = POP();
2214
2215   if (IN_RAM(arg1))
2216     {
2217       if (!RAM_CLOSURE(arg1))
2218         TYPE_ERROR("pop_procedure", "procedure");
2219
2220       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
2221     }
2222   else if (IN_ROM(arg1))
2223     {
2224       if (!ROM_CLOSURE(arg1))
2225         TYPE_ERROR("pop_procedure", "procedure");
2226
2227       entry = rom_get_entry (arg1) + CODE_START;
2228     }
2229   else
2230     TYPE_ERROR("pop_procedure", "procedure");
2231 }
2232
2233 void handle_arity_and_rest_param (void)
2234 {
2235   uint8 np;
2236
2237   np = rom_get (entry++);
2238
2239   if ((np & 0x80) == 0)
2240     {
2241       if (na != np)
2242         ERROR("wrong number of arguments");
2243     }
2244   else
2245     {
2246       np = ~np;
2247
2248       if (na < np)
2249         ERROR("wrong number of arguments");
2250
2251       arg3 = OBJ_NULL;
2252
2253       while (na > np)
2254         {
2255           arg4 = POP();
2256
2257           arg3 = cons (arg4, arg3);
2258           arg4 = OBJ_FALSE;
2259
2260           na--;
2261         }
2262
2263       arg1 = cons (arg3, arg1);
2264       arg3 = OBJ_FALSE;
2265     }
2266 }
2267
2268 void build_env (void)
2269 {
2270   while (na != 0)
2271     {
2272       arg3 = POP();
2273
2274       arg1 = cons (arg3, arg1);
2275
2276       na--;
2277     }
2278
2279   arg3 = OBJ_FALSE;
2280 }
2281
2282 void save_cont (void)
2283 {
2284   // the second half is a closure
2285   arg3 = alloc_ram_cell_init (CLOSURE_FIELD0 | (pc >> 11),
2286                               (pc >> 3) & 0xff,
2287                               ((pc & 0x0007) << 5) | (env >> 8),
2288                               env & 0xff);
2289   cont = alloc_ram_cell_init (COMPOSITE_FIELD0 | (cont >> 8),
2290                               cont & 0xff,
2291                               CONTINUATION_FIELD2 | (arg3 >> 8),
2292                               arg3 & 0xff);
2293   arg3 = OBJ_FALSE;
2294 }
2295
2296 void interpreter (void)
2297 {
2298   pc = (CODE_START + 4) + ((rom_addr)rom_get (CODE_START+2) << 2);
2299
2300   glovars = rom_get (CODE_START+3); // number of global variables
2301
2302   init_ram_heap ();
2303
2304   BEGIN_DISPATCH();
2305
2306   /***************************************************************************/
2307   CASE(PUSH_CONSTANT1);
2308
2309   IF_TRACE(printf("  (push-constant "); show (bytecode_lo4); printf (")\n"));
2310
2311   arg1 = bytecode_lo4;
2312
2313   PUSH_ARG1();
2314
2315   DISPATCH();
2316
2317   /***************************************************************************/
2318   CASE(PUSH_CONSTANT2);
2319
2320   IF_TRACE(printf("  (push-constant "); show (bytecode_lo4+16); printf (")\n"));
2321   arg1 = bytecode_lo4+16;
2322
2323   PUSH_ARG1();
2324
2325   DISPATCH();
2326
2327   /***************************************************************************/
2328   CASE(PUSH_STACK1);
2329
2330   IF_TRACE(printf("  (push-stack %d)\n", bytecode_lo4));
2331
2332   arg1 = env;
2333
2334   while (bytecode_lo4 != 0)
2335     {
2336       arg1 = ram_get_cdr (arg1);
2337       bytecode_lo4--;
2338     }
2339
2340   arg1 = ram_get_car (arg1);
2341
2342   PUSH_ARG1();
2343
2344   DISPATCH();
2345
2346   /***************************************************************************/
2347   CASE(PUSH_STACK2);
2348
2349   IF_TRACE(printf("  (push-stack %d)\n", bytecode_lo4+16));
2350   // TODO does this ever happens ?
2351   bytecode_lo4 += 16;
2352
2353   arg1 = env;
2354
2355   while (bytecode_lo4 != 0)
2356     {
2357       arg1 = ram_get_cdr (arg1);
2358       bytecode_lo4--;
2359     }
2360
2361   arg1 = ram_get_car (arg1);
2362
2363   PUSH_ARG1();
2364
2365   DISPATCH();
2366
2367   /***************************************************************************/
2368   CASE(PUSH_GLOBAL);
2369
2370   IF_TRACE(printf("  (push-global %d)\n", bytecode_lo4));
2371
2372   arg1 = get_global (bytecode_lo4);
2373
2374   PUSH_ARG1();
2375
2376   DISPATCH();
2377
2378   /***************************************************************************/
2379   CASE(SET_GLOBAL);
2380
2381   IF_TRACE(printf("  (set-global %d)\n", bytecode_lo4));
2382
2383   set_global (bytecode_lo4, POP());
2384
2385   DISPATCH();
2386
2387   /***************************************************************************/
2388   CASE(CALL);
2389
2390   IF_TRACE(printf("  (call %d)\n", bytecode_lo4));
2391
2392   na = bytecode_lo4;
2393
2394   pop_procedure ();
2395   handle_arity_and_rest_param ();
2396   build_env ();
2397   save_cont ();
2398
2399   env = arg1;
2400   pc = entry;
2401
2402   arg1 = OBJ_FALSE;
2403
2404   DISPATCH();
2405
2406   /***************************************************************************/
2407   CASE(JUMP);
2408
2409   IF_TRACE(printf("  (jump %d)\n", bytecode_lo4));
2410
2411   na = bytecode_lo4;
2412
2413   pop_procedure ();
2414   handle_arity_and_rest_param ();
2415   build_env ();
2416
2417   env = arg1;
2418   pc = entry;
2419
2420   arg1 = OBJ_FALSE;
2421
2422   DISPATCH();
2423
2424   /***************************************************************************/
2425   CASE(LABEL_INSTR);
2426
2427   switch (bytecode_lo4)
2428     {
2429     case 0: // call-toplevel TODO put these in separate functions ?
2430       FETCH_NEXT_BYTECODE();
2431       arg2 = bytecode;
2432
2433       FETCH_NEXT_BYTECODE();
2434
2435       IF_TRACE(printf("  (call-toplevel 0x%04x)\n",
2436                       ((arg2 << 8) | bytecode) + CODE_START));
2437
2438       entry = (arg2 << 8) + bytecode + CODE_START;
2439       arg1 = OBJ_NULL;
2440
2441       na = rom_get (entry++);
2442
2443       build_env ();
2444       save_cont ();
2445
2446       env = arg1;
2447       pc = entry;
2448
2449       arg1 = OBJ_FALSE;
2450       arg2 = OBJ_FALSE;
2451
2452       break;
2453
2454     case 1: // jump-toplevel
2455       FETCH_NEXT_BYTECODE();
2456       arg2 = bytecode;
2457
2458       FETCH_NEXT_BYTECODE();
2459
2460       IF_TRACE(printf("  (jump-toplevel 0x%04x)\n",
2461                       ((arg2 << 8) | bytecode) + CODE_START));
2462
2463       entry = (arg2 << 8) + bytecode + CODE_START; // TODO this is a common pattern
2464       arg1 = OBJ_NULL;
2465
2466       na = rom_get (entry++);
2467
2468       build_env ();
2469
2470       env = arg1;
2471       pc = entry;
2472
2473       arg1 = OBJ_FALSE;
2474       arg2 = OBJ_FALSE;
2475
2476       break;
2477
2478     case 2: // goto
2479       FETCH_NEXT_BYTECODE();
2480       arg2 = bytecode;
2481
2482       FETCH_NEXT_BYTECODE();
2483
2484       IF_TRACE(printf("  (goto 0x%04x)\n",
2485                       (arg2 << 8) + bytecode + CODE_START));
2486
2487       pc = (arg2 << 8) + bytecode + CODE_START;
2488
2489       break;
2490
2491     case 3: // goto-if-false
2492       FETCH_NEXT_BYTECODE();
2493       arg2 = bytecode;
2494
2495       FETCH_NEXT_BYTECODE();
2496
2497       IF_TRACE(printf("  (goto-if-false 0x%04x)\n",
2498                       (arg2 << 8) + bytecode + CODE_START));
2499
2500       if (POP() == OBJ_FALSE)
2501         pc = (arg2 << 8) + bytecode + CODE_START;
2502
2503       break;
2504
2505     case 4: // closure
2506       FETCH_NEXT_BYTECODE();
2507       arg2 = bytecode;
2508
2509       FETCH_NEXT_BYTECODE();
2510
2511       IF_TRACE(printf("  (closure 0x%04x)\n", (arg2 << 8) | bytecode));
2512
2513       arg3 = POP(); // env
2514
2515       entry = (arg2 << 8) | bytecode;
2516
2517       arg1 = alloc_ram_cell_init (CLOSURE_FIELD0 | (arg2 >> 3),
2518                                   ((arg2 & 0x07) << 5) | (bytecode >> 3),
2519                                   ((bytecode &0x07) <<5) |((arg3 &0x1f00) >>8),
2520                                   arg3 & 0xff);
2521
2522       PUSH_ARG1();
2523
2524       arg2 = OBJ_FALSE;
2525       arg3 = OBJ_FALSE;
2526
2527       break;
2528
2529     case 5: // call-toplevel-short
2530       FETCH_NEXT_BYTECODE(); // TODO the sort version have a lot in common with the long ones, abstract ?
2531       // TODO short instructions don't work at the moment
2532       IF_TRACE(printf("  (call-toplevel-short 0x%04x)\n",
2533                       pc + bytecode + CODE_START));
2534
2535       entry = pc + bytecode + CODE_START;
2536       arg1 = OBJ_NULL;
2537
2538       na = rom_get (entry++);
2539
2540       build_env ();
2541       save_cont ();
2542
2543       env = arg1;
2544       pc = entry;
2545
2546       arg1 = OBJ_FALSE;
2547
2548       break;
2549
2550     case 6: // jump-toplevel-short
2551       FETCH_NEXT_BYTECODE();
2552
2553       IF_TRACE(printf("  (jump-toplevel-short 0x%04x)\n",
2554                       pc + bytecode + CODE_START));
2555
2556       entry = pc + bytecode + CODE_START;
2557       arg1 = OBJ_NULL;
2558
2559       na = rom_get (entry++);
2560
2561       build_env ();
2562
2563       env = arg1;
2564       pc = entry;
2565
2566       arg1 = OBJ_FALSE;
2567
2568       break;
2569
2570     case 7: // goto-short
2571       FETCH_NEXT_BYTECODE();
2572
2573       IF_TRACE(printf("  (goto-short 0x%04x)\n", pc + bytecode + CODE_START));
2574
2575       pc = pc + bytecode + CODE_START;
2576
2577       break;
2578
2579     case 8: // goto-if-false-short
2580       FETCH_NEXT_BYTECODE();
2581
2582       IF_TRACE(printf("  (goto-if-false-short 0x%04x)\n",
2583                       pc + bytecode + CODE_START));
2584
2585       if (POP() == OBJ_FALSE)
2586         pc = pc + bytecode + CODE_START;
2587
2588       break;
2589
2590     case 9: // closure-short TODO I doubt these short instrs will have great effect, and this is the one I doubt the most about
2591       FETCH_NEXT_BYTECODE();
2592
2593       IF_TRACE(printf("  (closure-short 0x%04x)\n", pc + bytecode));
2594
2595       arg3 = POP(); // env
2596
2597       entry = pc + bytecode; // TODO makes sense for a closure ?
2598
2599       arg1 = alloc_ram_cell_init (CLOSURE_FIELD0 | (arg2 >> 3),
2600                                   ((arg2 & 0x07) << 5) | (bytecode >> 3),
2601                                   ((bytecode &0x07) <<5) |((arg3 &0x1f00) >>8),
2602                                   arg3 & 0xff);
2603
2604       PUSH_ARG1();
2605
2606       arg3 = OBJ_FALSE;
2607
2608       break;
2609
2610 #if 0
2611     case 10:
2612       break;
2613     case 11:
2614       break;
2615     case 12:
2616       break;
2617     case 13:
2618       break;
2619 #endif
2620     case 14: // push_global [long]
2621       FETCH_NEXT_BYTECODE();
2622
2623       IF_TRACE(printf("  (push-global [long] %d)\n", bytecode));
2624
2625       arg1 = get_global (bytecode);
2626
2627       PUSH_ARG1();
2628
2629       break;
2630
2631     case 15: // set_global [long]
2632       FETCH_NEXT_BYTECODE();
2633
2634       IF_TRACE(printf("  (set-global [long] %d)\n", bytecode));
2635
2636       set_global (bytecode, POP());
2637
2638       break;
2639     }
2640
2641   DISPATCH();
2642
2643   /***************************************************************************/
2644   CASE(PUSH_CONSTANT_LONG);
2645
2646   /* push-constant [long] */
2647
2648   FETCH_NEXT_BYTECODE();
2649
2650   IF_TRACE(printf("  (push [long] 0x%04x)\n", (bytecode_lo4 << 8) + bytecode));
2651
2652   arg1 = (bytecode_lo4 << 8) | bytecode;
2653   PUSH_ARG1();
2654
2655   DISPATCH();
2656
2657   /***************************************************************************/
2658   CASE(GOTO); // BREGG move
2659
2660   DISPATCH();
2661
2662   /***************************************************************************/
2663   CASE(GOTO_IF_FALSE); // BREGG move
2664
2665   DISPATCH();
2666
2667   /***************************************************************************/
2668   CASE(PRIM1);
2669
2670   IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4]));
2671
2672   switch (bytecode_lo4)
2673     {
2674     case 0:
2675       arg1 = POP();  prim_numberp ();  PUSH_ARG1();  break;
2676     case 1:
2677       arg2 = POP();  arg1 = POP();  prim_add ();      PUSH_ARG1();  break;
2678     case 2:
2679       arg2 = POP();  arg1 = POP();  prim_sub ();      PUSH_ARG1();  break;
2680     case 3:
2681       arg2 = POP();  arg1 = POP();  prim_mul ();      PUSH_ARG1();  break;
2682     case 4:
2683       arg2 = POP();  arg1 = POP();  prim_div ();      PUSH_ARG1();  break;
2684     case 5:
2685       arg2 = POP();  arg1 = POP();  prim_rem ();      PUSH_ARG1();  break;
2686     case 6:
2687       arg1 = POP();  prim_neg ();      PUSH_ARG1();  break;
2688     case 7:
2689       arg2 = POP();  arg1 = POP();  prim_eq ();       PUSH_ARG1();  break;
2690     case 8:
2691       arg2 = POP();  arg1 = POP();  prim_lt ();       PUSH_ARG1();  break;
2692     case 9:
2693       arg2 = POP(); arg1 = POP(); prim_ior (); PUSH_ARG1(); break;
2694     case 10:
2695       arg2 = POP();  arg1 = POP();  prim_gt ();       PUSH_ARG1();  break;
2696     case 11:
2697       arg2 = POP(); arg1 = POP(); prim_xor (); PUSH_ARG1(); break;
2698     case 12:
2699       arg1 = POP();  prim_pairp ();    PUSH_ARG1();  break;
2700     case 13:
2701       arg2 = POP();  arg1 = POP();  prim_cons ();     PUSH_ARG1();  break;
2702     case 14:
2703       arg1 = POP();  prim_car ();      PUSH_ARG1();  break;
2704     case 15:
2705       arg1 = POP();  prim_cdr ();      PUSH_ARG1();  break;
2706     }
2707
2708   DISPATCH();
2709
2710   /***************************************************************************/
2711   CASE(PRIM2);
2712
2713   IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4+16]));
2714
2715   switch (bytecode_lo4)
2716     {
2717     case 0:
2718       arg2 = POP();  arg1 = POP();  prim_set_car ();                break;
2719     case 1:
2720       arg2 = POP();  arg1 = POP();  prim_set_cdr ();                break;
2721     case 2:
2722       arg1 = POP();  prim_nullp ();    PUSH_ARG1();  break;
2723     case 3:
2724       arg2 = POP();  arg1 = POP();  prim_eqp ();      PUSH_ARG1();  break;
2725     case 4:
2726       arg1 = POP();  prim_not ();      PUSH_ARG1();  break;
2727     case 5:
2728       /* prim #%get-cont */
2729       arg1 = cont;
2730       PUSH_ARG1();
2731       break;
2732     case 6:
2733       /* prim #%graft-to-cont */
2734
2735       arg1 = POP(); /* thunk to call */
2736       cont = POP(); /* continuation */
2737
2738       PUSH_ARG1();
2739
2740       na = 0;
2741
2742       pop_procedure ();
2743       handle_arity_and_rest_param ();
2744       build_env ();
2745
2746       env = arg1;
2747       pc = entry;
2748
2749       arg1 = OBJ_FALSE;
2750
2751       break;
2752     case 7:
2753       /* prim #%return-to-cont */
2754
2755       arg1 = POP(); /* value to return */
2756       cont = POP(); /* continuation */
2757
2758       arg2 = ram_get_cdr (cont);
2759
2760       pc = ram_get_entry (arg2);
2761
2762       env = ram_get_cdr (arg2);
2763       cont = ram_get_car (cont);
2764
2765       PUSH_ARG1();
2766       arg2 = OBJ_FALSE;
2767
2768       break;
2769     case 8:
2770       /* prim #%halt */
2771       return;
2772     case 9:
2773       /* prim #%symbol? */
2774       arg1 = POP();  prim_symbolp ();  PUSH_ARG1();  break;
2775     case 10:
2776       /* prim #%string? */
2777       arg1 = POP();  prim_stringp ();  PUSH_ARG1();  break;
2778     case 11:
2779       /* prim #%string->list */
2780       arg1 = POP();  prim_string2list ();  PUSH_ARG1();  break;
2781     case 12:
2782       /* prim #%list->string */
2783       arg1 = POP();  prim_list2string ();  PUSH_ARG1();  break;
2784     case 13:
2785       /* prim #%make-u8vector */
2786       arg2 = POP(); arg1 = POP(); prim_make_u8vector (); PUSH_ARG1(); break;
2787     case 14:
2788       /* prim #%u8vector-ref */
2789       arg2 = POP(); arg1 = POP(); prim_u8vector_ref (); PUSH_ARG1(); break;
2790     case 15:
2791       /* prim #%u8vector-set! */
2792       arg3 = POP(); arg2 = POP(); arg1 = POP(); prim_u8vector_set (); break;
2793     }
2794
2795   DISPATCH();
2796
2797   /***************************************************************************/
2798   CASE(PRIM3);
2799
2800   IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4+32]));
2801
2802   switch (bytecode_lo4)
2803     {
2804     case 0:
2805       /* prim #%print */
2806       arg1 = POP();
2807       prim_print ();
2808       break;
2809     case 1:
2810       /* prim #%clock */
2811       prim_clock ();  PUSH_ARG1();  break;
2812     case 2:
2813       /* prim #%motor */
2814       arg2 = POP();  arg1 = POP();  prim_motor ();  break;
2815     case 3:
2816       /* prim #%led */
2817       arg3 = POP();  arg2 = POP();  arg1 = POP();  prim_led ();  ;break;
2818     case 4:
2819       /* prim #%led2-color */
2820       arg1 = POP();  prim_led2_color ();  break;
2821     case 5:
2822       /* prim #%getchar-wait */
2823       arg2 = POP();  arg1 = POP();  prim_getchar_wait ();  PUSH_ARG1();  break;
2824     case 6:
2825       /* prim #%putchar */
2826       arg2 = POP();  arg1 = POP();  prim_putchar ();  break;
2827     case 7:
2828       /* prim #%beep */
2829       arg2 = POP();  arg1 = POP();  prim_beep ();  break;
2830     case 8:
2831       /* prim #%adc */
2832       arg1 = POP();  prim_adc ();  PUSH_ARG1();  break;
2833     case 9:
2834       /* prim #%u8vector? */
2835       arg1 = POP(); prim_u8vectorp (); PUSH_ARG1(); break;
2836     case 10:
2837       /* prim #%sernum */
2838       prim_sernum ();  PUSH_ARG1();  break;
2839     case 11:
2840       /* prim #%u8vector-length */
2841       arg1 = POP(); prim_u8vector_length (); PUSH_ARG1(); break;
2842     case 12:
2843       /* prim #%u8vector-copy! */
2844       arg5 = POP(); arg4 = POP(); arg3 = POP(); arg2 = POP(); arg1 = POP();
2845       prim_u8vector_copy (); break;
2846       break;
2847     case 13:
2848       /* shift */
2849       arg1 = POP();
2850       POP();
2851       PUSH_ARG1();
2852       break;
2853     case 14:
2854       /* pop */
2855       POP();
2856       break;
2857     case 15:
2858       /* return */
2859       arg1 = POP();
2860       arg2 = ram_get_cdr (cont);
2861       pc = ram_get_entry (arg2);
2862       env = ram_get_cdr (arg2);
2863       cont = ram_get_car (cont);
2864       PUSH_ARG1();
2865       arg2 = OBJ_FALSE;
2866       break;
2867     }
2868
2869   DISPATCH();
2870
2871   /***************************************************************************/
2872
2873   CASE(PRIM4);
2874
2875   IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4]));
2876
2877   switch (bytecode_lo4)
2878     {
2879     case 0:
2880       break;
2881     case 1:
2882       break;
2883     case 2:
2884       break;
2885     case 3:
2886       break;
2887     case 4:
2888       break;
2889     case 5:
2890       break;
2891     case 6:
2892       break;
2893     case 7:
2894       break;
2895     case 8:
2896       break;
2897     case 9:
2898       break;
2899     case 10:
2900       break;
2901     case 11:
2902       break;
2903     case 12:
2904       break;
2905     case 13:
2906       break;
2907     case 14:
2908       break;
2909     case 15:
2910       break;
2911     }
2912
2913   DISPATCH();
2914
2915   /***************************************************************************/
2916
2917   END_DISPATCH();
2918 }
2919
2920 /*---------------------------------------------------------------------------*/
2921
2922 #ifdef WORKSTATION
2923
2924 void usage (void)
2925 {
2926   printf ("usage: sim file.hex\n");
2927   exit (1);
2928 }
2929
2930 int main (int argc, char *argv[])
2931 {
2932   int errcode = 1;
2933   rom_addr rom_start_addr = 0;
2934
2935   if (argc > 1 && argv[1][0] == '-' && argv[1][1] == 's')
2936     {
2937       int h1;
2938       int h2;
2939       int h3;
2940       int h4;
2941
2942       if ((h1 = hex (argv[1][2])) < 0 ||
2943           (h2 = hex (argv[1][3])) < 0 ||
2944           (h3 = hex (argv[1][4])) != 0 ||
2945           (h4 = hex (argv[1][5])) != 0 ||
2946           argv[1][6] != '\0')
2947         usage ();
2948
2949       rom_start_addr = (h1 << 12) | (h2 << 8) | (h3 << 4) | h4;
2950
2951       argv++;
2952       argc--;
2953     }
2954
2955 #ifdef DEBUG
2956   printf ("Start address = 0x%04x\n", rom_start_addr); // TODO says 0, but should be CODE_START ?
2957 #endif
2958
2959   if (argc != 2)
2960     usage ();
2961
2962   if (!read_hex_file (argv[1]))
2963     printf ("*** Could not read hex file \"%s\"\n", argv[1]);
2964   else
2965     {
2966       int i;
2967
2968       if (rom_get (CODE_START+0) != 0xfb ||
2969           rom_get (CODE_START+1) != 0xd7)
2970         printf ("*** The hex file was not compiled with PICOBIT\n");
2971       else
2972         {
2973 #if 0
2974           for (i=0; i<8192; i++) // TODO remove this ? and not the night address space, now 16 bits
2975             if (rom_get (i) != 0xff)
2976               printf ("rom_mem[0x%04x] = 0x%02x\n", i, rom_get (i));
2977 #endif
2978
2979           interpreter ();
2980
2981 #ifdef DEBUG_GC
2982           printf ("**************** memory needed = %d\n", max_live+1);
2983 #endif
2984         }
2985     }
2986
2987   return errcode;
2988 }
2989
2990 #endif
2991
2992 /*---------------------------------------------------------------------------*/