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  */
  10
  11 #define DEBUG_not
  12 #define DEBUG_GC_not
  13
  14 /*---------------------------------------------------------------------------*/
  15
  16 typedef char int8;
  17 typedef short int16;
  18 typedef long int32;
  19 typedef unsigned char uint8;
  20 typedef unsigned short uint16;
  21 typedef unsigned long uint32;
  22
  23 /*---------------------------------------------------------------------------*/
  24
  25
  26 #ifdef __18CXX
  27 #define ROBOT
  28 #endif
  29
  30 #ifdef HI_TECH_C
  31 #define ROBOT
  32 #endif
  33
  34 #ifndef ROBOT
  35 #define WORKSTATION
  36 #endif
  37
  38
  39 #ifdef __18CXX
  40
  41 #include <p18f452.h>
  42
  43 extern volatile near uint8 IR_TX_BUF[2+(8+2)+2];
  44 extern volatile near uint8 FW_EVENTS;
  45 extern volatile near uint8 FW_OPS;
  46 extern volatile near uint8 IR_TX_LENGTH;
  47 extern volatile near uint8 IR_TX_LEDS;
  48 extern volatile near uint8 IR_TX_CURRENT_LEDS;
  49 extern volatile near uint8 IR_TX_POWER;
  50 extern volatile near uint8 IR_TX_CURRENT_POWER;
  51 extern volatile near uint8 IR_TX_SHIFT_REG;
  52 extern volatile near uint8 IR_TX_PTR;
  53 extern volatile near uint8 IR_TX_TIMEOUT;
  54 extern volatile near uint8 IR_TX_WAIT_RANGE;
  55 extern volatile near uint8 IR_TX_RETRY_COUNT;
  56 extern volatile near uint8 IR_TX_CRC_HI;
  57 extern volatile near uint8 IR_TX_CRC_LO;
  58 extern volatile near uint8 IR_TX_HI4;
  59 extern volatile near uint8 IR_TX_LO4;
  60 extern volatile near uint8 INT_IR_STATE_HI;
  61 extern volatile near uint8 INT_IR_STATE_LO;
  62 extern volatile near uint8 INT_PCLATH;
  63 extern volatile near uint8 INT_CODE;
  64 extern volatile near uint8 IR_BIT_CLOCK;
  65 extern volatile near uint8 CLOCK_UP;
  66 extern volatile near uint8 CLOCK_HI;
  67 extern volatile near uint8 CLOCK_LO;
  68 extern volatile near uint8 RANDOM;
  69 extern volatile near uint8 NODE_NUM;
  70 extern volatile near uint8 IR_RX_SOURCE;
  71 extern volatile near uint8 IR_RX_LENGTH;
  72 extern volatile near uint8 IR_RX_BUF[2+(2+8)+2];
  73 extern volatile near uint8 IR_RX_CRC_HI;
  74 extern volatile near uint8 IR_RX_CRC_LO;
  75 extern volatile near uint8 IR_RX_HI4;
  76 extern volatile near uint8 IR_RX_LO4;
  77 extern volatile near uint8 DRIVE_A_MODE;
  78 extern volatile near uint8 DRIVE_A_PWM;
  79 extern volatile near uint8 DRIVE_B_MODE;
  80 extern volatile near uint8 DRIVE_B_PWM;
  81 extern volatile near uint8 DRIVE_C_MODE;
  82 extern volatile near uint8 DRIVE_C_PWM;
  83 extern volatile near uint8 MOTOR_ID;
  84 extern volatile near uint8 FW_VALUE_UP;
  85 extern volatile near uint8 MOTOR_ROT;
  86 extern volatile near uint8 FW_VALUE_HI;
  87 extern volatile near uint8 MOTOR_POW;
  88 extern volatile near uint8 FW_VALUE_LO;
  89 extern volatile near uint8 FW_VALUE_TMP;
  90 extern volatile near uint8 FW_LAST_TX_TIME_LO;
  91 extern volatile near uint8 IR_RX_SAMPLE_TIMER;
  92 extern volatile near uint8 IR_RX_SHIFT_REG;
  93 extern volatile near uint8 IR_RX_PREVIOUS;
  94 extern volatile near uint8 IR_RX_PTR;
  95 extern volatile near uint8 IR_RX_BYTE;
  96 extern volatile near uint8 STDIO_TX_SEQ_NUM;
  97 extern volatile near uint8 STDIO_RX_SEQ_NUM;
  98 extern volatile near uint8 FW_TEMP1;
  99
 100 extern void fw_clock_read (void);
 101 extern void fw_motor (void);
 102 extern void fw_light_read (void);
 103 extern void fw_ir_tx (void);
 104 extern void fw_ir_rx_stdio_char (void);
 105 extern void fw_ir_tx_wait_ready (void);
 106 extern void fw_ir_tx_stdio (void);
 107 extern void program_mode (void);
 108
 109 #endif
 110
 111
 112 #ifdef HI_TECH_C
 113
 114 #include <pic18.h>
 115
 116 static volatile near uint8 FW_VALUE_UP       @ 0x33;
 117 static volatile near uint8 FW_VALUE_HI       @ 0x33;
 118 static volatile near uint8 FW_VALUE_LO       @ 0x33;
 119
 120 #define ACTIVITY_LED1_LAT LATB
 121 #define ACTIVITY_LED1_BIT 5
 122 #define ACTIVITY_LED2_LAT LATB
 123 #define ACTIVITY_LED2_BIT 4
 124 static volatile near bit ACTIVITY_LED1 @ ((unsigned)&ACTIVITY_LED1_LAT*8)+ACTIVITY_LED1_BIT;
 125 static volatile near bit ACTIVITY_LED2 @ ((unsigned)&ACTIVITY_LED2_LAT*8)+ACTIVITY_LED2_BIT;
 126
 127 #endif
 128
 129
 130 #ifdef WORKSTATION
 131
 132 #include <stdio.h>
 133 #include <stdlib.h>
 134
 135 #ifdef _WIN32
 136 #include <sys/types.h>
 137 #include <sys/timeb.h>
 138 #include <conio.h>
 139 #else
 140 #include <sys/time.h>
 141 #endif
 142
 143 #endif
 144
 145
 146 /*---------------------------------------------------------------------------*/
 147
 148 #define WORD_BITS 8
 149
 150 #define CODE_START 0x2000
 151
 152 #define GLOVARS 16
 153
 154 #ifdef DEBUG
 155 #define IF_TRACE(x) x
 156 #define IF_GC_TRACE(x)
 157 #else
 158 #define IF_TRACE(x)
 159 #define IF_GC_TRACE(x)
 160 #endif
 161
 162 /*---------------------------------------------------------------------------*/
 163
 164
 165 #ifdef __18CXX
 166
 167 #define ERROR(msg) program_mode ()
 168 #define TYPE_ERROR(type) program_mode ()
 169
 170 #endif
 171
 172
 173 #ifdef WORKSTATION
 174
 175 #define ERROR(msg) error (msg)
 176 #define TYPE_ERROR(type) type_error (type)
 177
 178 void error (char *msg)
 179 {
 180   printf ("ERROR: %s\n", msg);
 181   exit (1);
 182 }
 183
 184 void type_error (char *type)
 185 {
 186   printf ("ERROR: An argument of type %s was expected\n", type);
 187   exit (1);
 188 }
 189
 190 #endif
 191
 192
 193 /*---------------------------------------------------------------------------*/
 194
 195 #if WORD_BITS <= 8
 196 typedef uint8 word;
 197 #else
 198 typedef uint16 word;
 199 #endif
 200
 201 typedef uint16 ram_addr;
 202 typedef uint16 rom_addr;
 203
 204 typedef uint16 obj;
 205
 206 /*---------------------------------------------------------------------------*/
 207
 208 #define MIN_RAM_ENCODING 128
 209 #define MAX_RAM_ENCODING 8192
 210 // TODO some space in rom is not used, use for fixnums ?
 211 #define RAM_BYTES ((MAX_RAM_ENCODING - MIN_RAM_ENCODING + 1)*4)
 212
 213 // TODO change if we change the proportion of rom and ram addresses
 214 #if WORD_BITS == 8
 215 #define OBJ_TO_RAM_ADDR(o,f) (((ram_addr)((uint16)(o) - MIN_RAM_ENCODING) << 2) + (f))
 216 #define OBJ_TO_ROM_ADDR(o,f) (((rom_addr)((uint8)(o) - MIN_ROM_ENCODING) << 2) + (CODE_START + 4 + (f)))
 217 #endif
 218
 219
 220 #ifdef __18CXX
 221
 222 #define ram_get(a) *(uint8*)(a+0x200)
 223 #define ram_set(a,x) *(uint8*)(a+0x200) = (x)
 224
 225 #endif
 226
 227
 228 #ifdef WORKSTATION
 229
 230 uint8 ram_mem[RAM_BYTES];
 231
 232 #define ram_get(a) ram_mem[a]
 233 #define ram_set(a,x) ram_mem[a] = (x)
 234
 235 #endif
 236
 237
 238 /*---------------------------------------------------------------------------*/
 239
 240 #ifdef __18CXX
 241
 242 #if WORD_BITS == 8
 243 #endif
 244
 245 uint8 rom_get (rom_addr a)
 246 {
 247   return *(rom uint8*)a;
 248 }
 249
 250 #endif
 251
 252
 253 #ifdef WORKSTATION
 254
 255 #define ROM_BYTES 8192
 256
 257 uint8 rom_mem[ROM_BYTES] =
 258   {
 259 #define RED_GREEN
 260 #define PUTCHAR_LIGHT_not
 261
 262 #ifdef RED_GREEN
 263     0xFB, 0xD7, 0x03, 0x00, 0x00, 0x00, 0x00, 0x32
 264     , 0x03, 0x00, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00
 265     , 0x08, 0x50, 0x80, 0x16, 0xFE, 0xE8, 0x00, 0xFC
 266     , 0x32, 0x80, 0x2D, 0xFE, 0xFC, 0x31, 0x80, 0x43
 267     , 0xFE, 0xFC, 0x33, 0x80, 0x2D, 0xFE, 0xFC, 0x31
 268     , 0x80, 0x43, 0xFE, 0x90, 0x16, 0x01, 0x20, 0xFC
 269     , 0x32, 0xE3, 0xB0, 0x37, 0x09, 0xF3, 0xFF, 0x20
 270     , 0xFC, 0x33, 0xE3, 0xB0, 0x40, 0x0A, 0xF3, 0xFF
 271     , 0x08, 0xF3, 0xFF, 0x01, 0x40, 0x21, 0xD1, 0x00
 272     , 0x02, 0xC0, 0x4C, 0x71, 0x01, 0x20, 0x50, 0x90
 273     , 0x51, 0x00, 0xF1, 0x40, 0xD8, 0xB0, 0x59, 0x90
 274     , 0x51, 0x00, 0xFF
 275 #endif
 276 #ifdef PUTCHAR_LIGHT
 277     0xFB, 0xD7, 0x00, 0x00, 0x80, 0x08, 0xFE, 0xE8
 278     , 0x00, 0xF6, 0xF5, 0x90, 0x08
 279 #endif
 280   };
 281
 282 uint8 rom_get (rom_addr a)
 283 {
 284   return rom_mem[a-CODE_START];
 285 }
 286
 287 #endif
 288
 289 obj globals[GLOVARS];
 290
 291 /*---------------------------------------------------------------------------*/
 292
 293 /*
 294   OBJECT ENCODING:
 295
 296   #f           0
 297   #t           1
 298   ()           2
 299   fixnum n     MIN_FIXNUM -> 3 ... MAX_FIXNUM -> 3 + (MAX_FIXNUM-MIN_FIXNUM)
 300   TODO do we want 0..127 as fixnums ? would reduce number of ra/om objects
 301   rom object   4 + (MAX_FIXNUM-MIN_FIXNUM) ... MIN_RAM_ENCODING-1
 302   ram object   MIN_RAM_ENCODING ... 4095 TODO was 255, now we have 12 bits
 303
 304   layout of memory allocated objects:
 305
 306   G's represent mark bits used by the gc TODO change GC, and does not use the same bits
 307
 308   bignum n     00G00000 uuuuuuuu hhhhhhhh llllllll  (24 bit signed integer)
 309   TODO we could have 29-bit integers
 310
 311   pair         1GGaaaaa aaaaaaaa 000ddddd dddddddd
 312   TODO was 00000010 aaaaaaaa aaaadddd dddddddd
 313   a is car
 314   d is cdr
 315   gives an address space of 2^13 * 4 = 32k (not all of it is for RAM, though)
 316
 317   symbol       1GG00000 00000000 00100000 00000000  TODO not used ? seems symbols are not even really supported, but the led user functions do use them, strange
 318
 319   string       1GG***** *chars** 01000000 00000000
 320
 321   vector       1GG***** *elems** 01100000 00000000  TODO not used yet
 322
 323   closure      01Gxxxxx xxxxxxxx aaaaaaaa aaaaaaaa
 324   0x5ff<a<0x4000 is entry TODO we now have more 16 bits for the entry, 16 whole, how to use it ?
 325   x is pointer to environment
 326
 327   continuation 01Gxxxxx xxxxxxxx aaaaaaaa aaaaaaaa  0x5ff<a<0x4000 is pc
 328   TODO actually, 16 bits for the code
 329   x is pointer to the second half
 330   TODO ok, ugly hack, closures are in only one object, but continuations (since they seem to only be created by the runtime) are stored in 2, the compiler doesn't need to be changed much, not for closures at least, we'll just have to see if the similar representation is used somewhere in the vm
 331
 332   second half  1GGxxxxx xxxxxxxx 000yyyyy yyyyyyyy
 333   of continuations, actually a simple pair
 334   x is environment
 335   y is parent continuation
 336
 337   An environment is a list of objects built out of pairs.  On entry to
 338   a procedure the environment is the list of parameters to which is
 339   added the environment of the closure being called.
 340
 341   The first byte at the entry point of a procedure gives the arity of
 342   the procedure:
 343
 344   n = 0 to 127    -> procedure has n parameters (no rest parameter)
 345   n = -128 to -1  -> procedure has -n parameters, the last is
 346   a rest parameter
 347 */
 348
 349 #define OBJ_FALSE 0
 350 #define OBJ_TRUE  1
 351 #define OBJ_NULL  2
 352
 353 #define MIN_FIXNUM_ENCODING 3
 354 #define MIN_FIXNUM (-5)
 355 #define MAX_FIXNUM 40
 356 #define MIN_ROM_ENCODING (MIN_FIXNUM_ENCODING+MAX_FIXNUM-MIN_FIXNUM+1)
 357
 358 #define ENCODE_FIXNUM(n) ((obj)(n) + (MIN_FIXNUM_ENCODING - MIN_FIXNUM))
 359 #define DECODE_FIXNUM(o) ((int32)(o) - (MIN_FIXNUM_ENCODING - MIN_FIXNUM))
 360
 361 #if WORD_BITS == 8
 362 #define IN_RAM(o) ((o) >= MIN_RAM_ENCODING)
 363 #define IN_ROM(o) ((int8)(o) >= MIN_ROM_ENCODING)
 364 #endif
 365
 366 // bignum first byte : 00G00000
 367 #define BIGNUM_FIELD0 0
 368 #define RAM_BIGNUM(o) ((ram_get_field0 (o) & 0xc0) == BIGNUM_FIELD0)
 369 #define ROM_BIGNUM(o) ((rom_get_field0 (o) & 0xc0) == BIGNUM_FIELD0)
 370
 371 // composite first byte : 1GGxxxxx
 372 #define COMPOSITE_FIELD0 0x80
 373 #define RAM_COMPOSITE(o) ((ram_get_field0 (o) & 0x80) == COMPOSITE_FIELD0)
 374 #define ROM_COMPOSITE(o) ((rom_get_field0 (o) & 0x80) == COMPOSITE_FIELD0)
 375
 376 // pair third byte : 000xxxxx
 377 #define PAIR_FIELD2 0
 378 #define RAM_PAIR(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == PAIR_FIELD2))
 379 #define ROM_PAIR(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == PAIR_FIELD2))
 380
 381 // symbol third byte : 001xxxxx
 382 #define SYMBOL_FIELD2 0x20
 383 #define RAM_SYMBOL(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == SYMBOL_FIELD2))
 384 #define ROM_SYMBOL(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == SYMBOL_FIELD2))
 385
 386 // string third byte : 010xxxxx
 387 #define STRING_FIELD2 0x40
 388 #define RAM_STRING(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == STRING_FIELD2))
 389 #define ROM_STRING(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == STRING_FIELD2))
 390
 391 // vector third byte : 011xxxxx
 392 #define VECTOR_FIELD2 0x60
 393 #define RAM_VECTOR(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == VECTOR_FIELD2))
 394 #define ROM_VECTOR(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == VECTOR_FIELD2))
 395
 396 // procedure / continuation first byte : 01Gxxxxx
 397 #define PROCEDURE_FIELD0 0x40
 398 #define RAM_PROCEDURE(o) ((ram_get_field0 (o) & 0xc0) == PROCEDURE_FIELD0)
 399 #define ROM_PROCEDURE(o) ((rom_get_field0 (o) & 0xc0) == PROCEDURE_FIELD0)
 400
 401 /*---------------------------------------------------------------------------*/
 402
 403 #define RAM_GET_FIELD0_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,0))
 404 #define RAM_SET_FIELD0_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,0), val)
 405 #define ROM_GET_FIELD0_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,0))
 406
 407 // TODO changed, now gc bits are 0x60, were 0xc0, but the 1st is not always used
 408 #define RAM_GET_GC_TAGS_MACRO(o) (RAM_GET_FIELD0_MACRO(o) & 0x60)
 409 #define RAM_SET_GC_TAGS_MACRO(o,tags)                                      \
 410   (RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0x9f) | (tags)))
 411 #define RAM_SET_GC_TAG0_MACRO(o,tag)                                    \
 412   RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xdf) | (tag))
 413 #define RAM_SET_GC_TAG1_MACRO(o,tag)                                    \
 414   RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xbf) | (tag))
 415 // TODO we can't set them both at once now, since some objects only have 1
 416 // FOOBAR, maybe we can
 417
 418 #if WORD_BITS == 8
 419 #define RAM_GET_FIELD1_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,1))
 420 #define RAM_GET_FIELD2_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,2))
 421 #define RAM_GET_FIELD3_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,3))
 422 #define RAM_SET_FIELD1_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,1), val)
 423 #define RAM_SET_FIELD2_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,2), val)
 424 #define RAM_SET_FIELD3_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,3), val)
 425 #define ROM_GET_FIELD1_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,1))
 426 #define ROM_GET_FIELD2_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,2))
 427 #define ROM_GET_FIELD3_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,3))
 428 #endif
 429
 430 // TODO this might be of use, but doesn't look like it is for now
 431 #if WORD_BITS == 10
 432 #define RAM_GET_FIELD1_MACRO(o)                                         \
 433   (ram_get (OBJ_TO_RAM_ADDR(o,1)) + ((RAM_GET_FIELD0_MACRO(o) & 0x03)<<8))
 434 #define RAM_GET_FIELD2_MACRO(o)                                         \
 435   (ram_get (OBJ_TO_RAM_ADDR(o,2)) + ((RAM_GET_FIELD0_MACRO(o) & 0x0c)<<6))
 436 #define RAM_GET_FIELD3_MACRO(o)                                         \
 437   (ram_get (OBJ_TO_RAM_ADDR(o,3)) + ((RAM_GET_FIELD0_MACRO(o) & 0x30)<<4))
 438 #define RAM_SET_FIELD1_MACRO(o,val)                                     \
 439   do {                                                                  \
 440     ram_set (OBJ_TO_RAM_ADDR(o,1), (val) & 0xff);                       \
 441     RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xfc) + (((val) >> 8) & 0x03)); \
 442   } while (0)
 443 #define RAM_SET_FIELD2_MACRO(o,val)                                     \
 444   do {                                                                  \
 445     ram_set (OBJ_TO_RAM_ADDR(o,2), (val) & 0xff);                       \
 446     RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xf3) + (((val) >> 6) & 0x0c)); \
 447   } while (0)
 448 #define RAM_SET_FIELD3_MACRO(o,val)                                     \
 449   do {                                                                  \
 450     ram_set (OBJ_TO_RAM_ADDR(o,3), (val) & 0xff);                       \
 451     RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xcf) + (((val) >> 4) & 0x30)); \
 452   } while (0)
 453 #define ROM_GET_FIELD1_MACRO(o)                                         \
 454   (rom_get (OBJ_TO_ROM_ADDR(o,1)) + ((ROM_GET_FIELD0_MACRO(o) & 0x03)<<8))
 455 #define ROM_GET_FIELD2_MACRO(o)                                         \
 456   (rom_get (OBJ_TO_ROM_ADDR(o,2)) + ((ROM_GET_FIELD0_MACRO(o) & 0x0c)<<6))
 457 #define ROM_GET_FIELD3_MACRO(o)                                         \
 458   (rom_get (OBJ_TO_ROM_ADDR(o,3)) + ((ROM_GET_FIELD0_MACRO(o) & 0x30)<<4))
 459 #endif
 460
 461 uint8 ram_get_gc_tags (obj o) { return RAM_GET_GC_TAGS_MACRO(o); }
 462 void ram_set_gc_tags  (obj o, uint8 tags) { RAM_SET_GC_TAGS_MACRO(o, tags); }
 463 void ram_set_gc_tag0 (obj o, uint8 tag) { RAM_SET_GC_TAG0_MACRO(o,tag); }
 464 void ram_set_gc_tag1 (obj o, uint8 tag) { RAM_SET_GC_TAG1_MACRO(o,tag); }
 465 // TODO we can't set them both at once anymore, some object only use 1
 466 // FOOBAR actually, we might be able to, if we don't ever set or unset something used for the type
 467 uint8 ram_get_field0 (obj o) { return RAM_GET_FIELD0_MACRO(o); }
 468 word ram_get_field1 (obj o) { return RAM_GET_FIELD1_MACRO(o); } // TODO used to return obj, which used to be the same as words
 469 word ram_get_field2 (obj o) { return RAM_GET_FIELD2_MACRO(o); }
 470 word ram_get_field3 (obj o) { return RAM_GET_FIELD3_MACRO(o); }
 471 void ram_set_field0 (obj o, uint8 val) { RAM_SET_FIELD0_MACRO(o,val); }
 472 void ram_set_field1 (obj o, word val) { RAM_SET_FIELD1_MACRO(o,val); }
 473 void ram_set_field2 (obj o, word val) { RAM_SET_FIELD2_MACRO(o,val); }
 474 void ram_set_field3 (obj o, word val) { RAM_SET_FIELD3_MACRO(o,val); }
 475 uint8 rom_get_field0 (obj o) { return ROM_GET_FIELD0_MACRO(o); }
 476 word rom_get_field1 (obj o) { return ROM_GET_FIELD1_MACRO(o); }
 477 word rom_get_field2 (obj o) { return ROM_GET_FIELD2_MACRO(o); }
 478 word rom_get_field3 (obj o) { return ROM_GET_FIELD3_MACRO(o); }
 479
 480 obj ram_get_car (obj o)
 481 { return ((ram_get_field0 (o) & 0x1f) << 8) | ram_get_field1 (o); }
 482 obj rom_get_car (obj o)
 483 { return ((rom_get_field0 (o) & 0x1f) << 8) | rom_get_field1 (o); }
 484 obj ram_get_cdr (obj o)
 485 { return ((ram_get_field2 (o) & 0x1f) << 8) | ram_get_field3 (o); }
 486 obj rom_get_cdr (obj o)
 487 { return ((rom_get_field2 (o) & 0x1f) << 8) | rom_get_field3 (o); }
 488 void ram_set_car (obj o, obj val)
 489 {
 490   ram_set_field0 (o, ((val & 0x1f00) >> 8) | (ram_get_field0 (o) & 0xc0));
 491   ram_set_field1 (o, val & 0xff);
 492 }
 493 void ram_set_cdr (obj o, obj val)
 494 {
 495   ram_set_field2 (o, ((val & 0x1f00) >> 8) | (ram_get_field2 (o) & 0xc0));
 496   ram_set_field3 (o, val & 0xff);
 497 }
 498
 499 obj get_global (uint8 i) // TODO 8 ? do we want more than 256 globals ?
 500 {
 501   return globals[i];
 502 }
 503
 504 void set_global (uint8 i, obj o)
 505 {
 506   globals[i] = o;
 507 }
 508
 509 /*---------------------------------------------------------------------------*/
 510
 511 /* Interface to GC */
 512
 513 /* GC tags are in the top 2 bits of field 0 */
 514 // TODO change GC with new representation FOOBAR
 515 #define GC_TAG_0_LEFT   (1<<5)
 516 // TODO was 3<<5, changed to play nice with procedures and bignums, but should actually set only this bit, not clear the other
 517 #define GC_TAG_1_LEFT   (2<<5)
 518 #define GC_TAG_UNMARKED (0<<5)  /* must be 0 */ // TODO FOOBAR is it ok ? eevn for bignums ?
 519
 520 /* Number of object fields of objects in ram */
 521 #define HAS_2_OBJECT_FIELDS(visit) (RAM_PAIR(visit))
 522 #define HAS_1_OBJECT_FIELD(visit)  (RAM_COMPOSITE(visit) || RAM_PROCEDURE(visit))
 523 // TODO now we consider that all composites have at least 1 field, even symbols, as do procedures. no problem for symbols, since the car is always #f
 524 // TODO was : (RAM_STRING(visit) || RAM_VECTOR(visit) || RAM_PROCEDURE(visit))
 525 // TODO no real way to tell using simple inequality
 526 // TODO if we ever have true bignums, bignums will have 1 object field
 527
 528 #define NIL OBJ_FALSE
 529
 530 /*---------------------------------------------------------------------------*/
 531
 532 /* Garbage collector */
 533
 534 obj free_list; /* list of unused cells */
 535
 536 obj arg1; /* root set */
 537 obj arg2;
 538 obj arg3;
 539 obj arg4;
 540 obj cont;
 541 obj env;
 542
 543 uint8 na; /* interpreter variables */ // TODO what's na ?
 544 rom_addr pc;
 545 rom_addr entry;
 546 uint8 bytecode;
 547 uint8 bytecode_hi4;
 548 uint8 bytecode_lo4;
 549 obj second_half; /* the second half of continuations */
 550 int32 a1;
 551 int32 a2;
 552 int32 a3;
 553
 554 void init_ram_heap (void)
 555 {
 556   uint8 i;
 557   obj o = MAX_RAM_ENCODING;
 558
 559   free_list = 0;
 560
 561   while (o >= MIN_RAM_ENCODING)
 562     {
 563       ram_set_gc_tags (o, GC_TAG_UNMARKED);
 564       ram_set_car (o, free_list); // TODO was field1
 565       free_list = o;
 566       o--;
 567     }
 568
 569   for (i=0; i<GLOVARS; i++)
 570     set_global (i, OBJ_FALSE);
 571
 572   arg1 = OBJ_FALSE;
 573   arg2 = OBJ_FALSE;
 574   arg3 = OBJ_FALSE;
 575   arg4 = OBJ_FALSE;
 576   cont = OBJ_FALSE;
 577   env  = OBJ_NULL;
 578   second_half = OBJ_FALSE;
 579 }
 580
 581 void mark (obj temp)
 582 {
 583   /* mark phase */
 584
 585   obj stack; // TODO do we need a stack ? since we have 0-1-2 children, we could do deutsche schorr waite
 586   obj visit;
 587
 588   if (IN_RAM(temp))
 589     {
 590       visit = NIL;
 591
 592     push:
 593
 594       stack = visit;
 595       visit = temp;
 596
 597       IF_GC_TRACE(printf ("push   stack=%d (tag=%d)  visit=%d (tag=%d)\n", stack, ram_get_gc_tags (stack)>>6, visit, ram_get_gc_tags (visit)>>6));
 598
 599       /*
 600        * Four cases are possible:
 601        *
 602        * A)
 603        *                          stack  visit tag F1  F2  F3
 604        *                           NIL    |   +---+---+---+---+
 605        *                                  +-> | ? |   |   |   |
 606        *                                      +---+---+---+---+
 607        *
 608        * B)
 609        *          tag F1  F2  F3  stack  visit tag F1  F2  F3
 610        *         +---+---+---+---+   |    |   +---+---+---+---+
 611        *         | 1 |   |   |   | <-+    +-> | ? |   |   |   |
 612        *         +---+---+---+-|-+            +---+---+---+---+
 613        *     <-----------------+
 614        *
 615        * C)
 616        *          tag F1  F2  F3  stack  visit tag F1  F2  F3
 617        *         +---+---+---+---+   |    |   +---+---+---+---+
 618        *         | 2 |   |   |   | <-+    +-> | ? |   |   |   |
 619        *         +---+---+-|-+---+            +---+---+---+---+
 620        *     <-------------+
 621        *
 622        * D)
 623        *          tag F1  F2  F3  stack  visit tag F1  F2  F3
 624        *         +---+---+---+---+   |    |   +---+---+---+---+
 625        *         | 3 |   |   |   | <-+    +-> | ? |   |   |   |
 626        *         +---+-|-+---+---+            +---+---+---+---+
 627        *     <---------+
 628        */
 629       // TODO since no-one has 3 fields anymore, not really 4 cases ?
 630
 631       //      if (ram_get_gc_tags (visit) != GC_TAG_UNMARKED) // TODO always matches procedures, WRONG, maybe check only the right gc bit ?/
 632       if (ram_get_gc_tags (visit) & 0x2f) // TODO we check only the last gc bit
 633         IF_GC_TRACE(printf ("case 1\n")); // TODO are there cases where checking only the last gc bit is wrong ?
 634       // TODO FOOBAR ok, with our new way, what do we check here ?
 635       else
 636         {
 637           if (HAS_2_OBJECT_FIELDS(visit))
 638             {
 639               IF_GC_TRACE(printf ("case 5\n"));
 640               // TODO we don't have cases 2-4 anymore
 641
 642             visit_field2:
 643
 644               temp = ram_get_cdr (visit);
 645
 646               if (IN_RAM(temp))
 647                 {
 648                   IF_GC_TRACE(printf ("case 6\n"));
 649                   ram_set_gc_tags (visit, GC_TAG_1_LEFT);
 650                   ram_set_cdr (visit, stack);
 651                   goto push;
 652                 }
 653
 654               IF_GC_TRACE(printf ("case 7\n"));
 655
 656               goto visit_field1;
 657             }
 658
 659           if (HAS_1_OBJECT_FIELD(visit))
 660             {
 661               IF_GC_TRACE(printf ("case 8\n"));
 662
 663             visit_field1:
 664
 665               temp = ram_get_car (visit);
 666
 667               if (IN_RAM(temp))
 668                 {
 669                   IF_GC_TRACE(printf ("case 9\n"));
 670                   ram_set_gc_tag0 (visit, GC_TAG_0_LEFT); // TODO changed, now we only set the bit 0, we don't change the bit 1, since some objets have only 1 mark bit
 671                   ram_set_car (visit, stack);
 672                   goto push;
 673                 }
 674
 675               IF_GC_TRACE(printf ("case 10\n"));
 676             }
 677           else
 678             IF_GC_TRACE(printf ("case 11\n"));
 679
 680           ram_set_gc_tag0 (visit, GC_TAG_0_LEFT); // TODO changed, same as above
 681         }
 682
 683     pop:
 684
 685       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));
 686
 687       if (stack != NIL)
 688         {
 689           if (ram_get_gc_tags (stack) == GC_TAG_1_LEFT) // TODO FOOBAR, this is always true for procedures that have not been marked, can such an object get here ? probably not, since when a procedure is popped, it has already been visited, so will be at 0 left
 690             {
 691               IF_GC_TRACE(printf ("case 13\n"));
 692
 693               temp = ram_get_cdr (stack);  /* pop through field 2 */
 694               ram_set_cdr (stack, visit);
 695               visit = stack;
 696               stack = temp;
 697
 698               goto visit_field1;
 699             }
 700
 701           IF_GC_TRACE(printf ("case 14\n"));
 702
 703           temp = ram_get_car (stack);  /* pop through field 1 */
 704           ram_set_car (stack, visit);
 705           visit = stack;
 706           stack = temp;
 707
 708           goto pop;
 709         }
 710     }
 711 }
 712
 713 #ifdef DEBUG_GC
 714 int max_live = 0;
 715 #endif
 716
 717 void sweep (void)
 718 {
 719   /* sweep phase */
 720
 721 #ifdef DEBUG_GC
 722   int n = 0;
 723 #endif
 724
 725   obj visit = MAX_RAM_ENCODING;
 726
 727   free_list = 0;
 728
 729   while (visit >= MIN_RAM_ENCODING)
 730     {
 731       if ((RAM_COMPOSITE(visit) && (ram_get_gc_tags (visit) == GC_TAG_UNMARKED)) || (ram_get_gc_tags (visit) & GC_TAG_0_LEFT)) /* unmarked? */
 732         // TODO now we check only 1 bit if the object has only 1 mark bit
 733         {
 734           ram_set_car (visit, free_list); // TODO was field1
 735           free_list = visit;
 736         }
 737       else
 738         {
 739           if (RAM_COMPOSITE(visit))
 740             ram_set_gc_tags (visit, GC_TAG_UNMARKED);
 741           else // only 1 mark bit to unset
 742             ram_set_gc_tag0 (visit, GC_TAG_UNMARKED);
 743 #ifdef DEBUG_GC
 744           n++;
 745 #endif
 746         }
 747       visit--;
 748     }
 749
 750 #ifdef DEBUG_GC
 751   if (n > max_live)
 752     {
 753       max_live = n;
 754       printf ("**************** memory needed = %d\n", max_live+1);
 755       fflush (stdout);
 756     }
 757 #endif
 758 }
 759
 760 void gc (void)
 761 {
 762   uint8 i;
 763
 764   mark (arg1);
 765   mark (arg2);
 766   mark (arg3);
 767   mark (arg4);
 768   mark (cont);
 769   mark (env);
 770
 771   for (i=0; i<GLOVARS; i++)
 772     mark (get_global (i));
 773
 774   sweep ();
 775 }
 776
 777 obj alloc_ram_cell (void)
 778 {
 779   obj o;
 780
 781 #ifdef DEBUG_GC
 782   gc ();
 783 #endif
 784
 785   if (free_list == 0)
 786     {
 787 #ifndef DEBUG_GC
 788       gc ();
 789       if (free_list == 0)
 790 #endif
 791         ERROR("memory is full");
 792     }
 793
 794   o = free_list;
 795
 796   free_list = ram_get_field1 (o);
 797
 798   return o;
 799 }
 800
 801 obj alloc_ram_cell_init (uint8 f0, uint8 f1, uint8 f2, uint8 f3)
 802 {
 803   obj o = alloc_ram_cell ();
 804
 805   ram_set_field0 (o, f0);
 806   ram_set_field1 (o, f1);
 807   ram_set_field2 (o, f2);
 808   ram_set_field3 (o, f3);
 809
 810   return o;
 811 }
 812
 813 /*---------------------------------------------------------------------------*/
 814
 815 int32 decode_int (obj o)
 816 {
 817   uint8 u;
 818   uint8 h;
 819   uint8 l;
 820
 821   if (o < MIN_FIXNUM_ENCODING)
 822     TYPE_ERROR("integer");
 823
 824   if (o <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM)))
 825     return DECODE_FIXNUM(o);
 826
 827   if (IN_RAM(o))
 828     {
 829       if (!RAM_BIGNUM(o))
 830         TYPE_ERROR("integer");
 831
 832       u = ram_get_field1 (o);
 833       h = ram_get_field2 (o);
 834       l = ram_get_field3 (o);
 835     }
 836   else if (IN_ROM(o))
 837     {
 838       if (!ROM_BIGNUM(o))
 839         TYPE_ERROR("integer");
 840
 841       u = rom_get_field1 (o);
 842       h = rom_get_field2 (o);
 843       l = rom_get_field3 (o);
 844     }
 845   else
 846     TYPE_ERROR("integer");
 847
 848   if (u >= 128)
 849     return ((int32)((((int16)u - 256) << 8) + h) << 8) + l;
 850
 851   return ((int32)(((int16)u << 8) + h) << 8) + l;
 852 }
 853
 854 obj encode_int (int32 n)
 855 {
 856   if (n >= MIN_FIXNUM && n <= MAX_FIXNUM)
 857     return ENCODE_FIXNUM(n);
 858
 859   return alloc_ram_cell_init (BIGNUM_FIELD0, n >> 16, n >> 8, n);
 860 }
 861
 862 /*---------------------------------------------------------------------------*/
 863
 864 #ifdef WORKSTATION
 865
 866 void show (obj o)
 867 {
 868 #if 0
 869   printf ("[%d]", o);
 870 #endif
 871
 872   if (o == OBJ_FALSE)
 873     printf ("#f");
 874   else if (o == OBJ_TRUE)
 875     printf ("#t");
 876   else if (o == OBJ_NULL)
 877     printf ("()");
 878   else if (o <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM)))
 879     printf ("%d", DECODE_FIXNUM(o));
 880   else
 881     {
 882       uint8 in_ram;
 883
 884       if (IN_RAM(o))
 885         in_ram = 1;
 886       else
 887         in_ram = 0;
 888
 889       if ((in_ram && RAM_BIGNUM(o)) || ROM_BIGNUM(o))
 890         printf ("%d", decode_int (o));
 891       else if ((in_ram && RAM_COMPOSITE(o)) || ROM_COMPOSITE(o))
 892         {
 893           obj car;
 894           obj cdr;
 895
 896           if (in_ram && RAM_PAIR(o))
 897             {
 898               car = ram_get_car (o);
 899               cdr = ram_get_cdr (o);
 900               printf ("(");
 901
 902             loop_ram:
 903               show (car);
 904
 905               if (cdr == OBJ_NULL)
 906                 printf (")");
 907               else if (RAM_PAIR(ram_get_field0 (cdr)))
 908                 {
 909                   car = ram_get_car (cdr);
 910                   cdr = ram_get_cdr (cdr);
 911
 912                   printf (" ");
 913                   goto loop_ram;
 914                 }
 915               else
 916                 {
 917                   printf (" . ");
 918                   show (cdr);
 919                   printf (")");
 920                 }
 921             }
 922           else if (ROM_PAIR(o))
 923             {
 924               car = rom_get_car (o);
 925               cdr = rom_get_cdr (o);
 926               printf ("(");
 927             loop_rom:
 928               show (car);
 929
 930               if (cdr == OBJ_NULL)
 931                 printf (")");
 932               else if (ROM_PAIR(rom_get_field0 (cdr)))
 933                 {
 934                   car = rom_get_car (cdr);
 935                   cdr = rom_get_cdr (cdr);
 936
 937                   printf (" ");
 938                   goto loop_rom;
 939                 }
 940               else // TODO lots of repetition
 941                 {
 942                   printf (" . ");
 943                   show (cdr);
 944                   printf (")");
 945                 }
 946             }
 947           else if ((in_ram && RAM_SYMBOL(o)) || ROM_SYMBOL(o))
 948             printf ("#<symbol>");
 949           else if ((in_ram && RAM_STRING(o)) || ROM_STRING(o))
 950             printf ("#<string>");
 951           else if ((in_ram && RAM_VECTOR(o)) || ROM_VECTOR(o))
 952             printf ("#<vector>");
 953         }
 954       else
 955         {
 956           /* obj env; */
 957           /* obj parent_cont; */
 958           /* rom_addr pc; */
 959
 960           /* if (IN_RAM(o)) */
 961           /*   env = ram_get_field1 (o); */
 962           /* else */
 963           /*   env = rom_get_field1 (o); */
 964
 965           /* if (IN_RAM(o)) */
 966           /*   parent_cont = ram_get_field2 (o); */
 967           /* else */
 968           /*   parent_cont = rom_get_field2 (o); */
 969
 970           /* if (IN_RAM(o)) */
 971           /*   pc = ((rom_addr)(field0 + ((CODE_START>>8) - PROCEDURE_FIELD0)) << 8) + ram_get_field3 (o); */
 972           /* else */
 973           /*   pc = ((rom_addr)(field0 + ((CODE_START>>8) - PROCEDURE_FIELD0)) << 8) + rom_get_field3 (o); */
 974
 975           /* printf ("{0x%04x ", pc); */
 976           /* show (env); */
 977           /* printf (" "); */
 978           /* show (parent_cont); */
 979           /* printf ("}"); */ // TODO the representation of procedures changed
 980           printf ("#<procedure>");
 981         }
 982     }
 983
 984   fflush (stdout);
 985 }
 986
 987 void show_state (rom_addr pc)
 988 {
 989   printf ("pc=0x%04x bytecode=0x%02x env=", pc, rom_get (pc));
 990   show (env);
 991   printf (" cont=");
 992   show (cont);
 993   printf ("\n");
 994   fflush (stdout);
 995 }
 996
 997 void print (obj o)
 998 {
 999   show (o);
1000   printf ("\n");
1001   fflush (stdout);
1002 }
1003
1004 #endif
1005
1006 /*---------------------------------------------------------------------------*/
1007
1008 /* Integer operations */
1009
1010 #define encode_bool(x) ((obj)(x))
1011
1012 void prim_numberp (void)
1013 {
1014   if (arg1 >= MIN_FIXNUM_ENCODING
1015       && arg1 <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM)))
1016     arg1 = OBJ_TRUE;
1017   else
1018     {
1019       if (IN_RAM(arg1))
1020         arg1 = encode_bool (RAM_BIGNUM(arg1));
1021       else if (IN_ROM(arg1))
1022         arg1 = encode_bool (ROM_BIGNUM(arg1));
1023       else
1024         arg1 = OBJ_FALSE;
1025     }
1026 }
1027
1028 void decode_2_int_args (void)
1029 {
1030   a1 = decode_int (arg1);
1031   a2 = decode_int (arg2);
1032 }
1033
1034 void prim_add (void)
1035 {
1036   decode_2_int_args ();
1037   arg1 = encode_int (a1 + a2);
1038   arg2 = OBJ_FALSE;
1039 }
1040
1041 void prim_sub (void)
1042 {
1043   decode_2_int_args ();
1044   arg1 = encode_int (a1 - a2);
1045   arg2 = OBJ_FALSE;
1046 }
1047
1048 void prim_mul (void)
1049 {
1050   decode_2_int_args ();
1051   arg1 = encode_int (a1 * a2);
1052   arg2 = OBJ_FALSE;
1053 }
1054
1055 void prim_div (void)
1056 {
1057   decode_2_int_args ();
1058   if (a2 == 0)
1059     ERROR("divide by 0");
1060   arg1 = encode_int (a1 / a2);
1061   arg2 = OBJ_FALSE;
1062 }
1063
1064 void prim_rem (void)
1065 {
1066   decode_2_int_args ();
1067   if (a2 == 0)
1068     ERROR("divide by 0");
1069   arg1 = encode_int (a1 % a2);
1070   arg2 = OBJ_FALSE;
1071 }
1072
1073 void prim_neg (void)
1074 {
1075   a1 = decode_int (arg1);
1076   arg1 = encode_int (- a1);
1077 }
1078
1079 void prim_eq (void)
1080 {
1081   decode_2_int_args ();
1082   arg1 = encode_bool (a1 == a2);
1083   arg2 = OBJ_FALSE;
1084 }
1085
1086 void prim_lt (void)
1087 {
1088   decode_2_int_args ();
1089   arg1 = encode_bool (a1 < a2);
1090   arg2 = OBJ_FALSE;
1091 }
1092
1093 void prim_gt (void)
1094 {
1095   decode_2_int_args ();
1096   arg1 = encode_bool (a1 > a2);
1097   arg2 = OBJ_FALSE;
1098 }
1099
1100 /*---------------------------------------------------------------------------*/
1101
1102 /* List operations */
1103
1104 void prim_pairp (void)
1105 {
1106   if (IN_RAM(arg1))
1107     arg1 = encode_bool (RAM_PAIR(arg1));
1108   else if (IN_ROM(arg1))
1109     arg1 = encode_bool (ROM_PAIR(arg1));
1110   else
1111     arg1 = OBJ_FALSE;
1112 }
1113
1114 obj cons (obj car, obj cdr)
1115 {
1116   return alloc_ram_cell_init (COMPOSITE_FIELD0 | ((car & 0x1f00) >> 8),
1117                               car & 0xff,
1118                               PAIR_FIELD2 | ((cdr & 0x1f00) >> 8),
1119                               cdr & 0xff);
1120 }
1121
1122 void prim_cons (void)
1123 {
1124   arg1 = cons (arg1, arg2);
1125   arg2 = OBJ_FALSE;
1126 }
1127
1128 void prim_car (void)
1129 {
1130   if (IN_RAM(arg1))
1131     {
1132       if (!RAM_PAIR(arg1))
1133         TYPE_ERROR("pair");
1134       arg1 = ram_get_car (arg1);
1135     }
1136   else if (IN_ROM(arg1))
1137     {
1138       if (!ROM_PAIR(arg1))
1139         TYPE_ERROR("pair");
1140       arg1 = rom_get_car (arg1);
1141     }
1142   else
1143     TYPE_ERROR("pair");
1144 }
1145
1146 void prim_cdr (void)
1147 {
1148   if (IN_RAM(arg1))
1149     {
1150       if (!RAM_PAIR(arg1))
1151         TYPE_ERROR("pair");
1152       arg1 = ram_get_cdr (arg1);
1153     }
1154   else if (IN_ROM(arg1))
1155     {
1156       if (!ROM_PAIR(arg1))
1157         TYPE_ERROR("pair");
1158       arg1 = rom_get_cdr (arg1);
1159     }
1160   else
1161     TYPE_ERROR("pair");
1162 }
1163
1164 void prim_set_car (void)
1165 {
1166   if (IN_RAM(arg1))
1167     {
1168       if (!RAM_PAIR(arg1))
1169         TYPE_ERROR("pair");
1170
1171       ram_set_car (arg1, arg2);
1172       arg1 = OBJ_FALSE;
1173       arg2 = OBJ_FALSE;
1174     }
1175   else
1176     TYPE_ERROR("pair");
1177 }
1178
1179 void prim_set_cdr (void)
1180 {
1181   if (IN_RAM(arg1))
1182     {
1183       if (!RAM_PAIR(arg1))
1184         TYPE_ERROR("pair");
1185
1186       ram_set_cdr (arg1, arg2);
1187       arg1 = OBJ_FALSE;
1188       arg2 = OBJ_FALSE;
1189     }
1190   else
1191     TYPE_ERROR("pair");
1192 }
1193
1194 void prim_nullp (void)
1195 {
1196   arg1 = encode_bool (arg1 == OBJ_NULL);
1197 }
1198
1199 /*---------------------------------------------------------------------------*/
1200
1201 /* Miscellaneous operations */
1202
1203 void prim_eqp (void)
1204 {
1205   arg1 = encode_bool (arg1 == arg2);
1206   arg2 = OBJ_FALSE;
1207 }
1208
1209 void prim_not (void)
1210 {
1211   arg1 = encode_bool (arg1 == OBJ_FALSE);
1212 }
1213
1214 void prim_symbolp (void)
1215 {
1216   if (IN_RAM(arg1))
1217     arg1 = encode_bool (RAM_SYMBOL(arg1));
1218   else if (IN_ROM(arg1))
1219     arg1 = encode_bool (ROM_SYMBOL(arg1));
1220   else
1221     arg1 = OBJ_FALSE;
1222 }
1223
1224 void prim_stringp (void)
1225 {
1226   if (IN_RAM(arg1))
1227     arg1 = encode_bool (RAM_STRING(arg1));
1228   else if (IN_ROM(arg1))
1229     arg1 = encode_bool (ROM_STRING(arg1));
1230   else
1231     arg1 = OBJ_FALSE;
1232 }
1233
1234 void prim_string2list (void)
1235 {
1236   if (IN_RAM(arg1))
1237     {
1238       if (!RAM_STRING(arg1))
1239         TYPE_ERROR("string");
1240
1241       arg1 = ram_get_car (arg1);
1242     }
1243   else if (IN_ROM(arg1))
1244     {
1245       if (!ROM_STRING(arg1))
1246         TYPE_ERROR("string");
1247
1248       arg1 = rom_get_car (arg1);
1249     }
1250   else
1251     TYPE_ERROR("string");
1252 }
1253
1254  void prim_list2string (void)
1255 {
1256   arg1 = alloc_ram_cell_init (COMPOSITE_FIELD0 | ((arg1 & 0x1f00) >> 8),
1257                               arg1 & 0xff,
1258                               STRING_FIELD2,
1259                               0);
1260 }
1261
1262 void prim_ior (void)
1263 {
1264   a1 = decode_int (arg1);
1265   a2 = decode_int (arg2);
1266   arg1 = encode_int (a1 | a2);
1267   arg2 = OBJ_FALSE;
1268 }
1269
1270 void prim_xor (void)
1271 {
1272   a1 = decode_int (arg1);
1273   a2 = decode_int (arg2);
1274   arg1 = encode_int (a1 ^ a2);
1275   arg2 = OBJ_FALSE;
1276 }
1277
1278
1279 /*---------------------------------------------------------------------------*/
1280
1281 /* Robot specific operations */
1282
1283
1284 void prim_print (void)
1285 {
1286 #ifdef __18CXX
1287 #endif
1288
1289 #ifdef WORKSTATION
1290
1291   print (arg1);
1292
1293 #endif
1294
1295   arg1 = OBJ_FALSE;
1296 }
1297
1298
1299 int32 read_clock (void)
1300 {
1301   int32 now = 0;
1302
1303 #ifdef __18CXX
1304
1305   fw_clock_read ();
1306
1307   now = ((int32)(((int16)FW_VALUE_UP << 8) + FW_VALUE_HI) << 8) + FW_VALUE_LO;
1308
1309 #endif
1310
1311 #ifdef WORKSTATION
1312
1313 #ifdef _WIN32
1314
1315   static int32 start = 0;
1316   struct timeb tb;
1317
1318   ftime (&tb);
1319
1320   now = tb.time * 100 + tb.millitm / 10;
1321   if (start == 0)
1322     start = now;
1323   now -= start;
1324
1325 #else
1326
1327   static int32 start = 0;
1328   struct timeval tv;
1329
1330   if (gettimeofday (&tv, NULL) == 0)
1331     {
1332       now = tv.tv_sec * 100 + tv.tv_usec / 10000;
1333       if (start == 0)
1334         start = now;
1335       now -= start;
1336     }
1337
1338 #endif
1339
1340 #endif
1341
1342   return now;
1343 }
1344
1345
1346 void prim_clock (void)
1347 {
1348   arg1 = encode_int (read_clock ());
1349 }
1350
1351
1352 void prim_motor (void)
1353 {
1354   decode_2_int_args ();
1355   a3 = decode_int (arg3);
1356
1357   if (a1 < 0 || a1 > 2 || a2 < -1 || a2 > 1 || a3 < -4 || a3 > 4)
1358     ERROR("argument out of range to procedure \"motor\"");
1359
1360 #ifdef __18CXX
1361
1362   MOTOR_ID  = a1;
1363   MOTOR_ROT = a2;
1364   MOTOR_POW = a3;
1365
1366   fw_motor ();
1367
1368 #endif
1369
1370 #ifdef WORKSTATION
1371
1372   printf ("motor %d -> rotation=%d power=%d\n", a1, a2, a3);
1373   fflush (stdout);
1374
1375 #endif
1376
1377   arg1 = OBJ_FALSE;
1378   arg2 = OBJ_FALSE;
1379   arg3 = OBJ_FALSE;
1380 }
1381
1382
1383 void prim_led (void)
1384 {
1385   a1 = decode_int (arg1);
1386
1387   if (a1 < 0 || a1 > 2){
1388     printf("%d", a1); // TODO debug
1389     ERROR("argument out of range to procedure \"led\"");
1390   }
1391
1392 #ifdef __18CXX
1393
1394   LATBbits.LATB5 = (a1 == 1);
1395   LATBbits.LATB4 = (a1 == 2);
1396
1397 #endif
1398
1399 #ifdef HI_TECH_C
1400
1401   ACTIVITY_LED1 = (a1 == 1);
1402   ACTIVITY_LED2 = (a1 == 2);
1403
1404 #endif
1405
1406 #ifdef WORKSTATION
1407
1408   printf ("led -> %s\n", (a1==1)?"red":(a1==2)?"green":"off");
1409   fflush (stdout);
1410
1411 #endif
1412
1413   arg1 = OBJ_FALSE;
1414 }
1415
1416
1417 void prim_getchar_wait (void)
1418 {
1419   a1 = decode_int (arg1);
1420   a1 = read_clock () + a1;
1421
1422 #ifdef __18CXX
1423
1424   arg1 = OBJ_FALSE;
1425
1426   do
1427     {
1428       uint8 seq_num = STDIO_RX_SEQ_NUM;
1429
1430       fw_ir_rx_stdio_char ();
1431
1432       if (seq_num != STDIO_RX_SEQ_NUM)
1433         {
1434           arg1 = encode_int (FW_VALUE_LO);
1435           break;
1436         }
1437     } while (read_clock () < a1);
1438
1439 #endif
1440
1441 #ifdef WORKSTATION
1442
1443 #ifdef _WIN32
1444
1445   arg1 = OBJ_FALSE;
1446
1447   do
1448     {
1449       if (_kbhit ())
1450         {
1451           arg1 = encode_int (_getch ());
1452           break;
1453         }
1454     } while (read_clock () < a1);
1455
1456
1457 #else
1458
1459   arg1 = encode_int (getchar ());
1460
1461 #endif
1462
1463 #endif
1464 }
1465
1466
1467 void prim_putchar (void)
1468 {
1469   a1 = decode_int (arg1);
1470
1471   if (a1 < 0 || a1 > 255)
1472     ERROR("argument out of range to procedure \"putchar\"");
1473
1474 #ifdef __18CXX
1475
1476   fw_ir_tx_wait_ready ();
1477
1478   IR_TX_BUF[2] = a1;
1479   IR_TX_LENGTH = 1;
1480
1481   fw_ir_tx_stdio ();
1482
1483 #endif
1484
1485 #ifdef WORKSTATION
1486
1487   putchar (a1);
1488   fflush (stdout);
1489
1490 #endif
1491
1492   arg1 = OBJ_FALSE;
1493 }
1494
1495
1496 void prim_light (void)
1497 {
1498   uint8 light;
1499
1500 #ifdef __18CXX
1501
1502   fw_light_read ();
1503
1504   light = FW_VALUE_LO;
1505
1506 #endif
1507
1508 #ifdef WORKSTATION
1509
1510   light = read_clock () & 31;
1511
1512   if (light > 15) light = 32 - light;
1513
1514   light += 40;
1515
1516 #endif
1517
1518   arg1 = encode_int (light);
1519 }
1520
1521
1522 /*---------------------------------------------------------------------------*/
1523
1524 #ifdef WORKSTATION
1525
1526 int hidden_fgetc (FILE *f)
1527 {
1528   int c = fgetc (f);
1529 #if 0
1530   printf ("{%d}",c);
1531   fflush (stdout);
1532 #endif
1533   return c;
1534 }
1535
1536 #define fgetc(f) hidden_fgetc(f)
1537
1538 void write_hex_nibble (int n)
1539 {
1540   putchar ("0123456789ABCDEF"[n]);
1541 }
1542
1543 void write_hex (uint8 n)
1544 {
1545   write_hex_nibble (n >> 4);
1546   write_hex_nibble (n & 0x0f);
1547 }
1548
1549 int hex (int c)
1550 {
1551   if (c >= '0' && c <= '9')
1552     return (c - '0');
1553
1554   if (c >= 'A' && c <= 'F')
1555     return (c - 'A' + 10);
1556
1557   if (c >= 'a' && c <= 'f')
1558     return (c - 'a' + 10);
1559
1560   return -1;
1561 }
1562
1563 int read_hex_byte (FILE *f)
1564 {
1565   int h1 = hex (fgetc (f));
1566   int h2 = hex (fgetc (f));
1567
1568   if (h1 >= 0 && h2 >= 0)
1569     return (h1<<4) + h2;
1570
1571   return -1;
1572 }
1573
1574 int read_hex_file (char *filename)
1575 {
1576   int c;
1577   FILE *f = fopen (filename, "r");
1578   int result = 0;
1579   int len;
1580   int a, a1, a2;
1581   int t;
1582   int b;
1583   int i;
1584   uint8 sum;
1585   int hi16 = 0;
1586
1587   for (i=0; i<ROM_BYTES; i++)
1588     rom_mem[i] = 0xff;
1589
1590   if (f != NULL)
1591     {
1592       while ((c = fgetc (f)) != EOF)
1593         {
1594           if ((c == '\r') || (c == '\n'))
1595             continue;
1596
1597           if (c != ':' ||
1598               (len = read_hex_byte (f)) < 0 ||
1599               (a1 = read_hex_byte (f)) < 0 ||
1600               (a2 = read_hex_byte (f)) < 0 ||
1601               (t = read_hex_byte (f)) < 0)
1602             break;
1603
1604           a = (a1 << 8) + a2;
1605
1606           i = 0;
1607           sum = len + a1 + a2 + t;
1608
1609           if (t == 0)
1610             {
1611             next0:
1612
1613               if (i < len)
1614                 {
1615                   unsigned long adr = ((unsigned long)hi16 << 16) + a - CODE_START;
1616
1617                   if ((b = read_hex_byte (f)) < 0)
1618                     break;
1619
1620                   if (adr >= 0 && adr < ROM_BYTES)
1621                     rom_mem[adr] = b;
1622
1623                   a = (a + 1) & 0xffff;
1624                   i++;
1625                   sum += b;
1626
1627                   goto next0;
1628                 }
1629             }
1630           else if (t == 1)
1631             {
1632               if (len != 0)
1633                 break;
1634             }
1635           else if (t == 4)
1636             {
1637               if (len != 2)
1638                 break;
1639
1640               if ((a1 = read_hex_byte (f)) < 0 ||
1641                   (a2 = read_hex_byte (f)) < 0)
1642                 break;
1643
1644               sum += a1 + a2;
1645
1646               hi16 = (a1<<8) + a2;
1647             }
1648           else
1649             break;
1650
1651           if ((b = read_hex_byte (f)) < 0)
1652             break;
1653
1654           sum = -sum;
1655
1656           if (sum != b)
1657             {
1658               printf ("*** HEX file checksum error (expected 0x%02x)\n", sum);
1659               break;
1660             }
1661
1662           c = fgetc (f);
1663
1664           if ((c != '\r') && (c != '\n'))
1665             break;
1666
1667           if (t == 1)
1668             {
1669               result = 1;
1670               break;
1671             }
1672         }
1673
1674       if (result == 0)
1675         printf ("*** HEX file syntax error\n");
1676
1677       fclose (f);
1678     }
1679
1680   return result;
1681 }
1682
1683 #endif
1684
1685 /*---------------------------------------------------------------------------*/
1686
1687 #define FETCH_NEXT_BYTECODE() bytecode = rom_get (pc++)
1688
1689 #define BEGIN_DISPATCH()                        \
1690   dispatch:                                     \
1691   IF_TRACE(show_state (pc));                    \
1692   FETCH_NEXT_BYTECODE();                        \
1693   bytecode_hi4 = bytecode & 0xf0;               \
1694   bytecode_lo4 = bytecode & 0x0f;               \
1695   switch (bytecode_hi4 >> 4) {
1696
1697 #define END_DISPATCH() }
1698
1699 #define CASE(opcode) case (opcode>>4):;
1700
1701 #define DISPATCH(); goto dispatch;
1702
1703 #if 0
1704 #define pc FSR1
1705 #define sp FSR2
1706 #define bytecode TABLAT
1707 #define bytecode_hi4 WREG
1708 #endif
1709
1710 #define PUSH_CONSTANT1 0x00
1711 #define PUSH_CONSTANT2 0x10
1712 #define PUSH_STACK1    0x20
1713 #define PUSH_STACK2    0x30
1714 #define PUSH_GLOBAL    0x40
1715 #define SET_GLOBAL     0x50
1716 #define CALL           0x60
1717 #define JUMP           0x70
1718 #define CALL_TOPLEVEL  0x80
1719 #define JUMP_TOPLEVEL  0x90
1720 #define GOTO           0xa0
1721 #define GOTO_IF_FALSE  0xb0
1722 #define CLOSURE        0xc0
1723 #define PRIM1          0xd0
1724 #define PRIM2          0xe0
1725 #define PRIM3          0xf0
1726
1727 #ifdef WORKSTATION
1728
1729 char *prim_name[48] =
1730   {
1731     "prim #%number?",
1732     "prim #%+",
1733     "prim #%-",
1734     "prim #%*",
1735     "prim #%quotient",
1736     "prim #%remainder",
1737     "prim #%neg",
1738     "prim #%=",
1739     "prim #%<",
1740     "prim #%ior",
1741     "prim #%>",
1742     "prim #%xor",
1743     "prim #%pair?",
1744     "prim #%cons",
1745     "prim #%car",
1746     "prim #%cdr",
1747     "prim #%set-car!",
1748     "prim #%set-cdr!",
1749     "prim #%null?",
1750     "prim #%eq?",
1751     "prim #%not",
1752     "prim #%get-cont",
1753     "prim #%graft-to-cont",
1754     "prim #%return-to-cont",
1755     "prim #%halt",
1756     "prim #%symbol?",
1757     "prim #%string?",
1758     "prim #%string->list",
1759     "prim #%list->string",
1760     "prim #%set-fst!", // ADDED TODO obsolete, but kept to have the right size
1761     "prim #%set-snd!", // ADDED
1762     "prim #%set-trd!", // ADDED
1763     "prim #%print",
1764     "prim #%clock",
1765     "prim #%motor",
1766     "prim #%led",
1767     "prim #%getchar-wait",
1768     "prim #%putchar",
1769     "prim #%light",
1770     "prim #%triplet?", // ADDED
1771     "prim #%triplet", // ADDED
1772     "prim #%fst", // ADDED
1773     "prim #%snd", // ADDED
1774     "prim #%trd", // ADDED
1775     "push-constant [long]",
1776     "shift",
1777     "pop",
1778     "return",
1779   };
1780
1781 #endif
1782
1783 #define PUSH_ARG1() push_arg1 ()
1784 #define POP() pop()
1785
1786 void push_arg1 (void)
1787 {
1788   env = cons (arg1, env);
1789   arg1 = OBJ_FALSE;
1790 }
1791
1792 obj pop (void)
1793 {
1794   obj o = ram_get_car (env);
1795   env = ram_get_cdr (env);
1796   return o;
1797 }
1798
1799 void pop_procedure (void) // TODO where do we get the env of the procedure ?
1800 { // TODO can continuations end up ond the stack ? if so, they act differently than procedures
1801   arg1 = POP();
1802   if (IN_RAM(arg1))
1803     {
1804       if (RAM_PROCEDURE(arg1))
1805         TYPE_ERROR("procedure");
1806
1807       entry = ((ram_get_field2 (arg1) << 8) | ram_get_field3 (arg1))
1808         + CODE_START;
1809     }
1810   else if (IN_ROM(arg1))
1811     {
1812       if (ROM_PROCEDURE(arg1))
1813         TYPE_ERROR("procedure");
1814
1815       entry = ((rom_get_field2 (arg1) << 8) | rom_get_field3 (arg1))
1816         + CODE_START;
1817     }
1818   else
1819     TYPE_ERROR("procedure");
1820 }
1821
1822 void handle_arity_and_rest_param (void)
1823 {
1824   uint8 np;
1825
1826   np = rom_get (entry++); // TODO does that mean we can't have procedures in ram ?
1827
1828   if ((np & 0x80) == 0)
1829     {
1830       if (na != np)
1831         ERROR("wrong number of arguments");
1832     }
1833   else
1834     {
1835       np = ~np;
1836
1837       if (na < np)
1838         ERROR("wrong number of arguments");
1839
1840       arg3 = OBJ_NULL;
1841
1842       while (na > np)
1843         {
1844           arg4 = POP();
1845
1846           arg3 = cons (arg4, arg3);
1847           arg4 = OBJ_FALSE;
1848
1849           na--;
1850         }
1851
1852       arg1 = cons (arg3, arg1); // TODO what shpuld be the value of arg1 at this point ? the popped procedure ? the old env ? looks like the popped procedure
1853       arg3 = OBJ_FALSE;
1854     }
1855 }
1856
1857 void build_env (void)
1858 {
1859   while (na != 0)
1860     {
1861       arg3 = POP();
1862
1863       arg1 = cons (arg3, arg1);
1864
1865       na--;
1866     }
1867
1868   arg3 = OBJ_FALSE;
1869 }
1870
1871 void save_cont (void)
1872 {
1873   second_half = cons (env, cont);
1874   cont = alloc_ram_cell_init (PROCEDURE_FIELD0 | ((second_half &0x1f00) >> 8),
1875                               second_half & 0xff,
1876                               (pc & 0xff00) >> 8,
1877                               pc & 0xff);
1878 }
1879
1880 void interpreter (void)
1881 {
1882   init_ram_heap ();
1883
1884   pc = (CODE_START + 4) + ((rom_addr)rom_get (CODE_START+2) << 2);
1885
1886   BEGIN_DISPATCH();
1887
1888   /***************************************************************************/
1889   CASE(PUSH_CONSTANT1);
1890
1891   IF_TRACE(printf("  (push-constant "); show (bytecode_lo4); printf (")\n"));
1892
1893   arg1 = bytecode_lo4;
1894
1895   PUSH_ARG1();
1896
1897   DISPATCH();
1898
1899   /***************************************************************************/
1900   CASE(PUSH_CONSTANT2);
1901
1902   IF_TRACE(printf("  (push-constant "); show (bytecode_lo4+16); printf (")\n"));
1903   // TODO for bigger fixnums and co, we have to use push long ? fix push long
1904   arg1 = bytecode_lo4+16;
1905
1906   PUSH_ARG1();
1907
1908   DISPATCH();
1909
1910   /***************************************************************************/
1911   CASE(PUSH_STACK1);
1912
1913   IF_TRACE(printf("  (push-stack %d)\n", bytecode_lo4));
1914
1915   arg1 = env;
1916
1917   while (bytecode_lo4 != 0)
1918     {
1919       arg1 = ram_get_cdr (arg1);
1920       bytecode_lo4--;
1921     }
1922
1923   arg1 = ram_get_car (arg1);
1924
1925   PUSH_ARG1();
1926
1927   DISPATCH();
1928
1929   /***************************************************************************/
1930   CASE(PUSH_STACK2);
1931
1932   IF_TRACE(printf("  (push-stack %d)\n", bytecode_lo4+16)); // TODO do we ever need to go this far in the stack ? since the stack is the env, maybe, if not, we have one free instruction
1933
1934   bytecode_lo4 += 16;
1935
1936   arg1 = env;
1937
1938   while (bytecode_lo4 != 0)
1939     {
1940       arg1 = ram_get_cdr (arg1);
1941       bytecode_lo4--;
1942     }
1943
1944   arg1 = ram_get_car (arg1);
1945
1946   PUSH_ARG1();
1947
1948   DISPATCH();
1949
1950   /***************************************************************************/
1951   CASE(PUSH_GLOBAL);
1952
1953   IF_TRACE(printf("  (push-global %d)\n", bytecode_lo4));
1954
1955   arg1 = get_global (bytecode_lo4);
1956
1957   PUSH_ARG1();
1958
1959   DISPATCH();
1960
1961   /***************************************************************************/
1962   CASE(SET_GLOBAL);
1963
1964   IF_TRACE(printf("  (set-global %d)\n", bytecode_lo4));
1965
1966   set_global (bytecode_lo4, POP());
1967
1968   DISPATCH();
1969
1970   /***************************************************************************/
1971   CASE(CALL);
1972
1973   IF_TRACE(printf("  (call %d)\n", bytecode_lo4));
1974
1975   na = bytecode_lo4;
1976
1977   pop_procedure ();
1978   handle_arity_and_rest_param ();
1979   build_env ();
1980   save_cont ();
1981
1982   env = arg1;
1983   pc = entry;
1984
1985   arg1 = OBJ_FALSE;
1986
1987   DISPATCH();
1988
1989   /***************************************************************************/
1990   CASE(JUMP);
1991
1992   IF_TRACE(printf("  (jump %d)\n", bytecode_lo4));
1993
1994   na = bytecode_lo4;
1995
1996   pop_procedure ();
1997   handle_arity_and_rest_param ();
1998   build_env ();
1999
2000   env = arg1;
2001   pc = entry;
2002
2003   arg1 = OBJ_FALSE;
2004
2005   DISPATCH();
2006
2007   /***************************************************************************/
2008   CASE(CALL_TOPLEVEL);
2009
2010   FETCH_NEXT_BYTECODE();
2011   second_half = bytecode; // TODO make sure second_half is not already in use
2012
2013   FETCH_NEXT_BYTECODE();
2014
2015   IF_TRACE(printf("  (call-toplevel 0x%04x)\n", ((second_half << 8) | bytecode) + CODE_START));
2016
2017   entry = ((second_half << 8) | bytecode) + CODE_START; // TODO FOOBAR we'd have to change the compiler to use 2 bytes after the opcode instead of one, and now we have the last 4 bits of the opcode free, to do pretty much anything
2018   arg1 = OBJ_NULL;
2019
2020   na = rom_get (entry++);
2021
2022   build_env ();
2023   save_cont ();
2024
2025   env = arg1;
2026   pc = entry;
2027
2028   arg1 = OBJ_FALSE;
2029
2030   DISPATCH();
2031
2032   /***************************************************************************/
2033   CASE(JUMP_TOPLEVEL);
2034
2035   FETCH_NEXT_BYTECODE();
2036   second_half = bytecode; // TODO make sure second_half is not already in use
2037
2038   FETCH_NEXT_BYTECODE();
2039
2040   IF_TRACE(printf("  (jump-toplevel 0x%04x)\n", ((second_half << 8) | bytecode) + CODE_START));
2041
2042   entry = ((second_half << 8) | bytecode) + CODE_START;
2043   arg1 = OBJ_NULL;
2044
2045   na = rom_get (entry++);
2046
2047   build_env ();
2048
2049   env = arg1;
2050   pc = entry;
2051
2052   arg1 = OBJ_FALSE;
2053
2054   DISPATCH();
2055
2056   /***************************************************************************/
2057   CASE(GOTO);
2058
2059   FETCH_NEXT_BYTECODE();
2060   // TODO goto's use 12-bit addresses, unlike calls and jumps, which use 16, is it ok ?
2061   IF_TRACE(printf("  (goto 0x%04x)\n", ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode));
2062
2063   pc = ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode;
2064
2065   DISPATCH();
2066
2067   /***************************************************************************/
2068   CASE(GOTO_IF_FALSE);
2069
2070   FETCH_NEXT_BYTECODE();
2071
2072   IF_TRACE(printf("  (goto-if-false 0x%04x)\n", ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode));
2073
2074   if (POP() == OBJ_FALSE)
2075     pc = ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode;
2076
2077   DISPATCH();
2078
2079   /***************************************************************************/
2080   CASE(CLOSURE);
2081
2082   FETCH_NEXT_BYTECODE();
2083   second_half = bytecode;
2084
2085   FETCH_NEXT_BYTECODE();
2086
2087   IF_TRACE(printf("  (closure 0x%04x)\n", (second_half << 8) | bytecode));
2088   // TODO original had CODE_START, while the real code below didn't
2089
2090   arg2 = POP(); // #f TODO should be, at least, and not used anymore
2091   arg3 = POP(); // env
2092
2093   entry = (second_half << 8) | bytecode; // TODO original had no CODE_START, why ?
2094
2095   arg1 = alloc_ram_cell_init (PROCEDURE_FIELD0 | ((arg3 & 0x1f00) >> 8),
2096                               arg3 & 0xff,
2097                               second_half,
2098                               bytecode);
2099
2100   PUSH_ARG1();
2101
2102   arg2 = OBJ_FALSE;
2103   arg3 = OBJ_FALSE;
2104
2105   DISPATCH();
2106
2107   /***************************************************************************/
2108   CASE(PRIM1);
2109
2110   IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4]));
2111
2112   switch (bytecode_lo4)
2113     {
2114     case 0:
2115       arg1 = POP();  prim_numberp ();  PUSH_ARG1();  break;
2116     case 1:
2117       arg2 = POP();  arg1 = POP();  prim_add ();      PUSH_ARG1();  break;
2118     case 2:
2119       arg2 = POP();  arg1 = POP();  prim_sub ();      PUSH_ARG1();  break;
2120     case 3:
2121       arg2 = POP();  arg1 = POP();  prim_mul ();      PUSH_ARG1();  break;
2122     case 4:
2123       arg2 = POP();  arg1 = POP();  prim_div ();      PUSH_ARG1();  break;
2124     case 5:
2125       arg2 = POP();  arg1 = POP();  prim_rem ();      PUSH_ARG1();  break;
2126     case 6:
2127       arg1 = POP();  prim_neg ();      PUSH_ARG1();  break;
2128     case 7:
2129       arg2 = POP();  arg1 = POP();  prim_eq ();       PUSH_ARG1();  break;
2130     case 8:
2131       arg2 = POP();  arg1 = POP();  prim_lt ();       PUSH_ARG1();  break;
2132     case 9:
2133       arg2 = POP(); arg1 = POP(); prim_ior (); PUSH_ARG1(); break;
2134     case 10:
2135       arg2 = POP();  arg1 = POP();  prim_gt ();       PUSH_ARG1();  break;
2136     case 11:
2137       arg2 = POP(); arg1 = POP(); prim_xor (); PUSH_ARG1(); break;
2138     case 12:
2139       arg1 = POP();  prim_pairp ();    PUSH_ARG1();  break;
2140     case 13:
2141       arg2 = POP();  arg1 = POP();  prim_cons ();     PUSH_ARG1();  break;
2142     case 14:
2143       arg1 = POP();  prim_car ();      PUSH_ARG1();  break;
2144     case 15:
2145       arg1 = POP();  prim_cdr ();      PUSH_ARG1();  break;
2146     }
2147
2148   DISPATCH();
2149
2150   /***************************************************************************/
2151   CASE(PRIM2);
2152
2153   IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4+16]));
2154
2155   switch (bytecode_lo4)
2156     {
2157     case 0:
2158       arg2 = POP();  arg1 = POP();  prim_set_car ();                break;
2159     case 1:
2160       arg2 = POP();  arg1 = POP();  prim_set_cdr ();                break;
2161     case 2:
2162       arg1 = POP();  prim_nullp ();    PUSH_ARG1();  break;
2163     case 3:
2164       arg2 = POP();  arg1 = POP();  prim_eqp ();      PUSH_ARG1();  break;
2165     case 4:
2166       arg1 = POP();  prim_not ();      PUSH_ARG1();  break;
2167     case 5:
2168       /* prim #%get-cont */
2169       arg1 = cont;
2170       PUSH_ARG1();
2171       break;
2172     case 6:
2173       /* prim #%graft-to-cont */
2174
2175       arg1 = POP(); /* thunk to call */
2176       cont = POP(); /* continuation */
2177
2178       PUSH_ARG1();
2179
2180       na = 0;
2181
2182       pop_procedure ();
2183       handle_arity_and_rest_param ();
2184       build_env ();
2185
2186       env = arg1;
2187       pc = entry;
2188
2189       arg1 = OBJ_FALSE;
2190
2191       break;
2192     case 7:
2193       /* prim #%return-to-cont */
2194
2195       arg1 = POP(); /* value to return */
2196       cont = POP(); /* continuation */
2197
2198       pc = ((ram_get_field2 (cont) << 8) | ram_get_field3 (cont)) + CODE_START;
2199       second_half = ram_get_car (cont);
2200       env = ram_get_car (second_half);
2201       cont = ram_get_cdr (second_half);
2202
2203       PUSH_ARG1();
2204
2205       break;
2206     case 8:
2207       /* prim #%halt */
2208       return;
2209     case 9:
2210       /* prim #%symbol? */
2211       arg1 = POP();  prim_symbolp ();  PUSH_ARG1();  break;
2212     case 10:
2213       /* prim #%string? */
2214       arg1 = POP();  prim_stringp ();  PUSH_ARG1();  break;
2215     case 11:
2216       /* prim #%string->list */
2217       arg1 = POP();  prim_string2list ();  PUSH_ARG1();  break;
2218     case 12:
2219       /* prim #%list->string */
2220       arg1 = POP();  prim_list2string ();  PUSH_ARG1();  break;
2221 #if 0
2222     case 13:
2223       break;
2224     case 14:
2225       break;
2226     case 15:
2227       break;
2228 #endif
2229     }
2230
2231   DISPATCH();
2232
2233   /***************************************************************************/
2234   CASE(PRIM3);
2235
2236   IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4+32]));
2237
2238   switch (bytecode_lo4)
2239     {
2240     case 0:
2241       /* prim #%print */
2242       arg1 = POP();
2243       prim_print ();
2244       break;
2245     case 1:
2246       /* prim #%clock */
2247       prim_clock ();  PUSH_ARG1();  break;
2248     case 2:
2249       /* prim #%motor */
2250       arg3 = POP();  arg2 = POP();  arg1 = POP();  prim_motor ();  break;
2251     case 3:
2252       /* prim #%led */
2253       arg1 = POP();  prim_led ();  ;break;
2254     case 4:
2255       /* prim #%getchar-wait */
2256       arg1 = POP();  prim_getchar_wait ();  PUSH_ARG1();  break;
2257     case 5:
2258       /* prim #%putchar */
2259       arg1 = POP();  prim_putchar ();  break;
2260     case 6:
2261       /* prim #%light */
2262       prim_light ();  PUSH_ARG1();  break;
2263 #if 0
2264     case 7: // TODO since not all of them will be used for vectors, maybe some could be used to have more globals ? or something else ?
2265       break;
2266     case 8:
2267       break;
2268     case 9:
2269       break;
2270     case 10:
2271       break;
2272     case 11:
2273       break;
2274 #endif
2275     case 12:
2276       /* push-constant [long] */
2277       FETCH_NEXT_BYTECODE();
2278       second_half = bytecode;
2279       FETCH_NEXT_BYTECODE();
2280       arg1 = (second_half << 8) | bytecode;
2281       PUSH_ARG1();
2282       break;
2283     case 13:
2284       /* shift */
2285       arg1 = POP();
2286       POP();
2287       PUSH_ARG1();
2288       break;
2289     case 14:
2290       /* pop */
2291       POP();
2292       break;
2293     case 15:
2294       /* return */
2295       arg1 = POP();
2296       pc = ((ram_get_field2 (cont) << 8) | ram_get_field3 (cont)) + CODE_START;
2297       second_half = ram_get_car (cont);
2298       env = ram_get_car (second_half);
2299       cont = ram_get_cdr (second_half);
2300       PUSH_ARG1();
2301       break;
2302     }
2303
2304   DISPATCH();
2305
2306   /***************************************************************************/
2307
2308   END_DISPATCH();
2309 }
2310
2311 /*---------------------------------------------------------------------------*/
2312
2313 #ifdef WORKSTATION
2314
2315 void usage (void)
2316 {
2317   printf ("usage: sim file.hex\n");
2318   exit (1);
2319 }
2320
2321 int main (int argc, char *argv[])
2322 {
2323   int errcode = 1;
2324   rom_addr rom_start_addr = 0;
2325
2326   if (argc > 1 && argv[1][0] == '-' && argv[1][1] == 's')
2327     {
2328       int h1;
2329       int h2;
2330       int h3;
2331       int h4;
2332
2333       if ((h1 = hex (argv[1][2])) < 0 ||
2334           (h2 = hex (argv[1][3])) < 0 ||
2335           (h3 = hex (argv[1][4])) != 0 ||
2336           (h4 = hex (argv[1][5])) != 0 ||
2337           argv[1][6] != '\0')
2338         usage ();
2339
2340       rom_start_addr = (h1 << 12) | (h2 << 8) | (h3 << 4) | h4;
2341
2342       argv++;
2343       argc--;
2344     }
2345
2346 #ifdef DEBUG
2347   printf ("Start address = 0x%04x\n", rom_start_addr);
2348 #endif
2349
2350   if (argc != 2)
2351     usage ();
2352
2353   if (!read_hex_file (argv[1]))
2354     printf ("*** Could not read hex file \"%s\"\n", argv[1]);
2355   else
2356     {
2357       int i;
2358
2359       if (rom_get (CODE_START+0) != 0xfb ||
2360           rom_get (CODE_START+1) != 0xd7)
2361         printf ("*** The hex file was not compiled with PICOBIT\n");
2362       else
2363         {
2364 #if 0
2365           for (i=0; i<8192; i++)
2366             if (rom_get (i) != 0xff)
2367               printf ("rom_mem[0x%04x] = 0x%02x\n", i, rom_get (i));
2368 #endif
2369
2370           interpreter ();
2371
2372 #ifdef DEBUG_GC
2373           printf ("**************** memory needed = %d\n", max_live+1);
2374 #endif
2375         }
2376     }
2377
2378   return errcode;
2379 }
2380
2381 #endif
2382
2383 /*---------------------------------------------------------------------------*/
2384
2385 #ifdef __18CXX
2386
2387 /* $Id: c018i.c,v 1.1.2.1 2004/03/09 16:47:01 sealep Exp $ */
2388
2389 /* Copyright (c)1999 Microchip Technology */
2390
2391 /* MPLAB-C18 startup code, including initialized data */
2392
2393 #if 0
2394 /* external reference to the user's main routine */
2395 extern void main (void);
2396 /* prototype for the startup function */
2397 void _entry (void);
2398 #endif
2399 void _startup (void);
2400 /* prototype for the initialized data setup */
2401 void _do_cinit (void);
2402
2403 extern volatile near unsigned long short TBLPTR;
2404 extern near unsigned FSR0;
2405 extern near char FPFLAGS;
2406 #define RND 6
2407
2408 #if 0
2409 #pragma code _entry_scn=0x000000
2410 void
2411 _entry (void)
2412 {
2413   _asm goto _startup _endasm
2414
2415     }
2416 #pragma code _startup_scn
2417 #endif
2418
2419 void
2420 _startup (void)
2421 {
2422   _asm
2423     // Initialize the stack pointer
2424     lfsr 1, _stack lfsr 2, _stack clrf TBLPTRU, 0 // 1st silicon doesn't do this on POR
2425     bcf FPFLAGS,RND,0 // Initialize rounding flag for floating point libs
2426
2427     _endasm
2428     _do_cinit ();
2429
2430   // Call the user's main routine
2431   interpreter ();
2432
2433   ERROR("halted");
2434 }                               /* end _startup() */
2435
2436 /* MPLAB-C18 initialized data memory support */
2437 /* The linker will populate the _cinit table */
2438 extern far rom struct
2439 {
2440   unsigned short num_init;
2441   struct _init_entry
2442   {
2443     unsigned long from;
2444     unsigned long to;
2445     unsigned long size;
2446   }
2447     entries[];
2448 }
2449   _cinit;
2450
2451 #pragma code _cinit_scn
2452 void
2453 _do_cinit (void)
2454 {
2455   /* we'll make the assumption in the following code that these statics
2456    * will be allocated into the same bank.
2457    */
2458   static short long prom;
2459   static unsigned short curr_byte;
2460   static unsigned short curr_entry;
2461   static short long data_ptr;
2462
2463   // Initialized data...
2464   TBLPTR = (short long)&_cinit;
2465   _asm
2466     movlb data_ptr
2467     tblrdpostinc
2468     movf TABLAT, 0, 0
2469     movwf curr_entry, 1
2470     tblrdpostinc
2471     movf TABLAT, 0, 0
2472     movwf curr_entry+1, 1
2473     _endasm
2474     //while (curr_entry)
2475     //{
2476     test:
2477   _asm
2478     bnz 3
2479     tstfsz curr_entry, 1
2480     bra 1
2481     _endasm
2482     goto done;
2483   /* Count down so we only have to look up the data in _cinit
2484    * once.
2485    *
2486    * At this point we know that TBLPTR points to the top of the current
2487    * entry in _cinit, so we can just start reading the from, to, and
2488    * size values.
2489    */
2490   _asm
2491     /* read the source address */
2492     tblrdpostinc
2493     movf TABLAT, 0, 0
2494     movwf prom, 1
2495     tblrdpostinc
2496     movf TABLAT, 0, 0
2497     movwf prom+1, 1
2498     tblrdpostinc
2499     movf TABLAT, 0, 0
2500     movwf prom+2, 1
2501     /* skip a byte since it's stored as a 32bit int */
2502     tblrdpostinc
2503     /* read the destination address directly into FSR0 */
2504     tblrdpostinc
2505     movf TABLAT, 0, 0
2506     movwf FSR0L, 0
2507     tblrdpostinc
2508     movf TABLAT, 0, 0
2509     movwf FSR0H, 0
2510     /* skip two bytes since it's stored as a 32bit int */
2511     tblrdpostinc
2512     tblrdpostinc
2513     /* read the destination address directly into FSR0 */
2514     tblrdpostinc
2515     movf TABLAT, 0, 0
2516     movwf curr_byte, 1
2517     tblrdpostinc
2518     movf TABLAT, 0, 0
2519     movwf curr_byte+1, 1
2520     /* skip two bytes since it's stored as a 32bit int */
2521     tblrdpostinc
2522     tblrdpostinc
2523     _endasm
2524     //prom = data_ptr->from;
2525     //FSR0 = data_ptr->to;
2526     //curr_byte = (unsigned short) data_ptr->size;
2527     /* the table pointer now points to the next entry. Save it
2528      * off since we'll be using the table pointer to do the copying
2529      * for the entry.
2530      */
2531     data_ptr = TBLPTR;
2532
2533   /* now assign the source address to the table pointer */
2534   TBLPTR = prom;
2535
2536   /* do the copy loop */
2537   _asm
2538     // determine if we have any more bytes to copy
2539     movlb curr_byte
2540     movf curr_byte, 1, 1
2541     copy_loop:
2542   bnz 2 // copy_one_byte
2543     movf curr_byte + 1, 1, 1
2544     bz 7 // done_copying
2545
2546     copy_one_byte:
2547   tblrdpostinc
2548     movf TABLAT, 0, 0
2549     movwf POSTINC0, 0
2550
2551     // decrement byte counter
2552     decf curr_byte, 1, 1
2553     bc -8 // copy_loop
2554     decf curr_byte + 1, 1, 1
2555     bra -7 // copy_one_byte
2556
2557     done_copying:
2558
2559   _endasm
2560     /* restore the table pointer for the next entry */
2561     TBLPTR = data_ptr;
2562   /* next entry... */
2563   curr_entry--;
2564   goto test;
2565  done:
2566   ;
2567 }
2568
2569 #pragma code picobit_boot=0x001ffa
2570 void _picobit_boot (void)
2571 {
2572   _asm goto _startup _endasm
2573     }
2574
2575 #endif
2576
2577 /*---------------------------------------------------------------------------*/