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