picobit-vm.c

   1 /* file: "picobit-vm.c" */
   2
   3 /*
   4  * Copyright 2004 by Marc Feeley, All Rights Reserved.
   5  *
   6  * History:
   7  *
   8  *   15/08/2004  Release of version 1
   9  *   06/07/2008  Modified for PICOBOARD2_R3
  10  *   07/18/2008  Modified to use new object representation
  11  */
  12
  13 #define DEBUG_not
  14 #define DEBUG_GC_not
  15
  16 /*---------------------------------------------------------------------------*/
  17
  18 typedef char int8;
  19 typedef short int16;
  20 typedef long int32;
  21 typedef unsigned char uint8;
  22 typedef unsigned short uint16;
  23 typedef unsigned long uint32;
  24
  25 /*---------------------------------------------------------------------------*/
  26
  27
  28 #ifdef PICOBOARD2
  29 #define ROBOT
  30 #endif
  31
  32 #ifdef HI_TECH_C
  33 #define ROBOT
  34 #endif
  35
  36 #ifndef ROBOT
  37 #define WORKSTATION
  38 #endif
  39
  40
  41 #ifdef HI_TECH_C
  42
  43 #include <pic18.h>
  44
  45 static volatile near uint8 FW_VALUE_UP       @ 0x33;
  46 static volatile near uint8 FW_VALUE_HI       @ 0x33;
  47 static volatile near uint8 FW_VALUE_LO       @ 0x33;
  48
  49 #define ACTIVITY_LED1_LAT LATB
  50 #define ACTIVITY_LED1_BIT 5
  51 #define ACTIVITY_LED2_LAT LATB
  52 #define ACTIVITY_LED2_BIT 4
  53 static volatile near bit ACTIVITY_LED1 @ ((unsigned)&ACTIVITY_LED1_LAT*8)+ACTIVITY_LED1_BIT;
  54 static volatile near bit ACTIVITY_LED2 @ ((unsigned)&ACTIVITY_LED2_LAT*8)+ACTIVITY_LED2_BIT;
  55
  56 #endif
  57
  58
  59 #ifdef WORKSTATION
  60
  61 #include <stdio.h>
  62 #include <stdlib.h>
  63
  64 #ifdef _WIN32
  65 #include <sys/types.h>
  66 #include <sys/timeb.h>
  67 #include <conio.h>
  68 #else
  69 #include <sys/time.h>
  70 #endif
  71
  72 #endif
  73
  74
  75 /*---------------------------------------------------------------------------*/
  76
  77 #define WORD_BITS 8
  78
  79 #define CODE_START 0x5000
  80
  81 #ifdef DEBUG
  82 #define IF_TRACE(x) x
  83 #define IF_GC_TRACE(x) x
  84 #else
  85 #define IF_TRACE(x)
  86 #define IF_GC_TRACE(x)
  87 #endif
  88
  89 /*---------------------------------------------------------------------------*/
  90
  91
  92 #ifdef PICOBOARD2
  93
  94 #define ERROR(msg) halt_with_error()
  95 #define TYPE_ERROR(prim, type) halt_with_error()
  96
  97 #endif
  98
  99
 100 #ifdef WORKSTATION
 101
 102 #define ERROR(msg) error (msg)
 103 #define TYPE_ERROR(prim, type) type_error (prim, type)
 104
 105 void error (char *msg)
 106 {
 107   printf ("ERROR: %s\n", msg);
 108   exit (1);
 109 }
 110
 111 void type_error (char *prim, char *type)
 112 {
 113   printf ("ERROR: %s: An argument of type %s was expected\n", prim, type);
 114   exit (1);
 115 }
 116
 117 #endif
 118
 119
 120 /*---------------------------------------------------------------------------*/
 121
 122 #if WORD_BITS <= 8
 123 typedef uint8 word;
 124 #else
 125 typedef uint16 word;
 126 #endif
 127
 128 typedef uint16 ram_addr;
 129 typedef uint16 rom_addr;
 130
 131 typedef uint16 obj;
 132
 133 /*---------------------------------------------------------------------------*/
 134
 135 #define MAX_VEC_ENCODING 8191
 136 #define MIN_VEC_ENCODING 4096
 137 #define VEC_BYTES ((MAX_VEC_ENCODING - MIN_VEC_ENCODING + 1)*4)
 138 // TODO this is new. if the pic has less than 8k of memory, start this lower
 139 // TODO max was 8192 for ram, would have been 1 too much (watch out, master branch still has that), now corrected
 140 // TODO the pic actually has 2k, so change these FOOBAR
 141 // TODO we'd only actually need 1024 or so for ram and vectors, since we can't address more. this gives us a lot of rom space
 142
 143 #define MAX_RAM_ENCODING 4095
 144 #define MIN_RAM_ENCODING 512
 145 #define RAM_BYTES ((MAX_RAM_ENCODING - MIN_RAM_ENCODING + 1)*4)
 146 // TODO watch out if we address more than what the PIC actually has
 147
 148 #if WORD_BITS == 8
 149 // TODO subtracts min_ram since vectors are actually in ram
 150 #define OBJ_TO_VEC_ADDR(o,f) (((ram_addr)((uint16)(o) - MIN_RAM_ENCODING) << 2) + (f))
 151 #define OBJ_TO_RAM_ADDR(o,f) (((ram_addr)((uint16)(o) - MIN_RAM_ENCODING) << 2) + (f))
 152 #define OBJ_TO_ROM_ADDR(o,f) (((rom_addr)((uint16)(o) - MIN_ROM_ENCODING) << 2) + (CODE_START + 4 + (f)))
 153 #endif
 154
 155 #ifdef PICOBOARD2
 156
 157 #define ram_get(a) *(uint8*)(a+0x200)
 158 #define ram_set(a,x) *(uint8*)(a+0x200) = (x)
 159 // TODO change these since we change proportion of ram and rom ?
 160 #endif
 161
 162
 163 #ifdef WORKSTATION
 164
 165 uint8 ram_mem[RAM_BYTES + VEC_BYTES];
 166
 167 #define ram_get(a) ram_mem[a]
 168 #define ram_set(a,x) ram_mem[a] = (x)
 169
 170 #endif
 171
 172
 173 /*---------------------------------------------------------------------------*/
 174
 175 #ifdef PICOBOARD2
 176
 177 /* #if WORD_BITS == 8 */
 178 /* #endif */ // TODO useless
 179
 180 uint8 rom_get (rom_addr a)
 181 {
 182   return *(rom uint8*)a;
 183 }
 184
 185 #endif
 186
 187
 188 #ifdef WORKSTATION
 189
 190 #define ROM_BYTES 8192
 191 // TODO the new pics have 32k, change this ? minus the vm size, firmware ?
 192
 193 uint8 rom_mem[ROM_BYTES] =
 194   {
 195 #define RED_GREEN
 196 #define PUTCHAR_LIGHT_not
 197
 198 #ifdef RED_GREEN
 199     0xFB, 0xD7, 0x03, 0x00, 0x00, 0x00, 0x00, 0x32
 200     , 0x03, 0x00, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00
 201     , 0x08, 0x50, 0x80, 0x16, 0xFE, 0xE8, 0x00, 0xFC
 202     , 0x32, 0x80, 0x2D, 0xFE, 0xFC, 0x31, 0x80, 0x43
 203     , 0xFE, 0xFC, 0x33, 0x80, 0x2D, 0xFE, 0xFC, 0x31
 204     , 0x80, 0x43, 0xFE, 0x90, 0x16, 0x01, 0x20, 0xFC
 205     , 0x32, 0xE3, 0xB0, 0x37, 0x09, 0xF3, 0xFF, 0x20
 206     , 0xFC, 0x33, 0xE3, 0xB0, 0x40, 0x0A, 0xF3, 0xFF
 207     , 0x08, 0xF3, 0xFF, 0x01, 0x40, 0x21, 0xD1, 0x00
 208     , 0x02, 0xC0, 0x4C, 0x71, 0x01, 0x20, 0x50, 0x90
 209     , 0x51, 0x00, 0xF1, 0x40, 0xD8, 0xB0, 0x59, 0x90
 210     , 0x51, 0x00, 0xFF
 211 #endif
 212 #ifdef PUTCHAR_LIGHT
 213     0xFB, 0xD7, 0x00, 0x00, 0x80, 0x08, 0xFE, 0xE8
 214     , 0x00, 0xF6, 0xF5, 0x90, 0x08
 215 #endif
 216   };
 217
 218 uint8 rom_get (rom_addr a)
 219 {
 220   return rom_mem[a-CODE_START];
 221 }
 222
 223 #endif
 224
 225 /*---------------------------------------------------------------------------*/
 226
 227 /*
 228   OBJECT ENCODING:
 229
 230   #f           0
 231   #t           1
 232   ()           2
 233   fixnum n     MIN_FIXNUM -> 3 ... MAX_FIXNUM -> 3 + (MAX_FIXNUM-MIN_FIXNUM)
 234   rom object   4 + (MAX_FIXNUM-MIN_FIXNUM) ... MIN_RAM_ENCODING-1
 235   ram object   MIN_RAM_ENCODING ... MAX_RAM_ENCODING
 236   vector       MIN_VEC_ENCODING ... 8191
 237
 238   layout of memory allocated objects:
 239
 240   G's represent mark bits used by the gc
 241
 242   bignum n     00G00000 uuuuuuuu hhhhhhhh llllllll  (24 bit signed integer)
 243   TODO we could have 29-bit integers
 244
 245   pair         1GGaaaaa aaaaaaaa 000ddddd dddddddd
 246   a is car
 247   d is cdr
 248   gives an address space of 2^13 * 4 = 32k divided between simple objects,
 249   rom, ram and vectors
 250
 251   symbol       1GG00000 00000000 00100000 00000000
 252
 253   string       1GG***** *chars** 01000000 00000000
 254
 255   vector       1GG***** *elems** 01100000 00000000 TODO old
 256   vector       1GGxxxxx xxxxxxxx 011yyyyy yyyyyyyy
 257   x is length of the vector, in bytes (stored raw, not encoded as an object)
 258   y is pointer to the elements themselves (stored in vector space)
 259   TODO pointer could be shorter since it always points in vector space, same for length, will never be this long
 260   TODO show how vectors are represented in vector space
 261   TODO what kind of gc to have for vectors ? if we have a copying gc (which we argues against in the paper), we might need a header in vector space to point to the ram header, so it can update the pointer when the vector is copied
 262   TODO have a header with length here that points to vector space, or have the header in vector space, for now, header is in ordinary ram
 263   TODO how to deal with gc ? mayeb when we sweep a vector header, go sweep its contents in vector space ?
 264
 265   closure      01Gaaaaa aaaaaaaa aaaxxxxx xxxxxxxx
 266   0x5ff<a<0x4000 is entry
 267   x is pointer to environment
 268   the reason why the environment is on the cdr (and the entry is split on 3
 269   bytes) is that, when looking for a variable, a closure is considered to be a
 270   pair. The compiler adds an extra offset to any variable in the closure's
 271   environment, so the car of the closure (which doesn't really exist) is never
 272   checked, but the cdr is followed to find the other bindings
 273
 274   continuation 1GGxxxxx xxxxxxxx 100yyyyy yyyyyyyy
 275   x is parent continuation
 276   y is pointer to the second half, which is a closure (contains env and entry)
 277
 278   An environment is a list of objects built out of pairs.  On entry to
 279   a procedure the environment is the list of parameters to which is
 280   added the environment of the closure being called.
 281
 282   The first byte at the entry point of a procedure gives the arity of
 283   the procedure:
 284
 285   n = 0 to 127    -> procedure has n parameters (no rest parameter)
 286   n = -128 to -1  -> procedure has -n parameters, the last is
 287   a rest parameter
 288 */
 289
 290 #define OBJ_FALSE 0
 291 #define OBJ_TRUE  1
 292 #define OBJ_NULL  2
 293
 294 #define MIN_FIXNUM_ENCODING 3
 295 #define MIN_FIXNUM 0
 296 #define MAX_FIXNUM 255
 297 #define MIN_ROM_ENCODING (MIN_FIXNUM_ENCODING+MAX_FIXNUM-MIN_FIXNUM+1)
 298
 299 #define ENCODE_FIXNUM(n) ((obj)(n) + (MIN_FIXNUM_ENCODING - MIN_FIXNUM))
 300 #define DECODE_FIXNUM(o) ((int32)(o) - (MIN_FIXNUM_ENCODING - MIN_FIXNUM))
 301
 302 // TODO why this ifdef ?
 303 #if WORD_BITS == 8
 304 #define IN_VEC(o) ((o) >= MIN_VEC_ENCODING)
 305 #define IN_RAM(o) (!IN_VEC(o) && ((o) >= MIN_RAM_ENCODING))
 306 #define IN_ROM(o) (!IN_VEC(o) && !IN_RAM(o) && ((o) >= MIN_ROM_ENCODING))
 307 #endif
 308 // TODO performance ?
 309
 310 // bignum first byte : 00G00000
 311 #define BIGNUM_FIELD0 0
 312 #define RAM_BIGNUM(o) ((ram_get_field0 (o) & 0xc0) == BIGNUM_FIELD0)
 313 #define ROM_BIGNUM(o) ((rom_get_field0 (o) & 0xc0) == BIGNUM_FIELD0)
 314
 315 // composite first byte : 1GGxxxxx
 316 #define COMPOSITE_FIELD0 0x80
 317 #define RAM_COMPOSITE(o) ((ram_get_field0 (o) & 0x80) == COMPOSITE_FIELD0)
 318 #define ROM_COMPOSITE(o) ((rom_get_field0 (o) & 0x80) == COMPOSITE_FIELD0)
 319
 320 // pair third byte : 000xxxxx
 321 #define PAIR_FIELD2 0
 322 #define RAM_PAIR(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == PAIR_FIELD2))
 323 #define ROM_PAIR(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == PAIR_FIELD2))
 324
 325 // symbol third byte : 001xxxxx
 326 #define SYMBOL_FIELD2 0x20
 327 #define RAM_SYMBOL(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == SYMBOL_FIELD2))
 328 #define ROM_SYMBOL(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == SYMBOL_FIELD2))
 329
 330 // string third byte : 010xxxxx
 331 #define STRING_FIELD2 0x40
 332 #define RAM_STRING(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == STRING_FIELD2))
 333 #define ROM_STRING(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == STRING_FIELD2))
 334
 335 // vector third byte : 011xxxxx
 336 #define VECTOR_FIELD2 0x60
 337 #define RAM_VECTOR(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == VECTOR_FIELD2))
 338 #define ROM_VECTOR(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == VECTOR_FIELD2))
 339 // TODO this is only for headers
 340
 341 // continuation third byte : 100xxxxx
 342 #define CONTINUATION_FIELD2 0x80
 343 #define RAM_CONTINUATION(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == CONTINUATION_FIELD2))
 344 #define ROM_CONTINUATION(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == CONTINUATION_FIELD2))
 345
 346 // closure first byte : 01Gxxxxx
 347 #define CLOSURE_FIELD0 0x40
 348 #define RAM_CLOSURE(o) ((ram_get_field0 (o) & 0xc0) == CLOSURE_FIELD0)
 349 #define ROM_CLOSURE(o) ((rom_get_field0 (o) & 0xc0) == CLOSURE_FIELD0)
 350
 351
 352 /*---------------------------------------------------------------------------*/
 353
 354 #define RAM_GET_FIELD0_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,0))
 355 #define RAM_SET_FIELD0_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,0), val)
 356 #define ROM_GET_FIELD0_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,0))
 357
 358 #define RAM_GET_GC_TAGS_MACRO(o) (RAM_GET_FIELD0_MACRO(o) & 0x60)
 359 #define RAM_GET_GC_TAG0_MACRO(o) (RAM_GET_FIELD0_MACRO(o) & 0x20)
 360 #define RAM_GET_GC_TAG1_MACRO(o) (RAM_GET_FIELD0_MACRO(o) & 0x40)
 361 #define RAM_SET_GC_TAGS_MACRO(o,tags)                                      \
 362   (RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0x9f) | (tags)))
 363 #define RAM_SET_GC_TAG0_MACRO(o,tag)                                    \
 364   RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xdf) | (tag))
 365 #define RAM_SET_GC_TAG1_MACRO(o,tag)                                    \
 366   RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xbf) | (tag))
 367
 368 #if WORD_BITS == 8
 369 #define RAM_GET_FIELD1_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,1))
 370 #define RAM_GET_FIELD2_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,2))
 371 #define RAM_GET_FIELD3_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,3))
 372 #define RAM_SET_FIELD1_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,1), val)
 373 #define RAM_SET_FIELD2_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,2), val)
 374 #define RAM_SET_FIELD3_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,3), val)
 375 #define ROM_GET_FIELD1_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,1))
 376 #define ROM_GET_FIELD2_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,2))
 377 #define ROM_GET_FIELD3_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,3))
 378 #define VEC_GET_BYTE0_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,0))
 379 #define VEC_GET_BYTE1_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,1))
 380 #define VEC_GET_BYTE2_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,2))
 381 #define VEC_GET_BYTE3_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,3))
 382 #define VEC_SET_BYTE0_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,0), val)
 383 #define VEC_SET_BYTE1_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,1), val)
 384 #define VEC_SET_BYTE2_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,2), val)
 385 #define VEC_SET_BYTE3_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,3), val)
 386 // TODO put these in the ifdef ? and is the ifdef necessary ? are the vec macros necessary ? use the word field instead of byte, for consistency ?
 387 #endif
 388
 389 uint8 ram_get_gc_tags (obj o) { return RAM_GET_GC_TAGS_MACRO(o); }
 390 uint8 ram_get_gc_tag0 (obj o) { return RAM_GET_GC_TAG0_MACRO(o); }
 391 uint8 ram_get_gc_tag1 (obj o) { return RAM_GET_GC_TAG1_MACRO(o); }
 392 void ram_set_gc_tags  (obj o, uint8 tags) { RAM_SET_GC_TAGS_MACRO(o, tags); }
 393 void ram_set_gc_tag0 (obj o, uint8 tag) { RAM_SET_GC_TAG0_MACRO(o,tag); }
 394 void ram_set_gc_tag1 (obj o, uint8 tag) { RAM_SET_GC_TAG1_MACRO(o,tag); }
 395 uint8 ram_get_field0 (obj o) { return RAM_GET_FIELD0_MACRO(o); }
 396 word ram_get_field1 (obj o) { return RAM_GET_FIELD1_MACRO(o); }
 397 word ram_get_field2 (obj o) { return RAM_GET_FIELD2_MACRO(o); }
 398 word ram_get_field3 (obj o) { return RAM_GET_FIELD3_MACRO(o); }
 399 void ram_set_field0 (obj o, uint8 val) { RAM_SET_FIELD0_MACRO(o,val); }
 400 void ram_set_field1 (obj o, word val) { RAM_SET_FIELD1_MACRO(o,val); }
 401 void ram_set_field2 (obj o, word val) { RAM_SET_FIELD2_MACRO(o,val); }
 402 void ram_set_field3 (obj o, word val) { RAM_SET_FIELD3_MACRO(o,val); }
 403 uint8 rom_get_field0 (obj o) { return ROM_GET_FIELD0_MACRO(o); }
 404 word rom_get_field1 (obj o) { return ROM_GET_FIELD1_MACRO(o); }
 405 word rom_get_field2 (obj o) { return ROM_GET_FIELD2_MACRO(o); }
 406 word rom_get_field3 (obj o) { return ROM_GET_FIELD3_MACRO(o); }
 407 /* word vec_get_byte0 (obj o) { return VEC_GET_BYTE0_MACRO(o); } */
 408 /* word vec_get_byte1 (obj o) { return VEC_GET_BYTE1_MACRO(o); } */
 409 /* word vec_get_byte2 (obj o) { return VEC_GET_BYTE2_MACRO(o); } */
 410 /* word vec_get_byte3 (obj o) { return VEC_GET_BYTE3_MACRO(o); } */
 411 /* word vec_set_byte0 (obj o, word val) { VEC_SET_BYTE0_MACRO(o,val); } */
 412 /* word vec_set_byte1 (obj o, word val) { VEC_SET_BYTE1_MACRO(o,val); } */
 413 /* word vec_set_byte2 (obj o, word val) { VEC_SET_BYTE2_MACRO(o,val); } */
 414 /* word vec_set_byte3 (obj o, word val) { VEC_SET_BYTE3_MACRO(o,val); } */
 415 // TODO use the word field or byte ? actually the ram functions are used, since this is in ram anyways
 416
 417 obj ram_get_car (obj o)
 418 { return ((ram_get_field0 (o) & 0x1f) << 8) | ram_get_field1 (o); }
 419 obj rom_get_car (obj o)
 420 { return ((rom_get_field0 (o) & 0x1f) << 8) | rom_get_field1 (o); }
 421 obj ram_get_cdr (obj o)
 422 { return ((ram_get_field2 (o) & 0x1f) << 8) | ram_get_field3 (o); }
 423 obj rom_get_cdr (obj o)
 424 { return ((rom_get_field2 (o) & 0x1f) << 8) | rom_get_field3 (o); }
 425 void ram_set_car (obj o, obj val)
 426 {
 427   ram_set_field0 (o, (val >> 8) | (ram_get_field0 (o) & 0xe0));
 428   ram_set_field1 (o, val & 0xff);
 429 }
 430 void ram_set_cdr (obj o, obj val)
 431 {
 432   ram_set_field2 (o, (val >> 8) | (ram_get_field2 (o) & 0xe0));
 433   ram_set_field3 (o, val & 0xff);
 434 }
 435 obj ram_get_entry (obj o)
 436 {
 437   return (((ram_get_field0 (o) & 0x1f) << 11)
 438           | (ram_get_field1 (o) << 3)
 439           | (ram_get_field2 (o) >> 5));
 440 }
 441 obj rom_get_entry (obj o)
 442 {
 443   return (((rom_get_field0 (o) & 0x1f) << 11)
 444           | (rom_get_field1 (o) << 3)
 445           | (rom_get_field2 (o) >> 5));
 446 }
 447
 448 obj get_global (uint8 i)
 449 // globals occupy the beginning of ram, with 2 globals per word
 450 {
 451   if (i & 1)
 452     return ram_get_cdr (MIN_RAM_ENCODING + (i / 2));
 453   else
 454     return ram_get_car (MIN_RAM_ENCODING + (i / 2));
 455 }
 456
 457 void set_global (uint8 i, obj o)
 458 {
 459   if (i & 1)
 460     ram_set_cdr (MIN_RAM_ENCODING + (i / 2), o);
 461   else
 462     ram_set_car (MIN_RAM_ENCODING + (i / 2), o);
 463 }
 464
 465 #ifdef WORKSTATION
 466 void show_type (obj o) // for debugging purposes
 467   {
 468     printf("%d : ", o);
 469     if (o == OBJ_FALSE) printf("#f");
 470     else if (o == OBJ_TRUE) printf("#t");
 471     else if (o == OBJ_NULL) printf("()");
 472     else if (o < MIN_ROM_ENCODING) printf("fixnum");
 473     else if (IN_RAM (o))
 474       {
 475         if (RAM_BIGNUM(o)) printf("ram bignum");
 476         else if (RAM_PAIR(o)) printf("ram pair");
 477         else if (RAM_SYMBOL(o)) printf("ram symbol");
 478         else if (RAM_STRING(o)) printf("ram string");
 479         else if (RAM_VECTOR(o)) printf("ram vector");
 480         else if (RAM_CONTINUATION(o)) printf("ram continuation");
 481         else if (RAM_CLOSURE(o)) printf("ram closure");
 482       }
 483     else // ROM
 484       {
 485         if (ROM_BIGNUM(o)) printf("rom bignum");
 486         else if (ROM_PAIR(o)) printf("rom pair");
 487         else if (ROM_SYMBOL(o)) printf("rom symbol");
 488         else if (ROM_STRING(o)) printf("rom string");
 489         else if (ROM_VECTOR(o)) printf("rom vector");
 490         else if (ROM_CONTINUATION(o)) printf("rom continuation");
 491         else if (RAM_CLOSURE(o)) printf("rom closure");
 492       }
 493     printf("\n");
 494   }
 495 #endif
 496
 497
 498 /*---------------------------------------------------------------------------*/
 499
 500 /* Interface to GC */
 501
 502 // TODO explain what each tag means, with 1-2 mark bits
 503 #define GC_TAG_0_LEFT   (1<<5)
 504 // TODO was 3<<5, changed to play nice with procedures and bignums, but should actually set only this bit, not clear the other
 505 #define GC_TAG_1_LEFT   (2<<5)
 506 #define GC_TAG_UNMARKED (0<<5)
 507
 508 /* Number of object fields of objects in ram */
 509 #define HAS_2_OBJECT_FIELDS(visit) (RAM_PAIR(visit) || RAM_CONTINUATION(visit))
 510 #define HAS_1_OBJECT_FIELD(visit)  (RAM_COMPOSITE(visit) || RAM_CLOSURE(visit))
 511 // all composites except pairs and continuations have 1 object field
 512 // TODO if we ever have true bignums, bignums will have 1 object field
 513
 514 #define NIL OBJ_FALSE
 515
 516 /*---------------------------------------------------------------------------*/
 517
 518 /* Garbage collector */
 519
 520 obj free_list; /* list of unused cells */
 521 obj free_list_vec; /* list of unused cells in vector space */
 522
 523 obj arg1; /* root set */
 524 obj arg2;
 525 obj arg3;
 526 obj arg4;
 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 (((ram_get_cdr(o) * 4) - n) < 4) // TODO is there a better way ?
 858     {
 859       if (prec) // TODO does this mean that the free list nodes are in the same order as they are in memory ?
 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); // TODO use decode_2_int_args ? can't see why not
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   decode_2_int_args (); // arg1 is length, arg2 is contents
1301
1302   if (a2 > 255)
1303     ERROR("byte vectors can only contain bytes");
1304
1305   arg3 = alloc_vec_cell (a1);
1306   arg1 = alloc_ram_cell_init (COMPOSITE_FIELD0 | (a1 >> 8),
1307                               a1 & 0xff,
1308                               VECTOR_FIELD2 | (arg3 >> 8),
1309                               arg3 & 0xff);
1310
1311   a1 = (a1 + 3) / 4; // actual length, in words
1312   while (a1--)
1313     {
1314       ram_set_field0 (arg3, a2);
1315       ram_set_field1 (arg3, a2);
1316       ram_set_field2 (arg3, a2);
1317       ram_set_field3 (arg3, a2);
1318       arg3++;
1319     }
1320 }
1321
1322 void prim_u8vector_ref (void)
1323 { // TODO how do we deal with rom vectors ? as lists ? they're never all that long
1324   a2 = decode_int (arg2);
1325
1326   if (IN_RAM(arg1))
1327     {
1328       if (!RAM_VECTOR(arg1))
1329         TYPE_ERROR("u8vector-ref", "vector");
1330       if (ram_get_car (arg1) <= a2)
1331         ERROR("vector index too large");
1332       arg1 = ram_get_cdr (arg1);
1333     }
1334   else if (IN_ROM(arg1))
1335     {
1336       if (!ROM_VECTOR(arg1))
1337         TYPE_ERROR("u8vector-ref", "vector");
1338       a3 = rom_get_car (arg1); // we'll need the length later
1339       if (a3 <= a2)
1340         ERROR("vector index too large");
1341       arg1 = rom_get_cdr (arg1);
1342     }
1343   else
1344     TYPE_ERROR("u8vector-ref", "vector");
1345
1346   if (IN_VEC(arg1))
1347     {
1348       arg1 += (a2 / 4);
1349       a2 %= 4;
1350
1351       switch (a2)
1352         {
1353         case 0:
1354           arg1 = ram_get_field0 (arg1); break;
1355         case 1:
1356           arg1 = ram_get_field1 (arg1); break;
1357         case 2:
1358           arg1 = ram_get_field2 (arg1); break;
1359         case 3:
1360           arg1 = ram_get_field3 (arg1); break;
1361         }
1362
1363       arg1 = encode_int (arg1);
1364     }
1365   else // rom vector, stored as a list
1366     { // TODO since these are stored as lists, nothing prevents us from having ordinary vectors, and not just byte vectors. in rom, both are lists so they are the same. in ram, byte vectors are in vector space, while ordinary vectors are still lists (the functions are already in the library)
1367       a1 = a2; // we save the index
1368
1369       while (a2--)
1370         arg1 = rom_get_cdr (arg1);
1371
1372       // since rom vectors are dotted pairs, the last element is in cdr
1373       if (a1 < (a3 - 1))
1374         arg1 = rom_get_car (arg1);
1375     }
1376
1377   arg2 = OBJ_FALSE;
1378   arg3 = OBJ_FALSE;
1379   arg4 = OBJ_FALSE;
1380 }
1381
1382 void prim_u8vector_set (void)
1383 { // TODO a lot in common with ref, abstract that
1384   a2 = decode_int (arg2);
1385   a3 = decode_int (arg3);
1386
1387   if (a3 > 255)
1388     ERROR("byte vectors can only contain bytes");
1389
1390   if (IN_RAM(arg1))
1391     {
1392       if (!RAM_VECTOR(arg1))
1393         TYPE_ERROR("u8vector-set!", "vector");
1394       if (ram_get_car (arg1) <= a2)
1395         ERROR("vector index too large");
1396       arg1 = ram_get_cdr (arg1);
1397     }
1398   else
1399     TYPE_ERROR("u8vector-set!", "vector");
1400
1401   arg1 += (a2 / 4);
1402   a2 %= 4;
1403
1404   switch (a2)
1405     {
1406     case 0:
1407       ram_set_field0 (arg1, a3); break;
1408     case 1:
1409       ram_set_field1 (arg1, a3); break;
1410     case 2:
1411       ram_set_field2 (arg1, a3); break;
1412     case 3:
1413       ram_set_field3 (arg1, a3); break;
1414     }
1415
1416   arg1 = OBJ_FALSE;
1417   arg2 = OBJ_FALSE;
1418   arg3 = OBJ_FALSE;
1419 }
1420
1421 void prim_u8vector_length (void)
1422 {
1423   if (IN_RAM(arg1))
1424     {
1425       if (!RAM_VECTOR(arg1))
1426         TYPE_ERROR("u8vector-length", "vector");
1427       arg1 = encode_int (ram_get_car (arg1));
1428     }
1429   else if (IN_ROM(arg1))
1430     {
1431       if (!ROM_VECTOR(arg1))
1432         TYPE_ERROR("u8vector-length", "vector");
1433       arg1 = encode_int (rom_get_car (arg1));
1434     }
1435   else
1436     TYPE_ERROR("u8vector-length", "vector");
1437 }
1438
1439 /*---------------------------------------------------------------------------*/
1440
1441 /* Miscellaneous operations */
1442
1443 void prim_eqp (void)
1444 {
1445   arg1 = encode_bool (arg1 == arg2);
1446   arg2 = OBJ_FALSE;
1447 }
1448
1449 void prim_not (void)
1450 {
1451   arg1 = encode_bool (arg1 == OBJ_FALSE);
1452 }
1453
1454 void prim_symbolp (void)
1455 {
1456   if (IN_RAM(arg1))
1457     arg1 = encode_bool (RAM_SYMBOL(arg1));
1458   else if (IN_ROM(arg1))
1459     arg1 = encode_bool (ROM_SYMBOL(arg1));
1460   else
1461     arg1 = OBJ_FALSE;
1462 }
1463
1464 void prim_stringp (void)
1465 {
1466   if (IN_RAM(arg1))
1467     arg1 = encode_bool (RAM_STRING(arg1));
1468   else if (IN_ROM(arg1))
1469     arg1 = encode_bool (ROM_STRING(arg1));
1470   else
1471     arg1 = OBJ_FALSE;
1472 }
1473
1474 void prim_string2list (void)
1475 {
1476   if (IN_RAM(arg1))
1477     {
1478       if (!RAM_STRING(arg1))
1479         TYPE_ERROR("string->list", "string");
1480
1481       arg1 = ram_get_car (arg1);
1482     }
1483   else if (IN_ROM(arg1))
1484     {
1485       if (!ROM_STRING(arg1))
1486         TYPE_ERROR("string->list", "string");
1487
1488       arg1 = rom_get_car (arg1);
1489     }
1490   else
1491     TYPE_ERROR("string->list", "string");
1492 }
1493
1494 void prim_list2string (void)
1495 {
1496   arg1 = alloc_ram_cell_init (COMPOSITE_FIELD0 | ((arg1 & 0x1f00) >> 8),
1497                               arg1 & 0xff,
1498                               STRING_FIELD2,
1499                               0);
1500 }
1501
1502
1503 /*---------------------------------------------------------------------------*/
1504
1505 /* Robot specific operations */
1506
1507
1508 void prim_print (void)
1509 {
1510 #ifdef PICOBOARD2
1511 #endif
1512
1513 #ifdef WORKSTATION
1514
1515   print (arg1);
1516
1517 #endif
1518
1519   arg1 = OBJ_FALSE;
1520 }
1521
1522
1523 int32 read_clock (void)
1524 {
1525   int32 now = 0;
1526
1527 #ifdef PICOBOARD2
1528
1529   now = from_now( 0 );
1530
1531 #endif
1532
1533 #ifdef WORKSTATION
1534
1535 #ifdef _WIN32
1536
1537   static int32 start = 0;
1538   struct timeb tb;
1539
1540   ftime (&tb);
1541
1542   now = tb.time * 1000 + tb.millitm;
1543   if (start == 0)
1544     start = now;
1545   now -= start;
1546
1547 #else
1548
1549   static int32 start = 0;
1550   struct timeval tv;
1551
1552   if (gettimeofday (&tv, NULL) == 0)
1553     {
1554       now = tv.tv_sec * 1000 + tv.tv_usec / 1000;
1555       if (start == 0)
1556         start = now;
1557       now -= start;
1558     }
1559
1560 #endif
1561
1562 #endif
1563
1564   return now;
1565 }
1566
1567
1568 void prim_clock (void)
1569 {
1570   arg1 = encode_int (read_clock ());
1571 }
1572
1573
1574 void prim_motor (void)
1575 {
1576   decode_2_int_args ();
1577
1578   if (a1 < 1 || a1 > 2 || a2 < -100 || a2 > 100)
1579     ERROR("argument out of range to procedure \"motor\"");
1580
1581 #ifdef PICOBOARD2
1582
1583   fw_motor ();
1584
1585 #endif
1586
1587 #ifdef WORKSTATION
1588
1589   printf ("motor %d -> power=%d\n", a1, a2);
1590   fflush (stdout);
1591
1592 #endif
1593
1594   arg1 = OBJ_FALSE;
1595   arg2 = OBJ_FALSE;
1596 }
1597
1598
1599 void prim_led (void)
1600 {
1601   decode_2_int_args ();
1602   a3 = decode_int (arg3);
1603
1604   if (a1 < 1 || a1 > 3 || a2 < 0 || a3 < 0)
1605     ERROR("argument out of range to procedure \"led\"");
1606
1607 #ifdef PICOBOARD2
1608
1609   LED_set( a1, a2, a3 );
1610
1611 #endif
1612
1613 #ifdef WORKSTATION
1614
1615   printf ("led %d -> duty=%d period=%d\n", a1, a2, a3 );
1616   fflush (stdout);
1617
1618 #endif
1619
1620   arg1 = OBJ_FALSE;
1621   arg2 = OBJ_FALSE;
1622   arg3 = OBJ_FALSE;
1623 }
1624
1625
1626 void prim_led2_color (void)
1627 {
1628   a1 = decode_int (arg1);
1629
1630   if (a1 < 0 || a1 > 1)
1631     ERROR("argument out of range to procedure \"led2-color\"");
1632
1633 #ifdef PICOBOARD2
1634
1635   LED2_color_set( a1 );
1636
1637 #endif
1638
1639 #ifdef WORKSTATION
1640
1641   printf ("led2-color -> %s\n", (a1==0)?"green":"red");
1642   fflush (stdout);
1643
1644 #endif
1645
1646   arg1 = OBJ_FALSE;
1647 }
1648
1649
1650 void prim_getchar_wait (void)
1651 {
1652   decode_2_int_args();
1653   a1 = read_clock () + a1;
1654
1655   if (a1 < 0 || a2 < 1 || a2 > 3)
1656     ERROR("argument out of range to procedure \"getchar-wait\"");
1657
1658 #ifdef PICOBOARD2
1659
1660   arg1 = OBJ_FALSE;
1661
1662   {
1663     serial_port_set ports;
1664     ports = serial_rx_wait_with_timeout( a2, a1 );
1665     if (ports != 0)
1666       arg1 = encode_int (serial_rx_read( ports ));
1667   }
1668
1669 #endif
1670
1671 #ifdef WORKSTATION
1672
1673 #ifdef _WIN32
1674
1675   arg1 = OBJ_FALSE;
1676
1677   do
1678     {
1679       if (_kbhit ())
1680         {
1681           arg1 = encode_int (_getch ());
1682           break;
1683         }
1684     } while (read_clock () < a1);
1685
1686
1687 #else
1688
1689   arg1 = encode_int (getchar ());
1690
1691 #endif
1692
1693 #endif
1694 }
1695
1696
1697 void prim_putchar (void)
1698 {
1699   decode_2_int_args ();
1700
1701   if (a1 < 0 || a1 > 255 || a2 < 1 || a2 > 3)
1702     ERROR("argument out of range to procedure \"putchar\"");
1703
1704 #ifdef PICOBOARD2
1705
1706   serial_tx_write( a2, a1 );
1707
1708 #endif
1709
1710 #ifdef WORKSTATION
1711
1712   putchar (a1);
1713   fflush (stdout);
1714
1715 #endif
1716
1717   arg1 = OBJ_FALSE;
1718   arg2 = OBJ_FALSE;
1719 }
1720
1721
1722 void prim_beep (void)
1723 {
1724   decode_2_int_args ();
1725
1726   if (a1 < 1 || a1 > 255 || a2 < 0)
1727     ERROR("argument out of range to procedure \"beep\"");
1728
1729 #ifdef PICOBOARD2
1730
1731   beep( a1, from_now( a2 ) );
1732
1733 #endif
1734
1735 #ifdef WORKSTATION
1736
1737   printf ("beep -> freq-div=%d duration=%d\n", a1, a2 );
1738   fflush (stdout);
1739
1740 #endif
1741
1742   arg1 = OBJ_FALSE;
1743   arg2 = OBJ_FALSE;
1744 }
1745
1746
1747 void prim_adc (void)
1748 {
1749   short x;
1750
1751   a1 = decode_int (arg1);
1752
1753   if (a1 < 1 || a1 > 3)
1754     ERROR("argument out of range to procedure \"adc\"");
1755
1756 #ifdef PICOBOARD2
1757
1758   x = adc( a1 );
1759
1760 #endif
1761
1762 #ifdef WORKSTATION
1763
1764   x = read_clock () & 255;
1765
1766   if (x > 127) x = 256 - x;
1767
1768   x += 200;
1769
1770 #endif
1771
1772   arg1 = encode_int (x);
1773 }
1774
1775
1776 void prim_dac (void)
1777 {
1778   a1 = decode_int (arg1);
1779
1780   if (a1 < 0 || a1 > 255)
1781     ERROR("argument out of range to procedure \"dac\"");
1782
1783 #ifdef PICOBOARD2
1784
1785   dac( a1 );
1786
1787 #endif
1788
1789 #ifdef WORKSTATION
1790
1791   printf ("dac -> %d\n", a1 );
1792   fflush (stdout);
1793
1794 #endif
1795
1796   arg1 = OBJ_FALSE;
1797 }
1798
1799
1800 void prim_sernum (void)
1801 {
1802   short x;
1803
1804 #ifdef PICOBOARD2
1805
1806   x = serial_num ();
1807
1808 #endif
1809
1810 #ifdef WORKSTATION
1811
1812   x = 0;
1813
1814 #endif
1815
1816   arg1 = encode_int (x);
1817 }
1818
1819
1820 /*---------------------------------------------------------------------------*/
1821
1822 #ifdef WORKSTATION
1823
1824 int hidden_fgetc (FILE *f)
1825 {
1826   int c = fgetc (f);
1827 #if 0
1828   printf ("{%d}",c);
1829   fflush (stdout);
1830 #endif
1831   return c;
1832 }
1833
1834 #define fgetc(f) hidden_fgetc(f)
1835
1836 void write_hex_nibble (int n)
1837 {
1838   putchar ("0123456789ABCDEF"[n]);
1839 }
1840
1841 void write_hex (uint8 n)
1842 {
1843   write_hex_nibble (n >> 4);
1844   write_hex_nibble (n & 0x0f);
1845 }
1846
1847 int hex (int c)
1848 {
1849   if (c >= '0' && c <= '9')
1850     return (c - '0');
1851
1852   if (c >= 'A' && c <= 'F')
1853     return (c - 'A' + 10);
1854
1855   if (c >= 'a' && c <= 'f')
1856     return (c - 'a' + 10);
1857
1858   return -1;
1859 }
1860
1861 int read_hex_byte (FILE *f)
1862 {
1863   int h1 = hex (fgetc (f));
1864   int h2 = hex (fgetc (f));
1865
1866   if (h1 >= 0 && h2 >= 0)
1867     return (h1<<4) + h2;
1868
1869   return -1;
1870 }
1871
1872 int read_hex_file (char *filename)
1873 {
1874   int c;
1875   FILE *f = fopen (filename, "r");
1876   int result = 0;
1877   int len;
1878   int a, a1, a2;
1879   int t;
1880   int b;
1881   int i;
1882   uint8 sum;
1883   int hi16 = 0;
1884
1885   for (i=0; i<ROM_BYTES; i++)
1886     rom_mem[i] = 0xff;
1887
1888   if (f != NULL)
1889     {
1890       while ((c = fgetc (f)) != EOF)
1891         {
1892           if ((c == '\r') || (c == '\n'))
1893             continue;
1894
1895           if (c != ':' ||
1896               (len = read_hex_byte (f)) < 0 ||
1897               (a1 = read_hex_byte (f)) < 0 ||
1898               (a2 = read_hex_byte (f)) < 0 ||
1899               (t = read_hex_byte (f)) < 0)
1900             break;
1901
1902           a = (a1 << 8) + a2;
1903
1904           i = 0;
1905           sum = len + a1 + a2 + t;
1906
1907           if (t == 0)
1908             {
1909             next0:
1910
1911               if (i < len)
1912                 {
1913                   unsigned long adr = ((unsigned long)hi16 << 16) + a - CODE_START;
1914
1915                   if ((b = read_hex_byte (f)) < 0)
1916                     break;
1917
1918                   if (adr >= 0 && adr < ROM_BYTES)
1919                     rom_mem[adr] = b;
1920
1921                   a = (a + 1) & 0xffff;
1922                   i++;
1923                   sum += b;
1924
1925                   goto next0;
1926                 }
1927             }
1928           else if (t == 1)
1929             {
1930               if (len != 0)
1931                 break;
1932             }
1933           else if (t == 4)
1934             {
1935               if (len != 2)
1936                 break;
1937
1938               if ((a1 = read_hex_byte (f)) < 0 ||
1939                   (a2 = read_hex_byte (f)) < 0)
1940                 break;
1941
1942               sum += a1 + a2;
1943
1944               hi16 = (a1<<8) + a2;
1945             }
1946           else
1947             break;
1948
1949           if ((b = read_hex_byte (f)) < 0)
1950             break;
1951
1952           sum = -sum;
1953
1954           if (sum != b)
1955             {
1956               printf ("*** HEX file checksum error (expected 0x%02x)\n", sum);
1957               break;
1958             }
1959
1960           c = fgetc (f);
1961
1962           if ((c != '\r') && (c != '\n'))
1963             break;
1964
1965           if (t == 1)
1966             {
1967               result = 1;
1968               break;
1969             }
1970         }
1971
1972       if (result == 0)
1973         printf ("*** HEX file syntax error\n");
1974
1975       fclose (f);
1976     }
1977
1978   return result;
1979 }
1980
1981 #endif
1982
1983 /*---------------------------------------------------------------------------*/
1984
1985 #define FETCH_NEXT_BYTECODE() bytecode = rom_get (pc++)
1986
1987 #define BEGIN_DISPATCH()                        \
1988   dispatch:                                     \
1989   IF_TRACE(show_state (pc));                    \
1990   FETCH_NEXT_BYTECODE();                        \
1991   bytecode_hi4 = bytecode & 0xf0;               \
1992   bytecode_lo4 = bytecode & 0x0f;               \
1993   switch (bytecode_hi4 >> 4) {
1994
1995 #define END_DISPATCH() }
1996
1997 #define CASE(opcode) case (opcode>>4):;
1998
1999 #define DISPATCH(); goto dispatch;
2000
2001 #if 0
2002 #define pc FSR1
2003 #define sp FSR2
2004 #define bytecode TABLAT
2005 #define bytecode_hi4 WREG
2006 #endif
2007
2008 #define PUSH_CONSTANT1     0x00
2009 #define PUSH_CONSTANT2     0x10
2010 #define PUSH_STACK1        0x20
2011 #define PUSH_STACK2        0x30
2012 #define PUSH_GLOBAL        0x40
2013 #define SET_GLOBAL         0x50
2014 #define CALL               0x60
2015 #define JUMP               0x70
2016 #define LABEL_INSTR        0x80
2017 #define PUSH_CONSTANT_LONG 0x90
2018
2019 // TODO these are free
2020 #define GOTO               0xa0
2021 #define GOTO_IF_FALSE      0xb0
2022 #define CLOSURE            0xc0
2023
2024 #define PRIM1              0xd0
2025 #define PRIM2              0xe0
2026 #define PRIM3              0xf0
2027
2028 #ifdef WORKSTATION
2029
2030 char *prim_name[48] =
2031   {
2032     "prim #%number?",
2033     "prim #%+",
2034     "prim #%-",
2035     "prim #%*",
2036     "prim #%quotient",
2037     "prim #%remainder",
2038     "prim #%neg",
2039     "prim #%=",
2040     "prim #%<",
2041     "prim #%ior",
2042     "prim #%>",
2043     "prim #%xor",
2044     "prim #%pair?",
2045     "prim #%cons",
2046     "prim #%car",
2047     "prim #%cdr",
2048     "prim #%set-car!",
2049     "prim #%set-cdr!",
2050     "prim #%null?",
2051     "prim #%eq?",
2052     "prim #%not",
2053     "prim #%get-cont",
2054     "prim #%graft-to-cont",
2055     "prim #%return-to-cont",
2056     "prim #%halt",
2057     "prim #%symbol?",
2058     "prim #%string?",
2059     "prim #%string->list",
2060     "prim #%list->string",
2061     "prim #%make-u8vector", // TODO was prim29
2062     "prim #%u8vector-ref", // TODO was prim30
2063     "prim #%u8vector-set!", // TODO was prim31
2064     "prim #%print",
2065     "prim #%clock",
2066     "prim #%motor",
2067     "prim #%led",
2068     "prim #%led2-color",
2069     "prim #%getchar-wait",
2070     "prim #%putchar",
2071     "prim #%beep",
2072     "prim #%adc",
2073     "prim #%u8vector?", // TODO was dac, but it's not plugged to anything
2074     "prim #%sernum",
2075     "prim #%u8vector-length", // TODO was prim43
2076     "push-constant [long]",
2077     "shift",
2078     "pop",
2079     "return",
2080   };
2081
2082 #endif
2083
2084 #define PUSH_ARG1() push_arg1 ()
2085 #define POP() pop()
2086
2087 void push_arg1 (void)
2088 {
2089   env = cons (arg1, env);
2090   arg1 = OBJ_FALSE;
2091 }
2092
2093 obj pop (void)
2094 {
2095   obj o = ram_get_car (env);
2096   env = ram_get_cdr (env);
2097   return o;
2098 }
2099
2100 void pop_procedure (void)
2101 {
2102   arg1 = POP();
2103
2104   if (IN_RAM(arg1))
2105     {
2106       if (!RAM_CLOSURE(arg1))
2107         TYPE_ERROR("pop_procedure", "procedure");
2108
2109       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
2110     }
2111   else if (IN_ROM(arg1))
2112     {
2113       if (!ROM_CLOSURE(arg1))
2114         TYPE_ERROR("pop_procedure", "procedure");
2115
2116       entry = rom_get_entry (arg1) + CODE_START;
2117     }
2118   else
2119     TYPE_ERROR("pop_procedure", "procedure");
2120 }
2121
2122 void handle_arity_and_rest_param (void)
2123 {
2124   uint8 np;
2125
2126   np = rom_get (entry++);
2127
2128   if ((np & 0x80) == 0)
2129     {
2130       if (na != np)
2131         ERROR("wrong number of arguments");
2132     }
2133   else
2134     {
2135       np = ~np;
2136
2137       if (na < np)
2138         ERROR("wrong number of arguments");
2139
2140       arg3 = OBJ_NULL;
2141
2142       while (na > np)
2143         {
2144           arg4 = POP();
2145
2146           arg3 = cons (arg4, arg3);
2147           arg4 = OBJ_FALSE;
2148
2149           na--;
2150         }
2151
2152       arg1 = cons (arg3, arg1);
2153       arg3 = OBJ_FALSE;
2154     }
2155 }
2156
2157 void build_env (void)
2158 {
2159   while (na != 0)
2160     {
2161       arg3 = POP();
2162
2163       arg1 = cons (arg3, arg1);
2164
2165       na--;
2166     }
2167
2168   arg3 = OBJ_FALSE;
2169 }
2170
2171 void save_cont (void)
2172 {
2173   // the second half is a closure
2174   arg3 = alloc_ram_cell_init (CLOSURE_FIELD0 | (pc >> 11),
2175                               (pc >> 3) & 0xff,
2176                               ((pc & 0x0007) << 5) | (env >> 8),
2177                               env & 0xff);
2178   cont = alloc_ram_cell_init (COMPOSITE_FIELD0 | (cont >> 8),
2179                               cont & 0xff,
2180                               CONTINUATION_FIELD2 | (arg3 >> 8),
2181                               arg3 & 0xff);
2182   arg3 = OBJ_FALSE;
2183 }
2184
2185 void interpreter (void)
2186 {
2187   pc = (CODE_START + 4) + ((rom_addr)rom_get (CODE_START+2) << 2);
2188
2189   glovars = rom_get (CODE_START+3); // number of global variables
2190
2191   init_ram_heap ();
2192
2193   BEGIN_DISPATCH();
2194
2195   /***************************************************************************/
2196   CASE(PUSH_CONSTANT1);
2197
2198   IF_TRACE(printf("  (push-constant "); show (bytecode_lo4); printf (")\n"));
2199
2200   arg1 = bytecode_lo4;
2201
2202   PUSH_ARG1();
2203
2204   DISPATCH();
2205
2206   /***************************************************************************/
2207   CASE(PUSH_CONSTANT2);
2208
2209   IF_TRACE(printf("  (push-constant "); show (bytecode_lo4+16); printf (")\n"));
2210   arg1 = bytecode_lo4+16;
2211
2212   PUSH_ARG1();
2213
2214   DISPATCH();
2215
2216   /***************************************************************************/
2217   CASE(PUSH_STACK1);
2218
2219   IF_TRACE(printf("  (push-stack %d)\n", bytecode_lo4));
2220
2221   arg1 = env;
2222
2223   while (bytecode_lo4 != 0)
2224     {
2225       arg1 = ram_get_cdr (arg1);
2226       bytecode_lo4--;
2227     }
2228
2229   arg1 = ram_get_car (arg1);
2230
2231   PUSH_ARG1();
2232
2233   DISPATCH();
2234
2235   /***************************************************************************/
2236   CASE(PUSH_STACK2);
2237
2238   IF_TRACE(printf("  (push-stack %d)\n", bytecode_lo4+16));
2239   // TODO does this ever happens ?
2240   bytecode_lo4 += 16;
2241
2242   arg1 = env;
2243
2244   while (bytecode_lo4 != 0)
2245     {
2246       arg1 = ram_get_cdr (arg1);
2247       bytecode_lo4--;
2248     }
2249
2250   arg1 = ram_get_car (arg1);
2251
2252   PUSH_ARG1();
2253
2254   DISPATCH();
2255
2256   /***************************************************************************/
2257   CASE(PUSH_GLOBAL);
2258
2259   IF_TRACE(printf("  (push-global %d)\n", bytecode_lo4));
2260
2261   arg1 = get_global (bytecode_lo4);
2262
2263   PUSH_ARG1();
2264
2265   DISPATCH();
2266
2267   /***************************************************************************/
2268   CASE(SET_GLOBAL);
2269
2270   IF_TRACE(printf("  (set-global %d)\n", bytecode_lo4));
2271
2272   set_global (bytecode_lo4, POP()); // TODO debug
2273
2274   DISPATCH();
2275
2276   /***************************************************************************/
2277   CASE(CALL);
2278
2279   IF_TRACE(printf("  (call %d)\n", bytecode_lo4));
2280
2281   na = bytecode_lo4;
2282
2283   pop_procedure ();
2284   handle_arity_and_rest_param ();
2285   build_env ();
2286   save_cont ();
2287
2288   env = arg1;
2289   pc = entry;
2290
2291   arg1 = OBJ_FALSE;
2292
2293   DISPATCH();
2294
2295   /***************************************************************************/
2296   CASE(JUMP);
2297
2298   IF_TRACE(printf("  (jump %d)\n", bytecode_lo4));
2299
2300   na = bytecode_lo4;
2301
2302   pop_procedure ();
2303   handle_arity_and_rest_param ();
2304   build_env ();
2305
2306   env = arg1;
2307   pc = entry;
2308
2309   arg1 = OBJ_FALSE;
2310
2311   DISPATCH();
2312
2313   /***************************************************************************/
2314   CASE(LABEL_INSTR);
2315
2316   switch (bytecode_lo4)
2317     {
2318     case 0: // call-toplevel TODO put these in separate functions ?
2319       FETCH_NEXT_BYTECODE();
2320       arg2 = bytecode;
2321
2322       FETCH_NEXT_BYTECODE();
2323
2324       IF_TRACE(printf("  (call-toplevel 0x%04x)\n",
2325                       ((arg2 << 8) | bytecode) + CODE_START));
2326
2327       entry = (arg2 << 8) + bytecode + CODE_START;
2328       arg1 = OBJ_NULL;
2329
2330       na = rom_get (entry++);
2331
2332       build_env ();
2333       save_cont ();
2334
2335       env = arg1;
2336       pc = entry;
2337
2338       arg1 = OBJ_FALSE;
2339       arg2 = OBJ_FALSE;
2340
2341       break;
2342
2343     case 1: // jump-toplevel
2344       FETCH_NEXT_BYTECODE();
2345       arg2 = bytecode;
2346
2347       FETCH_NEXT_BYTECODE();
2348
2349       IF_TRACE(printf("  (jump-toplevel 0x%04x)\n",
2350                       ((arg2 << 8) | bytecode) + CODE_START));
2351
2352       entry = (arg2 << 8) + bytecode + CODE_START; // TODO this is a common pattern
2353       arg1 = OBJ_NULL;
2354
2355       na = rom_get (entry++);
2356
2357       build_env ();
2358
2359       env = arg1;
2360       pc = entry;
2361
2362       arg1 = OBJ_FALSE;
2363       arg2 = OBJ_FALSE;
2364
2365       break;
2366
2367     case 2: // goto
2368       FETCH_NEXT_BYTECODE();
2369       arg2 = bytecode;
2370
2371       FETCH_NEXT_BYTECODE();
2372
2373       IF_TRACE(printf("  (goto 0x%04x)\n",
2374                       (arg2 << 8) + bytecode + CODE_START));
2375
2376       pc = (arg2 << 8) + bytecode + CODE_START;
2377
2378       break;
2379
2380     case 3: // goto-if-false
2381       FETCH_NEXT_BYTECODE();
2382       arg2 = bytecode;
2383
2384       FETCH_NEXT_BYTECODE();
2385
2386       IF_TRACE(printf("  (goto-if-false 0x%04x)\n",
2387                       (arg2 << 8) + bytecode + CODE_START));
2388
2389       if (POP() == OBJ_FALSE)
2390         pc = (arg2 << 8) + bytecode + CODE_START;
2391
2392       break;
2393
2394     case 4: // closure
2395       FETCH_NEXT_BYTECODE();
2396       arg2 = bytecode;
2397
2398       FETCH_NEXT_BYTECODE();
2399
2400       IF_TRACE(printf("  (closure 0x%04x)\n", (arg2 << 8) | bytecode));
2401
2402       arg3 = POP(); // env
2403
2404       entry = (arg2 << 8) | bytecode;
2405
2406       arg1 = alloc_ram_cell_init (CLOSURE_FIELD0 | (arg2 >> 3),
2407                                   ((arg2 & 0x07) << 5) | (bytecode >> 3),
2408                                   ((bytecode &0x07) <<5) |((arg3 &0x1f00) >>8),
2409                                   arg3 & 0xff);
2410
2411       PUSH_ARG1();
2412
2413       arg2 = OBJ_FALSE;
2414       arg3 = OBJ_FALSE;
2415
2416       break;
2417
2418     case 5: // call-toplevel-short
2419       FETCH_NEXT_BYTECODE(); // TODO the sort version have a lot in common with the long ones, abstract ?
2420       // TODO short instructions don't work at the moment
2421       IF_TRACE(printf("  (call-toplevel-short 0x%04x)\n",
2422                       pc + bytecode + CODE_START));
2423
2424       entry = pc + bytecode + CODE_START;
2425       arg1 = OBJ_NULL;
2426
2427       na = rom_get (entry++);
2428
2429       build_env ();
2430       save_cont ();
2431
2432       env = arg1;
2433       pc = entry;
2434
2435       arg1 = OBJ_FALSE;
2436
2437       break;
2438
2439     case 6: // jump-toplevel-short
2440       FETCH_NEXT_BYTECODE();
2441
2442       IF_TRACE(printf("  (jump-toplevel-short 0x%04x)\n",
2443                       pc + bytecode + CODE_START));
2444
2445       entry = pc + bytecode + CODE_START;
2446       arg1 = OBJ_NULL;
2447
2448       na = rom_get (entry++);
2449
2450       build_env ();
2451
2452       env = arg1;
2453       pc = entry;
2454
2455       arg1 = OBJ_FALSE;
2456
2457       break;
2458
2459     case 7: // goto-short
2460       FETCH_NEXT_BYTECODE();
2461
2462       IF_TRACE(printf("  (goto-short 0x%04x)\n", pc + bytecode + CODE_START));
2463
2464       pc = pc + bytecode + CODE_START;
2465
2466       break;
2467
2468     case 8: // goto-if-false-short
2469       FETCH_NEXT_BYTECODE();
2470
2471       IF_TRACE(printf("  (goto-if-false-short 0x%04x)\n",
2472                       pc + bytecode + CODE_START));
2473
2474       if (POP() == OBJ_FALSE)
2475         pc = pc + bytecode + CODE_START;
2476
2477       break;
2478
2479     case 9: // closure-short TODO I doubt these short instrs will have great effect, and this is the one I doubt the most about
2480       FETCH_NEXT_BYTECODE();
2481
2482       IF_TRACE(printf("  (closure-short 0x%04x)\n", pc + bytecode));
2483
2484       arg3 = POP(); // env
2485
2486       entry = pc + bytecode; // TODO makes sense for a closure ?
2487
2488       arg1 = alloc_ram_cell_init (CLOSURE_FIELD0 | (arg2 >> 3),
2489                                   ((arg2 & 0x07) << 5) | (bytecode >> 3),
2490                                   ((bytecode &0x07) <<5) |((arg3 &0x1f00) >>8),
2491                                   arg3 & 0xff);
2492
2493       PUSH_ARG1();
2494
2495       arg3 = OBJ_FALSE;
2496
2497       break;
2498
2499 #if 0
2500     case 10:
2501       break;
2502     case 11:
2503       break;
2504     case 12:
2505       break;
2506     case 13:
2507       break;
2508 #endif
2509     case 14: // push_global [long]
2510       FETCH_NEXT_BYTECODE();
2511
2512       IF_TRACE(printf("  (push-global [long] %d)\n", bytecode));
2513
2514       arg1 = get_global (bytecode);
2515
2516       PUSH_ARG1();
2517
2518       break;
2519
2520     case 15: // set_global [long]
2521       FETCH_NEXT_BYTECODE();
2522
2523       IF_TRACE(printf("  (set-global [long] %d)\n", bytecode));
2524
2525       set_global (bytecode, POP());
2526
2527       break;
2528     }
2529
2530   DISPATCH();
2531
2532   /***************************************************************************/
2533   CASE(PUSH_CONSTANT_LONG);
2534
2535   /* push-constant [long] */
2536
2537   FETCH_NEXT_BYTECODE();
2538
2539   IF_TRACE(printf("  (push [long] 0x%04x)\n", (bytecode_lo4 << 8) + bytecode));
2540
2541   arg1 = (bytecode_lo4 << 8) | bytecode;
2542   PUSH_ARG1();
2543
2544   DISPATCH();
2545
2546   /***************************************************************************/
2547   CASE(GOTO); // BREGG move
2548
2549   DISPATCH();
2550
2551   /***************************************************************************/
2552   CASE(GOTO_IF_FALSE); // BREGG move
2553
2554   DISPATCH();
2555
2556   /***************************************************************************/
2557   CASE(CLOSURE); // BREGG move
2558
2559   DISPATCH();
2560
2561   /***************************************************************************/
2562   CASE(PRIM1);
2563
2564   IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4]));
2565
2566   switch (bytecode_lo4)
2567     {
2568     case 0:
2569       arg1 = POP();  prim_numberp ();  PUSH_ARG1();  break;
2570     case 1:
2571       arg2 = POP();  arg1 = POP();  prim_add ();      PUSH_ARG1();  break;
2572     case 2:
2573       arg2 = POP();  arg1 = POP();  prim_sub ();      PUSH_ARG1();  break;
2574     case 3:
2575       arg2 = POP();  arg1 = POP();  prim_mul ();      PUSH_ARG1();  break;
2576     case 4:
2577       arg2 = POP();  arg1 = POP();  prim_div ();      PUSH_ARG1();  break;
2578     case 5:
2579       arg2 = POP();  arg1 = POP();  prim_rem ();      PUSH_ARG1();  break;
2580     case 6:
2581       arg1 = POP();  prim_neg ();      PUSH_ARG1();  break;
2582     case 7:
2583       arg2 = POP();  arg1 = POP();  prim_eq ();       PUSH_ARG1();  break;
2584     case 8:
2585       arg2 = POP();  arg1 = POP();  prim_lt ();       PUSH_ARG1();  break;
2586     case 9:
2587       arg2 = POP(); arg1 = POP(); prim_ior (); PUSH_ARG1(); break;
2588     case 10:
2589       arg2 = POP();  arg1 = POP();  prim_gt ();       PUSH_ARG1();  break;
2590     case 11:
2591       arg2 = POP(); arg1 = POP(); prim_xor (); PUSH_ARG1(); break;
2592     case 12:
2593       arg1 = POP();  prim_pairp ();    PUSH_ARG1();  break;
2594     case 13:
2595       arg2 = POP();  arg1 = POP();  prim_cons ();     PUSH_ARG1();  break;
2596     case 14:
2597       arg1 = POP();  prim_car ();      PUSH_ARG1();  break;
2598     case 15:
2599       arg1 = POP();  prim_cdr ();      PUSH_ARG1();  break;
2600     }
2601
2602   DISPATCH();
2603
2604   /***************************************************************************/
2605   CASE(PRIM2);
2606
2607   IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4+16]));
2608
2609   switch (bytecode_lo4)
2610     {
2611     case 0:
2612       arg2 = POP();  arg1 = POP();  prim_set_car ();                break;
2613     case 1:
2614       arg2 = POP();  arg1 = POP();  prim_set_cdr ();                break;
2615     case 2:
2616       arg1 = POP();  prim_nullp ();    PUSH_ARG1();  break;
2617     case 3:
2618       arg2 = POP();  arg1 = POP();  prim_eqp ();      PUSH_ARG1();  break;
2619     case 4:
2620       arg1 = POP();  prim_not ();      PUSH_ARG1();  break;
2621     case 5:
2622       /* prim #%get-cont */
2623       arg1 = cont;
2624       PUSH_ARG1();
2625       break;
2626     case 6:
2627       /* prim #%graft-to-cont */
2628
2629       arg1 = POP(); /* thunk to call */
2630       cont = POP(); /* continuation */
2631
2632       PUSH_ARG1();
2633
2634       na = 0;
2635
2636       pop_procedure ();
2637       handle_arity_and_rest_param ();
2638       build_env ();
2639
2640       env = arg1;
2641       pc = entry;
2642
2643       arg1 = OBJ_FALSE;
2644
2645       break;
2646     case 7:
2647       /* prim #%return-to-cont */
2648
2649       arg1 = POP(); /* value to return */
2650       cont = POP(); /* continuation */
2651
2652       arg2 = ram_get_cdr (cont);
2653
2654       pc = ram_get_entry (arg2);
2655
2656       env = ram_get_cdr (arg2);
2657       cont = ram_get_car (cont);
2658
2659       PUSH_ARG1();
2660       arg2 = OBJ_FALSE;
2661
2662       break;
2663     case 8:
2664       /* prim #%halt */
2665       return;
2666     case 9:
2667       /* prim #%symbol? */
2668       arg1 = POP();  prim_symbolp ();  PUSH_ARG1();  break;
2669     case 10:
2670       /* prim #%string? */
2671       arg1 = POP();  prim_stringp ();  PUSH_ARG1();  break;
2672     case 11:
2673       /* prim #%string->list */
2674       arg1 = POP();  prim_string2list ();  PUSH_ARG1();  break;
2675     case 12:
2676       /* prim #%list->string */
2677       arg1 = POP();  prim_list2string ();  PUSH_ARG1();  break;
2678     case 13:
2679       /* prim #%make-u8vector */
2680       arg2 = POP(); arg1 = POP(); prim_make_u8vector (); PUSH_ARG1(); break;
2681     case 14:
2682       /* prim #%u8vector-ref */
2683       arg2 = POP(); arg1 = POP(); prim_u8vector_ref (); PUSH_ARG1(); break;
2684     case 15:
2685       /* prim #%u8vector-set! */
2686       arg3 = POP(); arg2 = POP(); arg1 = POP(); prim_u8vector_set (); break;
2687     }
2688
2689   DISPATCH();
2690
2691   /***************************************************************************/
2692   CASE(PRIM3);
2693
2694   IF_TRACE(printf("  (%s)\n", prim_name[bytecode_lo4+32]));
2695
2696   switch (bytecode_lo4)
2697     {
2698     case 0:
2699       /* prim #%print */
2700       arg1 = POP();
2701       prim_print ();
2702       break;
2703     case 1:
2704       /* prim #%clock */
2705       prim_clock ();  PUSH_ARG1();  break;
2706     case 2:
2707       /* prim #%motor */
2708       arg2 = POP();  arg1 = POP();  prim_motor ();  break;
2709     case 3:
2710       /* prim #%led */
2711       arg3 = POP();  arg2 = POP();  arg1 = POP();  prim_led ();  ;break;
2712     case 4:
2713       /* prim #%led2-color */
2714       arg1 = POP();  prim_led2_color ();  break;
2715     case 5:
2716       /* prim #%getchar-wait */
2717       arg2 = POP();  arg1 = POP();  prim_getchar_wait ();  PUSH_ARG1();  break;
2718     case 6:
2719       /* prim #%putchar */
2720       arg2 = POP();  arg1 = POP();  prim_putchar ();  break;
2721     case 7:
2722       /* prim #%beep */
2723       arg2 = POP();  arg1 = POP();  prim_beep ();  break;
2724     case 8:
2725       /* prim #%adc */
2726       arg1 = POP();  prim_adc ();  PUSH_ARG1();  break;
2727     case 9:
2728       /* prim #%u8vector? */
2729       arg1 = POP(); prim_u8vectorp (); PUSH_ARG1(); break;
2730     case 10:
2731       /* prim #%sernum */
2732       prim_sernum ();  PUSH_ARG1();  break;
2733     case 11:
2734       /* prim #%u8vector-length */
2735       arg1 = POP(); prim_u8vector_length (); PUSH_ARG1(); break;
2736     case 12:
2737       // FREE find something to do with this
2738       break;
2739     case 13:
2740       /* shift */
2741       arg1 = POP();
2742       POP();
2743       PUSH_ARG1();
2744       break;
2745     case 14:
2746       /* pop */
2747       POP();
2748       break;
2749     case 15:
2750       /* return */
2751       arg1 = POP();
2752       arg2 = ram_get_cdr (cont);
2753       pc = ram_get_entry (arg2);
2754       env = ram_get_cdr (arg2);
2755       cont = ram_get_car (cont);
2756       PUSH_ARG1();
2757       arg2 = OBJ_FALSE;
2758       break;
2759     }
2760
2761   DISPATCH();
2762
2763   /***************************************************************************/
2764
2765   END_DISPATCH();
2766 }
2767
2768 /*---------------------------------------------------------------------------*/
2769
2770 #ifdef WORKSTATION
2771
2772 void usage (void)
2773 {
2774   printf ("usage: sim file.hex\n");
2775   exit (1);
2776 }
2777
2778 int main (int argc, char *argv[])
2779 {
2780   int errcode = 1;
2781   rom_addr rom_start_addr = 0;
2782
2783   if (argc > 1 && argv[1][0] == '-' && argv[1][1] == 's')
2784     {
2785       int h1;
2786       int h2;
2787       int h3;
2788       int h4;
2789
2790       if ((h1 = hex (argv[1][2])) < 0 ||
2791           (h2 = hex (argv[1][3])) < 0 ||
2792           (h3 = hex (argv[1][4])) != 0 ||
2793           (h4 = hex (argv[1][5])) != 0 ||
2794           argv[1][6] != '\0')
2795         usage ();
2796
2797       rom_start_addr = (h1 << 12) | (h2 << 8) | (h3 << 4) | h4;
2798
2799       argv++;
2800       argc--;
2801     }
2802
2803 #ifdef DEBUG
2804   printf ("Start address = 0x%04x\n", rom_start_addr); // TODO says 0, but should be CODE_START ?
2805 #endif
2806
2807   if (argc != 2)
2808     usage ();
2809
2810   if (!read_hex_file (argv[1]))
2811     printf ("*** Could not read hex file \"%s\"\n", argv[1]);
2812   else
2813     {
2814       int i;
2815
2816       if (rom_get (CODE_START+0) != 0xfb ||
2817           rom_get (CODE_START+1) != 0xd7)
2818         printf ("*** The hex file was not compiled with PICOBIT\n");
2819       else
2820         {
2821 #if 0
2822           for (i=0; i<8192; i++) // TODO remove this ? and not the night address space, now 16 bits
2823             if (rom_get (i) != 0xff)
2824               printf ("rom_mem[0x%04x] = 0x%02x\n", i, rom_get (i));
2825 #endif
2826
2827           interpreter ();
2828
2829 #ifdef DEBUG_GC
2830           printf ("**************** memory needed = %d\n", max_live+1);
2831 #endif
2832         }
2833     }
2834
2835   return errcode;
2836 }
2837
2838 #endif
2839
2840 /*---------------------------------------------------------------------------*/