1 /* file: "picobit-vm.c" */
4 * Copyright 2008 by Marc Feeley and Vincent St-Amour, All Rights Reserved.
8 * 15/08/2004 Release of version 1
9 * 06/07/2008 Modified for PICOBOARD2_R3
10 * 18/07/2008 Modified to use new object representation
11 * 17/12/2008 Release of version 2
16 // TODO once this is stable, put as default
17 #define INFINITE_PRECISION_BIGNUMS_not
19 /*---------------------------------------------------------------------------*/
24 typedef unsigned char uint8
;
25 typedef unsigned short uint16
;
26 typedef unsigned long uint32
;
31 typedef uint8 boolean
;
32 // TODO was signed, preventive change
34 /*---------------------------------------------------------------------------*/
54 static volatile near uint8 FW_VALUE_UP @
0x33;
55 static volatile near uint8 FW_VALUE_HI @
0x33;
56 static volatile near uint8 FW_VALUE_LO @
0x33;
58 #define ACTIVITY_LED1_LAT LATB
59 #define ACTIVITY_LED1_BIT 5
60 #define ACTIVITY_LED2_LAT LATB
61 #define ACTIVITY_LED2_BIT 4
62 static volatile near bit ACTIVITY_LED1 @
((unsigned)&ACTIVITY_LED1_LAT
*8)+ACTIVITY_LED1_BIT
;
63 static volatile near bit ACTIVITY_LED2 @
((unsigned)&ACTIVITY_LED2_LAT
*8)+ACTIVITY_LED2_BIT
;
76 #define MAX_PACKET_SIZE BUFSIZ
80 char errbuf
[PCAP_ERRBUF_SIZE
];
83 #define INTERFACE "eth0"
85 char buf
[MAX_PACKET_SIZE
]; // buffer for writing
89 #include <sys/types.h>
90 #include <sys/timeb.h>
99 /*---------------------------------------------------------------------------*/
103 #define CODE_START 0x5000
106 #define IF_TRACE(x) x
107 #define IF_GC_TRACE(x) x
110 #define IF_GC_TRACE(x)
113 /*---------------------------------------------------------------------------*/
118 #define ERROR(prim, msg) halt_with_error()
119 #define TYPE_ERROR(prim, type) halt_with_error()
126 #define ERROR(prim, msg) error (prim, msg)
127 #define TYPE_ERROR(prim, type) type_error (prim, type)
129 void error (char *prim
, char *msg
)
131 printf ("ERROR: %s: %s\n", prim
, msg
);
135 void type_error (char *prim
, char *type
)
137 printf ("ERROR: %s: An argument of type %s was expected\n", prim
, type
);
144 /*---------------------------------------------------------------------------*/
152 typedef uint16 ram_addr
;
153 typedef uint16 rom_addr
;
157 #ifdef INFINITE_PRECISION_BIGNUMS
159 #define digit_width 16
162 typedef uint16 digit
; // TODO why this ? adds to the confusion
163 typedef uint32 two_digit
;
167 /*---------------------------------------------------------------------------*/
169 #define MAX_VEC_ENCODING 8191
170 #define MIN_VEC_ENCODING 4096
171 #define VEC_BYTES ((MAX_VEC_ENCODING - MIN_VEC_ENCODING + 1)*4)
172 // TODO this is new. if the pic has less than 8k of memory, start this lower
173 // TODO the pic actually has 2k, so change these
174 // 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
176 #define MAX_RAM_ENCODING 4095
177 #define MIN_RAM_ENCODING 512
178 #define RAM_BYTES ((MAX_RAM_ENCODING - MIN_RAM_ENCODING + 1)*4)
179 // TODO watch out if we address more than what the PIC actually has
182 #define OBJ_TO_VEC_ADDR(o,f) (((ram_addr)((uint16)(o) - MIN_RAM_ENCODING) << 2) + (f))
183 #define OBJ_TO_RAM_ADDR(o,f) (((ram_addr)((uint16)(o) - MIN_RAM_ENCODING) << 2) + (f))
184 #define OBJ_TO_ROM_ADDR(o,f) (((rom_addr)((uint16)(o) - MIN_ROM_ENCODING) << 2) + (CODE_START + 4 + (f)))
189 #define ram_get(a) *(uint8*)(a+0x200)
190 #define ram_set(a,x) *(uint8*)(a+0x200) = (x)
196 uint8 ram_mem
[RAM_BYTES
+ VEC_BYTES
];
198 #define ram_get(a) ram_mem[a]
199 #define ram_set(a,x) ram_mem[a] = (x)
204 /*---------------------------------------------------------------------------*/
208 uint8
rom_get (rom_addr a
)
210 return *(rom uint8
*)a
;
218 #define ROM_BYTES 8192
219 // TODO the new pics have 32k, change this ? minus the vm size, firmware ?
221 uint8 rom_mem
[ROM_BYTES
] =
224 #define PUTCHAR_LIGHT_not
227 0xFB, 0xD7, 0x03, 0x00, 0x00, 0x00, 0x00, 0x32
228 , 0x03, 0x00, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00
229 , 0x08, 0x50, 0x80, 0x16, 0xFE, 0xE8, 0x00, 0xFC
230 , 0x32, 0x80, 0x2D, 0xFE, 0xFC, 0x31, 0x80, 0x43
231 , 0xFE, 0xFC, 0x33, 0x80, 0x2D, 0xFE, 0xFC, 0x31
232 , 0x80, 0x43, 0xFE, 0x90, 0x16, 0x01, 0x20, 0xFC
233 , 0x32, 0xE3, 0xB0, 0x37, 0x09, 0xF3, 0xFF, 0x20
234 , 0xFC, 0x33, 0xE3, 0xB0, 0x40, 0x0A, 0xF3, 0xFF
235 , 0x08, 0xF3, 0xFF, 0x01, 0x40, 0x21, 0xD1, 0x00
236 , 0x02, 0xC0, 0x4C, 0x71, 0x01, 0x20, 0x50, 0x90
237 , 0x51, 0x00, 0xF1, 0x40, 0xD8, 0xB0, 0x59, 0x90
241 0xFB, 0xD7, 0x00, 0x00, 0x80, 0x08, 0xFE, 0xE8
242 , 0x00, 0xF6, 0xF5, 0x90, 0x08
246 uint8
rom_get (rom_addr a
)
248 return rom_mem
[a
-CODE_START
];
253 /*---------------------------------------------------------------------------*/
261 fixnum n MIN_FIXNUM -> 3 ... MAX_FIXNUM -> 3 + (MAX_FIXNUM-MIN_FIXNUM)
262 rom object 4 + (MAX_FIXNUM-MIN_FIXNUM) ... MIN_RAM_ENCODING-1
263 ram object MIN_RAM_ENCODING ... MAX_RAM_ENCODING
264 u8vector MIN_VEC_ENCODING ... 8191
266 layout of memory allocated objects:
268 G's represent mark bits used by the gc
270 ifdef INFINITE_PRECISION_BIGNUMS
271 bignum n 0GG***** **next** hhhhhhhh llllllll (16 bit digit)
272 TODO make sure this works with the "new" object representation, that the first 3 bits are enough to spot bignums, quick check of the bignum predicate indicates this would work, now implement this pointer FOOBIGNUM
273 TODO what to do with the gc tags for the bignums ? will this work ?
275 ifndef INFINITE_PRECISION_BIGNUMS
276 bignum n 0000000 uuuuuuuu hhhhhhhh llllllll (24 bit signed integer)
278 pair 1GGaaaaa aaaaaaaa 000ddddd dddddddd
281 gives an address space of 2^13 * 4 = 32k divided between simple objects,
284 symbol 1GG00000 00000000 00100000 00000000
286 string 1GG***** *chars** 01000000 00000000
288 u8vector 1GGxxxxx xxxxxxxx 011yyyyy yyyyyyyy
289 x is length of the vector, in bytes (stored raw, not encoded as an object)
290 y is pointer to the elements themselves (stored in vector space)
292 closure 01Gaaaaa aaaaaaaa aaaxxxxx xxxxxxxx
293 0x5ff<a<0x4000 is entry
294 x is pointer to environment
295 the reason why the environment is on the cdr (and the entry is split on 3
296 bytes) is that, when looking for a variable, a closure is considered to be a
297 pair. The compiler adds an extra offset to any variable in the closure's
298 environment, so the car of the closure (which doesn't really exist) is never
299 checked, but the cdr is followed to find the other bindings
301 continuation 1GGxxxxx xxxxxxxx 100yyyyy yyyyyyyy
302 x is parent continuation
303 y is pointer to the second half, which is a closure (contains env and entry)
305 An environment is a list of objects built out of pairs. On entry to
306 a procedure the environment is the list of parameters to which is
307 added the environment of the closure being called.
309 The first byte at the entry point of a procedure gives the arity of
312 n = 0 to 127 -> procedure has n parameters (no rest parameter)
313 n = -128 to -1 -> procedure has -n parameters, the last is
319 #define encode_bool(x) ((obj)(x))
323 #define MIN_FIXNUM_ENCODING 3
324 // TODO change these ? were -5 and 40, with the new bignums, the needs for these might change
325 #define MIN_FIXNUM -1
326 // TODO FOOBIGNUMS, was 0, but -1 needed to be a fixnum for the algos to work
327 #define MAX_FIXNUM 255
328 #define MIN_ROM_ENCODING (MIN_FIXNUM_ENCODING+MAX_FIXNUM-MIN_FIXNUM+1)
330 #define ENCODE_FIXNUM(n) ((obj)(n) + (MIN_FIXNUM_ENCODING - MIN_FIXNUM))
331 #define DECODE_FIXNUM(o) ((int32)(o) - (MIN_FIXNUM_ENCODING - MIN_FIXNUM))
333 // TODO why this ifdef ?
335 #define IN_VEC(o) ((o) >= MIN_VEC_ENCODING)
336 #define IN_RAM(o) (!IN_VEC(o) && ((o) >= MIN_RAM_ENCODING))
337 #define IN_ROM(o) (!IN_VEC(o) && !IN_RAM(o) && ((o) >= MIN_ROM_ENCODING))
340 // bignum first byte : 00Gxxxxx
341 #define BIGNUM_FIELD0 0
342 #define RAM_BIGNUM(o) ((ram_get_field0 (o) & 0xc0) == BIGNUM_FIELD0)
343 #define ROM_BIGNUM(o) ((rom_get_field0 (o) & 0xc0) == BIGNUM_FIELD0)
345 // composite first byte : 1GGxxxxx
346 #define COMPOSITE_FIELD0 0x80
347 #define RAM_COMPOSITE(o) ((ram_get_field0 (o) & 0x80) == COMPOSITE_FIELD0)
348 #define ROM_COMPOSITE(o) ((rom_get_field0 (o) & 0x80) == COMPOSITE_FIELD0)
350 // pair third byte : 000xxxxx
351 #define PAIR_FIELD2 0
352 #define RAM_PAIR(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == PAIR_FIELD2))
353 #define ROM_PAIR(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == PAIR_FIELD2))
355 // symbol third byte : 001xxxxx
356 #define SYMBOL_FIELD2 0x20
357 #define RAM_SYMBOL(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == SYMBOL_FIELD2))
358 #define ROM_SYMBOL(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == SYMBOL_FIELD2))
360 // string third byte : 010xxxxx
361 #define STRING_FIELD2 0x40
362 #define RAM_STRING(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == STRING_FIELD2))
363 #define ROM_STRING(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == STRING_FIELD2))
365 // vector third byte : 011xxxxx
366 #define VECTOR_FIELD2 0x60
367 #define RAM_VECTOR(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == VECTOR_FIELD2))
368 #define ROM_VECTOR(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == VECTOR_FIELD2))
370 // continuation third byte : 100xxxxx
371 #define CONTINUATION_FIELD2 0x80
372 #define RAM_CONTINUATION(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == CONTINUATION_FIELD2))
373 #define ROM_CONTINUATION(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == CONTINUATION_FIELD2))
375 // closure first byte : 01Gxxxxx
376 #define CLOSURE_FIELD0 0x40
377 #define RAM_CLOSURE(o) ((ram_get_field0 (o) & 0xc0) == CLOSURE_FIELD0)
378 #define ROM_CLOSURE(o) ((rom_get_field0 (o) & 0xc0) == CLOSURE_FIELD0)
381 /*---------------------------------------------------------------------------*/
383 #define RAM_GET_FIELD0_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,0))
384 #define RAM_SET_FIELD0_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,0), val)
385 #define ROM_GET_FIELD0_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,0))
387 #define RAM_GET_GC_TAGS_MACRO(o) (RAM_GET_FIELD0_MACRO(o) & 0x60)
388 #define RAM_GET_GC_TAG0_MACRO(o) (RAM_GET_FIELD0_MACRO(o) & 0x20)
389 #define RAM_GET_GC_TAG1_MACRO(o) (RAM_GET_FIELD0_MACRO(o) & 0x40)
390 #define RAM_SET_GC_TAGS_MACRO(o,tags) \
391 (RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0x9f) | (tags)))
392 #define RAM_SET_GC_TAG0_MACRO(o,tag) \
393 RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xdf) | (tag))
394 #define RAM_SET_GC_TAG1_MACRO(o,tag) \
395 RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xbf) | (tag))
398 #define RAM_GET_FIELD1_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,1))
399 #define RAM_GET_FIELD2_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,2))
400 #define RAM_GET_FIELD3_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,3))
401 #define RAM_SET_FIELD1_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,1), val)
402 #define RAM_SET_FIELD2_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,2), val)
403 #define RAM_SET_FIELD3_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,3), val)
404 #define ROM_GET_FIELD1_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,1))
405 #define ROM_GET_FIELD2_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,2))
406 #define ROM_GET_FIELD3_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,3))
407 #define VEC_GET_BYTE0_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,0))
408 #define VEC_GET_BYTE1_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,1))
409 #define VEC_GET_BYTE2_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,2))
410 #define VEC_GET_BYTE3_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,3))
411 #define VEC_SET_BYTE0_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,0), val)
412 #define VEC_SET_BYTE1_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,1), val)
413 #define VEC_SET_BYTE2_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,2), val)
414 #define VEC_SET_BYTE3_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,3), val)
417 uint8
ram_get_gc_tags (obj o
) { return RAM_GET_GC_TAGS_MACRO(o
); }
418 uint8
ram_get_gc_tag0 (obj o
) { return RAM_GET_GC_TAG0_MACRO(o
); }
419 uint8
ram_get_gc_tag1 (obj o
) { return RAM_GET_GC_TAG1_MACRO(o
); }
420 void ram_set_gc_tags (obj o
, uint8 tags
) { RAM_SET_GC_TAGS_MACRO(o
, tags
); }
421 void ram_set_gc_tag0 (obj o
, uint8 tag
) { RAM_SET_GC_TAG0_MACRO(o
,tag
); }
422 void ram_set_gc_tag1 (obj o
, uint8 tag
) { RAM_SET_GC_TAG1_MACRO(o
,tag
); }
423 uint8
ram_get_field0 (obj o
) { return RAM_GET_FIELD0_MACRO(o
); }
424 word
ram_get_field1 (obj o
) { return RAM_GET_FIELD1_MACRO(o
); }
425 word
ram_get_field2 (obj o
) { return RAM_GET_FIELD2_MACRO(o
); }
426 word
ram_get_field3 (obj o
) { return RAM_GET_FIELD3_MACRO(o
); }
427 word
ram_get_fieldn (obj o
, uint8 n
)
431 case 0: return ram_get_field0 (o
);
432 case 1: return ram_get_field1 (o
);
433 case 2: return ram_get_field2 (o
);
434 case 3: return ram_get_field3 (o
);
437 void ram_set_field0 (obj o
, uint8 val
) { RAM_SET_FIELD0_MACRO(o
,val
); }
438 void ram_set_field1 (obj o
, word val
) { RAM_SET_FIELD1_MACRO(o
,val
); }
439 void ram_set_field2 (obj o
, word val
) { RAM_SET_FIELD2_MACRO(o
,val
); }
440 void ram_set_field3 (obj o
, word val
) { RAM_SET_FIELD3_MACRO(o
,val
); }
441 void ram_set_fieldn (obj o
, uint8 n
, word val
)
445 case 0: ram_set_field0 (o
, val
); break;
446 case 1: ram_set_field1 (o
, val
); break;
447 case 2: ram_set_field2 (o
, val
); break;
448 case 3: ram_set_field3 (o
, val
); break;
451 uint8
rom_get_field0 (obj o
) { return ROM_GET_FIELD0_MACRO(o
); }
452 word
rom_get_field1 (obj o
) { return ROM_GET_FIELD1_MACRO(o
); }
453 word
rom_get_field2 (obj o
) { return ROM_GET_FIELD2_MACRO(o
); }
454 word
rom_get_field3 (obj o
) { return ROM_GET_FIELD3_MACRO(o
); }
455 /* word vec_get_byte0 (obj o) { return VEC_GET_BYTE0_MACRO(o); } */
456 /* word vec_get_byte1 (obj o) { return VEC_GET_BYTE1_MACRO(o); } */
457 /* word vec_get_byte2 (obj o) { return VEC_GET_BYTE2_MACRO(o); } */
458 /* word vec_get_byte3 (obj o) { return VEC_GET_BYTE3_MACRO(o); } */
459 /* word vec_set_byte0 (obj o, word val) { VEC_SET_BYTE0_MACRO(o,val); } */
460 /* word vec_set_byte1 (obj o, word val) { VEC_SET_BYTE1_MACRO(o,val); } */
461 /* word vec_set_byte2 (obj o, word val) { VEC_SET_BYTE2_MACRO(o,val); } */
462 /* word vec_set_byte3 (obj o, word val) { VEC_SET_BYTE3_MACRO(o,val); } */
464 obj
get_field0 (obj o
) // TODO these are not used yet, will they be useful at all ?
467 return ram_get_field0 (o
);
469 return rom_get_field0 (o
);
471 obj
get_field1 (obj o
)
474 return ram_get_field1 (o
);
476 return rom_get_field1 (o
);
478 obj
get_field2 (obj o
)
481 return ram_get_field2 (o
);
483 return rom_get_field2 (o
);
485 obj
get_field3 (obj o
)
488 return ram_get_field3 (o
);
490 return rom_get_field3 (o
);
494 obj
ram_get_car (obj o
)
495 { return ((ram_get_field0 (o
) & 0x1f) << 8) | ram_get_field1 (o
); }
496 obj
rom_get_car (obj o
)
497 { return ((rom_get_field0 (o
) & 0x1f) << 8) | rom_get_field1 (o
); }
498 obj
ram_get_cdr (obj o
)
499 { return ((ram_get_field2 (o
) & 0x1f) << 8) | ram_get_field3 (o
); }
500 obj
rom_get_cdr (obj o
)
501 { return ((rom_get_field2 (o
) & 0x1f) << 8) | rom_get_field3 (o
); }
505 return ram_get_car (o
);
507 return rom_get_car (o
);
512 return ram_get_cdr (o
);
514 return rom_get_cdr (o
);
517 void ram_set_car (obj o
, obj val
)
519 ram_set_field0 (o
, (val
>> 8) | (ram_get_field0 (o
) & 0xe0));
520 ram_set_field1 (o
, val
& 0xff);
522 void ram_set_cdr (obj o
, obj val
)
524 ram_set_field2 (o
, (val
>> 8) | (ram_get_field2 (o
) & 0xe0));
525 ram_set_field3 (o
, val
& 0xff);
528 obj
ram_get_entry (obj o
)
530 return (((ram_get_field0 (o
) & 0x1f) << 11)
531 | (ram_get_field1 (o
) << 3)
532 | (ram_get_field2 (o
) >> 5));
534 obj
rom_get_entry (obj o
)
536 return (((rom_get_field0 (o
) & 0x1f) << 11)
537 | (rom_get_field1 (o
) << 3)
538 | (rom_get_field2 (o
) >> 5));
540 obj
get_entry (obj o
)
543 return ram_get_entry (o
);
545 return rom_get_entry (o
);
549 obj
get_global (uint8 i
)
550 // globals occupy the beginning of ram, with 2 globals per word
553 return ram_get_cdr (MIN_RAM_ENCODING
+ (i
/ 2));
555 return ram_get_car (MIN_RAM_ENCODING
+ (i
/ 2));
558 void set_global (uint8 i
, obj o
)
561 ram_set_cdr (MIN_RAM_ENCODING
+ (i
/ 2), o
);
563 ram_set_car (MIN_RAM_ENCODING
+ (i
/ 2), o
);
567 void show_type (obj o
) // for debugging purposes
570 if (o
== OBJ_FALSE
) printf("#f");
571 else if (o
== OBJ_TRUE
) printf("#t");
572 else if (o
== OBJ_NULL
) printf("()");
573 else if (o
< MIN_ROM_ENCODING
) printf("fixnum");
576 if (RAM_BIGNUM(o
)) printf("ram bignum");
577 else if (RAM_PAIR(o
)) printf("ram pair");
578 else if (RAM_SYMBOL(o
)) printf("ram symbol");
579 else if (RAM_STRING(o
)) printf("ram string");
580 else if (RAM_VECTOR(o
)) printf("ram vector");
581 else if (RAM_CONTINUATION(o
)) printf("ram continuation");
582 else if (RAM_CLOSURE(o
)) printf("ram closure");
586 if (ROM_BIGNUM(o
)) printf("rom bignum");
587 else if (ROM_PAIR(o
)) printf("rom pair");
588 else if (ROM_SYMBOL(o
)) printf("rom symbol");
589 else if (ROM_STRING(o
)) printf("rom string");
590 else if (ROM_VECTOR(o
)) printf("rom vector");
591 else if (ROM_CONTINUATION(o
)) printf("rom continuation");
592 else if (RAM_CLOSURE(o
)) printf("rom closure");
599 /*---------------------------------------------------------------------------*/
601 /* Interface to GC */
603 // TODO explain what each tag means, with 1-2 mark bits
604 #define GC_TAG_0_LEFT (1<<5)
605 #define GC_TAG_1_LEFT (2<<5)
606 #define GC_TAG_UNMARKED (0<<5)
608 /* Number of object fields of objects in ram */
609 #define HAS_2_OBJECT_FIELDS(visit) (RAM_PAIR(visit) || RAM_CONTINUATION(visit))
610 #ifdef INFINITE_PRECISION_BIGNUMS
611 #define HAS_1_OBJECT_FIELD(visit) (RAM_COMPOSITE(visit) \
612 || RAM_CLOSURE(visit) || RAM_BIGNUM(visit))
614 #define HAS_1_OBJECT_FIELD(visit) (RAM_COMPOSITE(visit) || RAM_CLOSURE(visit))
616 // all composites except pairs and continuations have 1 object field
618 #define NIL OBJ_FALSE
620 /*---------------------------------------------------------------------------*/
622 /* Garbage collector */
624 obj free_list
; /* list of unused cells */
625 obj free_list_vec
; /* list of unused cells in vector space */
627 obj arg1
; /* root set */
635 uint8 na
; /* interpreter variables */
646 void init_ram_heap (void)
649 obj o
= MAX_RAM_ENCODING
;
653 while (o
> (MIN_RAM_ENCODING
+ (glovars
+ 1) / 2))
654 // we don't want to add globals to the free list, and globals occupy the
655 // beginning of memory at the rate of 2 globals per word (car and cdr)
657 ram_set_gc_tags (o
, GC_TAG_UNMARKED
);
658 ram_set_car (o
, free_list
);
663 free_list_vec
= MIN_VEC_ENCODING
;
664 ram_set_car (free_list_vec
, 0);
665 // each node of the free list must know the free length that follows it
666 // this free length is stored in words, not in bytes
667 // if we did count in bytes, the number might need more than 13 bits
668 ram_set_cdr (free_list_vec
, VEC_BYTES
/ 4);
670 for (i
=0; i
<glovars
; i
++)
671 set_global (i
, OBJ_FALSE
);
698 IF_GC_TRACE(printf ("push stack=%d visit=%d (tag=%d)\n", stack
, visit
, ram_get_gc_tags (visit
)>>5));
700 if ((HAS_1_OBJECT_FIELD (visit
) && ram_get_gc_tag0 (visit
))
701 || (HAS_2_OBJECT_FIELDS (visit
)
702 && (ram_get_gc_tags (visit
) != GC_TAG_UNMARKED
)))
703 IF_GC_TRACE(printf ("case 1\n"));
706 if (HAS_2_OBJECT_FIELDS(visit
)) // pairs and continuations
708 IF_GC_TRACE(printf ("case 2\n"));
712 temp
= ram_get_cdr (visit
);
716 IF_GC_TRACE(printf ("case 3\n"));
717 ram_set_gc_tags (visit
, GC_TAG_1_LEFT
);
718 ram_set_cdr (visit
, stack
);
722 IF_GC_TRACE(printf ("case 4\n"));
727 if (HAS_1_OBJECT_FIELD(visit
))
729 IF_GC_TRACE(printf ("case 5\n"));
733 if (RAM_CLOSURE(visit
)) // closures have the pointer in the cdr
734 temp
= ram_get_cdr (visit
);
736 temp
= ram_get_car (visit
);
740 IF_GC_TRACE(printf ("case 6\n"));
741 ram_set_gc_tag0 (visit
, GC_TAG_0_LEFT
);
742 if (RAM_CLOSURE(visit
))
743 ram_set_cdr (visit
, stack
);
745 ram_set_car (visit
, stack
);
750 IF_GC_TRACE(printf ("case 7\n"));
753 IF_GC_TRACE(printf ("case 8\n"));
755 ram_set_gc_tag0 (visit
, GC_TAG_0_LEFT
);
760 IF_GC_TRACE(printf ("pop stack=%d visit=%d (tag=%d)\n", stack
, visit
, ram_get_gc_tags (visit
)>>6));
764 if (HAS_2_OBJECT_FIELDS(stack
) && ram_get_gc_tag1 (stack
))
766 IF_GC_TRACE(printf ("case 9\n"));
768 temp
= ram_get_cdr (stack
); /* pop through cdr */
769 ram_set_cdr (stack
, visit
);
773 ram_set_gc_tag1(visit
, GC_TAG_UNMARKED
);
774 // we unset the "1-left" bit
779 if (RAM_CLOSURE(stack
))
780 // closures have one object field, but it's in the cdr
782 IF_GC_TRACE(printf ("case 10\n"));
784 temp
= ram_get_cdr (stack
); /* pop through cdr */
785 ram_set_cdr (stack
, visit
);
792 IF_GC_TRACE(printf ("case 11\n"));
794 temp
= ram_get_car (stack
); /* pop through car */
795 ram_set_car (stack
, visit
);
816 obj visit
= MAX_RAM_ENCODING
;
820 while (visit
>= (MIN_RAM_ENCODING
+ ((glovars
+ 1) / 2)))
821 // we don't want to sweep the global variables area
823 if ((RAM_COMPOSITE(visit
)
824 && (ram_get_gc_tags (visit
) == GC_TAG_UNMARKED
)) // 2 mark bit
825 || !(ram_get_gc_tags (visit
) & GC_TAG_0_LEFT
)) // 1 mark bit
828 if (RAM_VECTOR(visit
))
829 // when we sweep a vector, we also have to sweep its contents
831 obj o
= ram_get_cdr (visit
);
832 uint16 i
= ram_get_car (visit
); // number of elements
833 ram_set_car (o
, free_list_vec
);
834 ram_set_cdr (o
, (i
+ 3) / 4); // free length, in words
836 // TODO merge free spaces
838 ram_set_car (visit
, free_list
);
843 if (RAM_COMPOSITE(visit
))
844 ram_set_gc_tags (visit
, GC_TAG_UNMARKED
);
845 else // only 1 mark bit to unset
846 ram_set_gc_tag0 (visit
, GC_TAG_UNMARKED
);
858 printf ("**************** memory needed = %d\n", max_live
+1);
868 IF_TRACE(printf("\nGC BEGINS\n"));
870 IF_GC_TRACE(printf("arg1\n"));
872 IF_GC_TRACE(printf("arg2\n"));
874 IF_GC_TRACE(printf("arg3\n"));
876 IF_GC_TRACE(printf("arg4\n"));
878 IF_GC_TRACE(printf("arg5\n"));
880 IF_GC_TRACE(printf("cont\n"));
882 IF_GC_TRACE(printf("env\n"));
885 IF_GC_TRACE(printf("globals\n"));
886 for (i
=0; i
<glovars
; i
++)
887 mark (get_global (i
));
892 obj
alloc_ram_cell (void)
906 ERROR("alloc_ram_cell", "memory is full");
911 free_list
= ram_get_car (o
);
916 obj
alloc_ram_cell_init (uint8 f0
, uint8 f1
, uint8 f2
, uint8 f3
)
918 obj o
= alloc_ram_cell ();
920 ram_set_field0 (o
, f0
);
921 ram_set_field1 (o
, f1
);
922 ram_set_field2 (o
, f2
);
923 ram_set_field3 (o
, f3
);
928 obj
alloc_vec_cell (uint16 n
)
930 obj o
= free_list_vec
;
939 while ((ram_get_cdr (o
) * 4) < n
) // free space too small
941 if (o
== 0) // no free space, or none big enough
943 if (gc_done
) // we gc'd, but no space is big enough for the vector
944 ERROR("alloc_vec_cell", "no room for vector");
952 } // TODO merge adjacent free spaces, maybe compact ?
957 // case 1 : the new vector fills every free word advertized, we remove the
958 // node from the free list
959 if (((ram_get_cdr(o
) * 4) - n
) < 4)
962 ram_set_car (prec
, ram_get_car (o
));
964 free_list_vec
= ram_get_car (o
);
966 // case 2 : there is still some space left in the free section, create a new
967 // node to represent this space
970 obj new_free
= o
+ (n
+ 3)/4;
972 ram_set_car (prec
, new_free
);
974 free_list_vec
= new_free
;
975 ram_set_car (new_free
, ram_get_car (o
));
976 ram_set_cdr (new_free
, ram_get_cdr (o
) - (n
+ 3)/4);
982 /*---------------------------------------------------------------------------*/
984 #ifdef INFINITE_PRECISION_BIGNUMS
986 // TODO FOOBIGNUMS this was taken from the bignum code, see if it works
987 int8
decode_int8 (obj o
) // TODO never used except in decode_int
988 { // TODO really fishy, to use only 8 bits this way...
990 if (o
< MIN_FIXNUM_ENCODING
)
991 TYPE_ERROR("decode_int8.0", "integer");
993 if (o
<= (MIN_FIXNUM_ENCODING
+ (MAX_FIXNUM
- MIN_FIXNUM
)))
994 return DECODE_FIXNUM(o
);
999 TYPE_ERROR("decode_int8.1", "integer");
1000 return ram_get_field3 (o
);
1005 TYPE_ERROR("decode_int8.2", "integer");
1006 return rom_get_field3 (o
);
1009 TYPE_ERROR("decode_int8.3", "integer");
1011 // TODO how could this possibly work ? it does not consider other fields, same for encoding, get to the bottom of this
1013 int32
decode_int (obj o
)
1015 return decode_int8 (o
); // TODO FOOBAR clearly wrong, is it used ?
1019 obj
encode_int (int32 n
) // TODO never used in the bignum code
1021 if (n
>= MIN_FIXNUM
&& n
<= MAX_FIXNUM
){
1022 return ENCODE_FIXNUM(n
);
1025 // TODO FOOBIGNUMS since we encode 0 here, and it's 00..0 we don't need to or with the 1st byte for the pointer, what happens with negative numbers, however ?
1026 return alloc_ram_cell_init (BIGNUM_FIELD0
, ENCODE_FIXNUM(0), n
>> 8, n
);
1031 int32
decode_int (obj o
)
1037 if (o
< MIN_FIXNUM_ENCODING
)
1038 TYPE_ERROR("decode_int.0", "integer");
1040 if (o
<= (MIN_FIXNUM_ENCODING
+ (MAX_FIXNUM
- MIN_FIXNUM
)))
1041 return DECODE_FIXNUM(o
);
1046 TYPE_ERROR("decode_int.1", "integer");
1048 u
= ram_get_field1 (o
);
1049 h
= ram_get_field2 (o
);
1050 l
= ram_get_field3 (o
);
1055 TYPE_ERROR("decode_int.2", "integer");
1057 u
= rom_get_field1 (o
);
1058 h
= rom_get_field2 (o
);
1059 l
= rom_get_field3 (o
);
1062 TYPE_ERROR("decode_int.3", "integer");
1064 if (u
>= 128) // TODO FOOBIGNUMS uhh, what's that again ? is here since the beginning
1065 return ((int32
)((((int16
)u
- 256) << 8) + h
) << 8) + l
;
1067 return ((int32
)(((int16
)u
<< 8) + h
) << 8) + l
;
1070 obj
encode_int (int32 n
)
1072 if (n
>= MIN_FIXNUM
&& n
<= MAX_FIXNUM
)
1073 return ENCODE_FIXNUM(n
);
1075 return alloc_ram_cell_init (BIGNUM_FIELD0
, n
>> 16, n
>> 8, n
);
1080 /*---------------------------------------------------------------------------*/
1092 else if (o
== OBJ_TRUE
)
1094 else if (o
== OBJ_NULL
)
1096 else if (o
<= (MIN_FIXNUM_ENCODING
+ (MAX_FIXNUM
- MIN_FIXNUM
)))
1097 printf ("%d", DECODE_FIXNUM(o
));
1107 if ((in_ram
&& RAM_BIGNUM(o
)) || (!in_ram
&& ROM_BIGNUM(o
))) // TODO FIX for new bignums
1108 printf ("%d", decode_int (o
));
1109 else if ((in_ram
&& RAM_COMPOSITE(o
)) || (!in_ram
&& ROM_COMPOSITE(o
)))
1114 if ((in_ram
&& RAM_PAIR(o
)) || (!in_ram
&& ROM_PAIR(o
)))
1118 car
= ram_get_car (o
);
1119 cdr
= ram_get_cdr (o
);
1123 car
= rom_get_car (o
);
1124 cdr
= rom_get_cdr (o
);
1133 if (cdr
== OBJ_NULL
)
1135 else if ((IN_RAM(cdr
) && RAM_PAIR(cdr
))
1136 || (IN_ROM(cdr
) && ROM_PAIR(cdr
)))
1140 car
= ram_get_car (cdr
);
1141 cdr
= ram_get_cdr (cdr
);
1145 car
= rom_get_car (cdr
);
1146 cdr
= rom_get_cdr (cdr
);
1159 else if ((in_ram
&& RAM_SYMBOL(o
)) || (!in_ram
&& ROM_SYMBOL(o
)))
1160 printf ("#<symbol>");
1161 else if ((in_ram
&& RAM_STRING(o
)) || (!in_ram
&& ROM_STRING(o
)))
1162 printf ("#<string>");
1163 else if ((in_ram
&& RAM_VECTOR(o
)) || (!in_ram
&& ROM_VECTOR(o
)))
1164 printf ("#<vector %d>", o
);
1168 car
= ram_get_car (o
);
1169 cdr
= ram_get_cdr (o
);
1170 // ugly hack, takes advantage of the fact that pairs and
1171 // continuations have the same layout
1181 env
= ram_get_cdr (o
);
1183 env
= rom_get_cdr (o
);
1186 pc
= ram_get_entry (o
);
1188 pc
= rom_get_entry (o
);
1190 printf ("{0x%04x ", pc
);
1199 void show_state (rom_addr pc
)
1202 printf ("pc=0x%04x bytecode=0x%02x env=", pc
, rom_get (pc
));
1219 /*---------------------------------------------------------------------------*/
1221 /* Integer operations */
1223 // TODO FOOBIGNUMS big pasted and NOT CHECKED section here
1224 #ifdef INFINITE_PRECISION_BIGNUMS
1226 #define obj_eq(x,y) ((x) == (y))
1228 #define integer_hi_set(x,y) ram_set_car (x, y)
1229 // TODO FOOBIGNUMS won't work, I think, will erase next pointer (or set it only in part) ACTUALLY, this is probably supposed to change the pointer. changed field1, npw changes the whole car
1231 #define ZERO ENCODE_FIXNUM(0)
1232 #define NEG1 (ZERO-1)
1233 #define POS1 (ZERO+1)
1235 /* integer fixnum (uint8 n) // TODO this used to be a signed int, but broke everything. probably should be removed */
1237 /* return ENCODE_FIXNUM (n); */
1238 /* } */ // TODO if no ill effect is detected without this, remove it
1240 // TODO this integer type is a mess, it should be obj, for clarity
1241 integer
make_integer (digit lo
, integer hi
) // TODO BAD, should use encode_int instead
1243 // TODO could this be fixed by a call to encode_int ?
1244 /* if(!hi && lo <= MAX_FIXNUM) // TODO dependent on the current fixnum range, which starts at 0, fix this */ // TODO would this even be useful ? don't the math routines already revert to fixnums if needed ? or norm does it ?
1245 /* return ENCODE_FIXNUM(lo); */
1246 // TODO won't work, and the bignum functions are unaware of fixnums
1247 return alloc_ram_cell_init (BIGNUM_FIELD0
| (hi
>> 8), hi
, lo
>> 8, lo
); // TODO hi should always be a 13-bit pointer, to avoid clobbering the bignum field
1250 integer
integer_hi (integer x
) // TODO should be used for decoding
1253 return ram_get_car (x
); // TODO was field1
1255 return rom_get_car (x
); // TODO was field1
1256 else if (x
< (MIN_FIXNUM_ENCODING
- MIN_FIXNUM
))
1257 return NEG1
; /* negative fixnum */
1259 return ZERO
; /* nonnegative fixnum */
1262 digit
integer_lo (integer x
)
1265 return (((digit
)ram_get_field2 (x
)) << 8) + ram_get_field3 (x
);
1267 return (((digit
)rom_get_field2 (x
)) << 8) + rom_get_field3 (x
);
1269 return DECODE_FIXNUM(x
);
1272 integer
norm (obj prefix
, integer n
)
1274 /* norm(prefix,n) returns a normalized integer whose value is the
1275 integer n prefixed with the digits in prefix (a list of digits) */
1277 while (prefix
!= NIL
)
1279 digit d
= integer_lo (prefix
);
1282 prefix
= integer_hi (temp
);
1284 if (obj_eq (n
, ZERO
))
1286 if (d
<= MAX_FIXNUM
)
1288 n
= ENCODE_FIXNUM ((uint8
)d
); // TODO is this cast needed at all ?
1289 continue; // TODO with cast to unsigned, will it work for negative numbers ? or is it only handled in the next branch ?
1292 else if (obj_eq (n
, NEG1
))
1294 if (d
>= (1<<digit_width
) + MIN_FIXNUM
)
1296 n
= ENCODE_FIXNUM (d
- (1<<digit_width
)); // TODO had a cast, origianlly to int8, changed to uint8 which didn't work (obviously, we use -1 here), is a cast necessary at all ?
1301 integer_hi_set (temp
, n
);
1308 boolean
negp (integer x
)
1310 /* negp(x) returns true iff x is negative */
1315 if (obj_eq (x
, ZERO
)) return false;
1316 } while (!obj_eq (x
, NEG1
));
1321 int8
cmp (integer x
, integer y
)
1323 /* cmp(x,y) return -1 when x<y, 1 when x>y, and 0 when x=y */
1331 if (obj_eq (x
, ZERO
) || obj_eq (x
, NEG1
))
1334 { if (negp (y
)) result
= 1; else result
= -1; }
1338 if (obj_eq (y
, ZERO
) || obj_eq (y
, NEG1
))
1340 if (negp (x
)) result
= -1; else result
= 1;
1344 xlo
= integer_lo (x
);
1345 ylo
= integer_lo (y
);
1349 { if (xlo
< ylo
) result
= -1; else result
= 1; }
1354 uint16
integer_length (integer x
)
1356 /* integer_length(x) returns the number of bits in the binary
1357 representation of the nonnegative integer x */
1363 while (!obj_eq ((next
= integer_hi (x
)), ZERO
)) // TODO what happens if it ends with -1 ?
1365 result
+= digit_width
;
1380 integer
shr (integer x
)
1382 /* shr(x) returns the integer x shifted one bit to the right */
1389 if (obj_eq (x
, ZERO
) || obj_eq (x
, NEG1
))
1391 result
= norm (result
, x
);
1397 result
= make_integer ((d
>> 1) |
1398 ((integer_lo (x
) & 1) ? (1<<(digit_width
-1)) : 0),
1405 integer
negative_carry (integer carry
)
1413 integer
shl (integer x
)
1415 /* shl(x) returns the integer x shifted one bit to the left */
1417 integer negc
= ZERO
; /* negative carry */
1424 if (obj_eq (x
, negc
))
1426 result
= norm (result
, x
);
1433 negc
= negative_carry (d
& (1<<(digit_width
-1))); // TODO right side is constant, and sixpic has no constant folding
1434 result
= make_integer ((d
<< 1) | obj_eq (temp
, NEG1
), result
);
1440 integer
shift_left (integer x
, uint16 n
) // TODO have the primitves been changed for this and right ?
1442 /* shift_left(x,n) returns the integer x shifted n bits to the left */
1444 if (obj_eq (x
, ZERO
))
1447 while (n
& (digit_width
-1))
1455 x
= make_integer (0, x
);
1462 integer
add (integer x
, integer y
)
1464 /* add(x,y) returns the sum of the integers x and y */
1466 integer negc
= ZERO
; /* negative carry */
1467 obj result
= NIL
; /* nil terminated for the norm function */
1473 if (obj_eq (x
, negc
))
1475 result
= norm (result
, y
);
1479 if (obj_eq (y
, negc
))
1481 result
= norm (result
, x
);
1485 dx
= integer_lo (x
);
1486 dy
= integer_lo (y
);
1487 dx
= dx
+ dy
; /* may wrap around */
1489 if (obj_eq (negc
, ZERO
))
1490 negc
= negative_carry (dx
< dy
);
1493 dx
++; /* may wrap around */
1494 negc
= negative_carry (dx
<= dy
);
1500 result
= make_integer (dx
, result
);
1506 integer
invert (integer x
)
1508 if (obj_eq (x
, ZERO
))
1514 integer
sub (integer x
, integer y
)
1516 /* sub(x,y) returns the difference of the integers x and y */
1517 integer negc
= NEG1
; /* negative carry */
1524 if (obj_eq (x
, negc
) && (obj_eq (y
, ZERO
) || obj_eq (y
, NEG1
)))
1526 result
= norm (result
, invert (y
));
1530 if (obj_eq (y
, invert (negc
)))
1532 result
= norm (result
, x
);
1536 dx
= integer_lo (x
);
1537 dy
= ~integer_lo (y
);
1538 dx
= dx
+ dy
; /* may wrap around */
1540 if (obj_eq (negc
, ZERO
))
1541 negc
= negative_carry (dx
< dy
);
1544 dx
++; /* may wrap around */
1545 negc
= negative_carry (dx
<= dy
);
1551 result
= make_integer (dx
, result
);
1557 integer
neg (integer x
)
1559 /* neg(x) returns the integer -x */
1561 return sub (ZERO
, x
);
1564 integer
scale (digit n
, integer x
)
1566 /* scale(n,x) returns the integer n*x */
1572 if ((n
== 0) || obj_eq (x
, ZERO
))
1583 if (obj_eq (x
, ZERO
))
1585 if (carry
<= MAX_FIXNUM
)
1586 result
= norm (result
, ENCODE_FIXNUM ((uint8
)carry
)); // TODO was fixnum, and int8 (signed)
1588 result
= norm (result
, make_integer (carry
, ZERO
));
1592 if (obj_eq (x
, NEG1
))
1595 if (carry
>= ((1<<digit_width
) + MIN_FIXNUM
))
1596 result
= norm (result
, ENCODE_FIXNUM ((uint8
)carry
)); // TODO was fixnum, and int8 (signed)
1598 result
= norm (result
, make_integer (carry
, NEG1
));
1602 m
= (two_digit
)integer_lo (x
) * n
+ carry
;
1605 carry
= m
>> digit_width
;
1606 result
= make_integer ((digit
)m
, result
);
1612 integer
mulnonneg (integer x
, integer y
)
1614 /* mulnonneg(x,y) returns the product of the integers x and y
1615 where x is nonnegative */
1618 integer s
= scale (integer_lo (x
), y
);
1622 result
= make_integer (integer_lo (s
), result
);
1626 if (obj_eq (x
, ZERO
))
1629 s
= add (s
, scale (integer_lo (x
), y
));
1632 return norm (result
, s
);
1635 integer
mul (integer x
, integer y
)
1637 /* mul(x,y) returns the product of the integers x and y */
1640 return neg (mulnonneg (neg (x
), y
));
1642 return mulnonneg (x
, y
);
1645 integer
divnonneg (integer x
, integer y
)
1647 /* divnonneg(x,y) returns the quotient and remainder of
1648 the integers x and y where x and y are nonnegative */
1650 integer result
= ZERO
;
1651 uint16 lx
= integer_length (x
);
1652 uint16 ly
= integer_length (y
);
1658 y
= shift_left (y
, lx
);
1662 result
= shl (result
);
1663 if (cmp (x
, y
) >= 0)
1666 result
= add (POS1
, result
);
1669 } while (lx
-- != 0);
1678 long long x
; // TODO long long is 32 bits here, what about on a 64 bit machine ?
1679 x
= ((long long)integer_lo (integer_hi (integer_hi (integer_hi (n
))))<<48)+
1680 ((long long)integer_lo (integer_hi (integer_hi (n
)))<<32)+
1681 ((long long)integer_lo (integer_hi (n
))<<16)+
1682 (long long)integer_lo (n
);
1683 printf ("%lld ", x
);
1684 // TODO test for hex output, to avoid signedness problems
1685 /* printf("%x%x%x%x\n", // TODO prob, if a lower part is 0, will show 0, not 0000 */
1686 /* integer_lo (integer_hi (integer_hi (integer_hi (n)))), */
1687 /* integer_lo (integer_hi (integer_hi (n))), */
1688 /* integer_lo (integer_hi (n)), */
1689 /* integer_lo (n)); */
1692 integer
enc (long long n
) // TODO used only for debugging
1694 integer result
= NIL
;
1696 while (n
!= 0 && n
!= -1)
1698 result
= make_integer ((digit
)n
, result
);
1703 return norm (result
, NEG1
);
1705 return norm (result
, ZERO
);
1708 void test (void) // TODO still in use ? no, but useful for tests
1718 zero
= make_integer (0x0000, 0);
1719 min1
= make_integer (0xffff, 0);
1720 integer_hi_set (zero
, ZERO
);
1721 integer_hi_set (min1
, NEG1
);
1723 min2
= make_integer (0xfffe, NEG1
);
1724 one
= make_integer (0x0001, ZERO
);
1725 two
= make_integer (0x0002, ZERO
);
1726 three
= make_integer (0x0003, ZERO
);
1727 four
= make_integer (0x0004, ZERO
);
1729 if (negp (ZERO
)) printf ("zero is negp\n"); // should not show
1730 if (negp (NEG1
)) printf ("min1 is negp\n");
1732 printf ("cmp(5,5) = %d\n",cmp (make_integer (5, ZERO
), make_integer (5, ZERO
)));
1733 printf ("cmp(2,5) = %d\n",cmp (make_integer (2, ZERO
), make_integer (5, ZERO
)));
1734 printf ("cmp(5,2) = %d\n",cmp (make_integer (5, ZERO
), make_integer (2, ZERO
)));
1736 printf ("cmp(-5,-5) = %d\n",cmp (make_integer (-5, NEG1
), make_integer (-5, NEG1
)));
1737 printf ("cmp(-2,-5) = %d\n",cmp (make_integer (-2, NEG1
), make_integer (-5, NEG1
)));
1738 printf ("cmp(-5,-2) = %d\n",cmp (make_integer (-5, NEG1
), make_integer (-2, NEG1
)));
1740 printf ("cmp(-5,65533) = %d\n",cmp (make_integer (-5, NEG1
), make_integer (65533, ZERO
)));
1741 printf ("cmp(-5,2) = %d\n",cmp (make_integer (-5, NEG1
), make_integer (2, ZERO
)));
1742 printf ("cmp(5,-65533) = %d\n",cmp (make_integer (5, ZERO
), make_integer (-65533, NEG1
)));
1743 printf ("cmp(5,-2) = %d\n",cmp (make_integer (5, ZERO
), make_integer (-2, NEG1
)));
1745 printf ("integer_length(0) = %d\n", integer_length (ZERO
)); // these return the number of bits necessary to encode
1746 printf ("integer_length(1) = %d\n", integer_length (make_integer (1, ZERO
)));
1747 printf ("integer_length(2) = %d\n", integer_length (make_integer (2, ZERO
)));
1748 printf ("integer_length(3) = %d\n", integer_length (make_integer (3, ZERO
)));
1749 printf ("integer_length(4) = %d\n", integer_length (make_integer (4, ZERO
)));
1750 printf ("integer_length(65536 + 4) = %d\n", integer_length (make_integer (4, make_integer (1, ZERO
))));
1753 printf ("1 = %d\n", one
); // TODO these show the address, useful ?
1754 printf ("2 = %d\n", two
);
1755 printf ("4 = %d\n", four
);
1756 printf ("norm(2) = %d\n", norm (make_integer (0, make_integer (2, NIL
)), ZERO
)); // TODO these show the fixnum address (6 and 7), so it seems to be working
1757 printf ("norm(2) = %d\n", norm (make_integer (0, make_integer (2, NIL
)), ZERO
));
1758 printf ("norm(3) = %d\n", norm (make_integer (0, make_integer (3, NIL
)), ZERO
));
1759 printf ("norm(3) = %d\n", norm (make_integer (0, make_integer (3, NIL
)), ZERO
));
1761 printf ("shl(1) = %d\n", shl (one
)); // TODO fixnums, again
1762 printf ("shl(2) = %d\n", shl (two
));
1767 // should show powers of 2 incerasing, then decreasing
1768 for (i
=1; i
<=34; i
++)
1770 printf("\nloop-1 : i=%d len=%d ", i
, integer_length(n
));
1774 for (i
=1; i
<=35; i
++)
1776 printf("\nloop-2 : i=%d len=%d ", i
, integer_length(n
));
1783 integer n
= shift_left (four
, 5);
1786 for (i
=0; i
<=14; i
++)
1788 printf("\nloop-3 : i=%d len=%d ", i
);
1789 p (shift_left (n
, i
*4));
1794 p (add (enc (32768), enc (32768))); printf("\n"); // 65536
1795 p (add (enc (32768+(65536*65535LL)), enc (32768))); printf("\n"); // 4294967296
1797 p (sub (enc (32768), enc (-32768))); printf("\n"); // 65536
1798 p (sub (enc (32768+(65536*65535LL)), enc (-32768))); printf("\n"); // 4294967296
1800 p (sub (enc (32768), enc (32769))); printf("\n"); // -1
1801 p (sub (enc (32768), enc (132768))); printf("\n"); // -100000
1802 p (add(sub (enc (32768), enc (32769)), enc(1000))); printf("\n"); // 999
1804 p (mul (enc (123456789), enc (1000000000))); printf("\n");
1805 p (mul (enc (123456789), enc (-1000000000))); printf("\n");
1806 p (mul (enc (-123456789), enc (1000000000))); printf("\n");
1807 p (mul (enc (-123456789), enc (-1000000000))); printf("\n");
1809 p (divnonneg (enc (10000000-1), enc (500000))); printf("\n");
1820 void prim_numberp (void)
1822 if (arg1
>= MIN_FIXNUM_ENCODING
1823 && arg1
<= (MIN_FIXNUM_ENCODING
+ (MAX_FIXNUM
- MIN_FIXNUM
)))
1828 arg1
= encode_bool (RAM_BIGNUM(arg1
));
1829 else if (IN_ROM(arg1
))
1830 arg1
= encode_bool (ROM_BIGNUM(arg1
));
1836 void decode_2_int_args (void) // TODO fix for bignums ?
1838 a1
= decode_int (arg1
); // TODO all math primitives call it, even for bignums, this is probably what causes problems, maybe not, since the primitives don't use a1 or a2, but rather arg1 and arg2
1839 a2
= decode_int (arg2
);
1842 void prim_add (void)
1844 #ifdef INFINITE_PRECISION_BIGNUMS
1845 arg1
= add (arg1
, arg2
);
1847 decode_2_int_args ();
1848 arg1
= encode_int (a1
+ a2
);
1853 void prim_sub (void)
1855 #ifdef INFINITE_PRECISION_BIGNUMS
1856 arg1
= sub (arg1
, arg2
);
1858 decode_2_int_args ();
1859 arg1
= encode_int (a1
- a2
);
1864 void prim_mul (void)
1866 #ifdef INFINITE_PRECISION_BIGNUMS
1867 arg1
= mul (arg1
, arg2
);
1869 decode_2_int_args ();
1870 arg1
= encode_int (a1
* a2
);
1875 void prim_div (void)
1877 decode_2_int_args (); // TODO useless work in the case of bignums, move in the else, but make sure that an error message is written even with bignums
1879 ERROR("quotient", "divide by 0");
1880 #ifdef INFINITE_PRECISION_BIGNUMS
1883 arg1
= encode_int (a1
/ a2
);
1888 void prim_rem (void)
1890 decode_2_int_args (); // TODO same as div
1892 ERROR("remainder", "divide by 0");
1893 #ifdef INFINITE_PRECISION_BIGNUMS
1896 arg1
= encode_int (a1
% a2
);
1901 void prim_neg (void)
1903 #ifdef INFINITE_PRECISION_BIGNUMS
1906 a1
= decode_int (arg1
);
1907 arg1
= encode_int (- a1
);
1913 #ifdef INFINITE_PRECISION_BIGNUMS
1914 arg1
= encode_bool(cmp (arg1
, arg2
) == 0);
1916 decode_2_int_args ();
1917 arg1
= encode_bool(a1
== a2
);
1924 #ifdef INFINITE_PRECISION_BIGNUMS
1925 arg1
= encode_bool(cmp (arg1
, arg2
) < 0);
1927 decode_2_int_args ();
1928 arg1
= encode_bool(a1
< a2
);
1935 #ifdef INFINITE_PRECISION_BIGNUMS
1936 arg1
= encode_bool(cmp (arg1
, arg2
) > 0);
1938 decode_2_int_args ();
1939 arg1
= encode_bool(a1
> a2
);
1944 void prim_ior (void) // TODO FOOBIGNUMS these have not been implemented with bignums, do it
1946 decode_2_int_args (); // TODO is the function call overhead worth it ?
1947 arg1
= encode_int (a1
| a2
);
1951 void prim_xor (void)
1953 decode_2_int_args (); // TODO is the function call overhead worth it ?
1954 arg1
= encode_int (a1
^ a2
);
1959 /*---------------------------------------------------------------------------*/
1961 /* List operations */
1963 void prim_pairp (void)
1966 arg1
= encode_bool (RAM_PAIR(arg1
));
1967 else if (IN_ROM(arg1
))
1968 arg1
= encode_bool (ROM_PAIR(arg1
));
1973 obj
cons (obj car
, obj cdr
)
1975 return alloc_ram_cell_init (COMPOSITE_FIELD0
| (car
>> 8),
1977 PAIR_FIELD2
| (cdr
>> 8),
1981 void prim_cons (void)
1983 arg1
= cons (arg1
, arg2
);
1987 void prim_car (void)
1991 if (!RAM_PAIR(arg1
))
1992 TYPE_ERROR("car.0", "pair");
1993 arg1
= ram_get_car (arg1
);
1995 else if (IN_ROM(arg1
))
1997 if (!ROM_PAIR(arg1
))
1998 TYPE_ERROR("car.1", "pair");
1999 arg1
= rom_get_car (arg1
);
2003 TYPE_ERROR("car.2", "pair");
2007 void prim_cdr (void)
2011 if (!RAM_PAIR(arg1
))
2012 TYPE_ERROR("cdr.0", "pair");
2013 arg1
= ram_get_cdr (arg1
);
2015 else if (IN_ROM(arg1
))
2017 if (!ROM_PAIR(arg1
))
2018 TYPE_ERROR("cdr.1", "pair");
2019 arg1
= rom_get_cdr (arg1
);
2023 TYPE_ERROR("cdr.2", "pair");
2027 void prim_set_car (void)
2031 if (!RAM_PAIR(arg1
))
2032 TYPE_ERROR("set-car!.0", "pair");
2034 ram_set_car (arg1
, arg2
);
2040 TYPE_ERROR("set-car!.1", "pair");
2044 void prim_set_cdr (void)
2048 if (!RAM_PAIR(arg1
))
2049 TYPE_ERROR("set-cdr!.0", "pair");
2051 ram_set_cdr (arg1
, arg2
);
2057 TYPE_ERROR("set-cdr!.1", "pair");
2061 void prim_nullp (void)
2063 arg1
= encode_bool (arg1
== OBJ_NULL
);
2066 /*---------------------------------------------------------------------------*/
2068 /* Vector operations */
2070 void prim_u8vectorp (void)
2073 arg1
= encode_bool (RAM_VECTOR(arg1
));
2074 else if (IN_ROM(arg1
))
2075 arg1
= encode_bool (ROM_VECTOR(arg1
));
2080 void prim_make_u8vector (void)
2082 decode_2_int_args (); // arg1 is length, arg2 is contents
2083 // TODO adapt for the new bignums
2085 ERROR("make-u8vector", "byte vectors can only contain bytes");
2087 arg3
= alloc_vec_cell (a1
);
2088 arg1
= alloc_ram_cell_init (COMPOSITE_FIELD0
| (a1
>> 8),
2090 VECTOR_FIELD2
| (arg3
>> 8),
2093 a1
= (a1
+ 3) / 4; // actual length, in words
2096 ram_set_field0 (arg3
, a2
);
2097 ram_set_field1 (arg3
, a2
);
2098 ram_set_field2 (arg3
, a2
);
2099 ram_set_field3 (arg3
, a2
);
2104 void prim_u8vector_ref (void)
2106 a2
= decode_int (arg2
);
2107 // TODO adapt for the new bignums
2110 if (!RAM_VECTOR(arg1
))
2111 TYPE_ERROR("u8vector-ref.0", "vector");
2112 if ((ram_get_car (arg1
) <= a2
) || (a2
< 0))
2113 ERROR("u8vector-ref.0", "vector index invalid");
2114 arg1
= ram_get_cdr (arg1
);
2116 else if (IN_ROM(arg1
))
2118 if (!ROM_VECTOR(arg1
))
2119 TYPE_ERROR("u8vector-ref.1", "vector");
2120 if ((rom_get_car (arg1
) <= a2
) || (a2
< 0))
2121 ERROR("u8vector-ref.1", "vector index invalid");
2122 arg1
= rom_get_cdr (arg1
);
2125 TYPE_ERROR("u8vector-ref.2", "vector");
2132 arg1
= encode_int (ram_get_fieldn (arg1
, a2
));
2134 else // rom vector, stored as a list
2137 arg1
= rom_get_cdr (arg1
);
2139 // the contents are already encoded as fixnums
2140 arg1
= rom_get_car (arg1
);
2148 void prim_u8vector_set (void)
2149 { // TODO a lot in common with ref, abstract that
2150 a2
= decode_int (arg2
); // TODO adapt for bignums
2151 a3
= decode_int (arg3
);
2154 ERROR("u8vector-set!", "byte vectors can only contain bytes");
2158 if (!RAM_VECTOR(arg1
))
2159 TYPE_ERROR("u8vector-set!.0", "vector");
2160 if ((ram_get_car (arg1
) <= a2
) || (a2
< 0))
2161 ERROR("u8vector-set!", "vector index invalid");
2162 arg1
= ram_get_cdr (arg1
);
2165 TYPE_ERROR("u8vector-set!.1", "vector");
2170 ram_set_fieldn (arg1
, a2
, a3
);
2177 void prim_u8vector_length (void)
2181 if (!RAM_VECTOR(arg1
))
2182 TYPE_ERROR("u8vector-length.0", "vector");
2183 arg1
= encode_int (ram_get_car (arg1
));
2185 else if (IN_ROM(arg1
))
2187 if (!ROM_VECTOR(arg1
))
2188 TYPE_ERROR("u8vector-length.1", "vector");
2189 arg1
= encode_int (rom_get_car (arg1
));
2192 TYPE_ERROR("u8vector-length.2", "vector");
2195 void prim_u8vector_copy (void)
2197 // arg1 is source, arg2 is source-start, arg3 is target, arg4 is target-start
2198 // arg5 is number of bytes to copy
2200 a1
= decode_int (arg2
); // TODO adapt for bignums
2201 a2
= decode_int (arg4
);
2202 a3
= decode_int (arg5
);
2204 // case 1 : ram to ram
2205 if (IN_RAM(arg1
) && IN_RAM(arg3
))
2207 if (!RAM_VECTOR(arg1
) || !RAM_VECTOR(arg3
))
2208 TYPE_ERROR("u8vector-copy!.0", "vector");
2209 if ((ram_get_car (arg1
) < (a1
+ a3
)) || (a1
< 0) ||
2210 (ram_get_car (arg3
) < (a2
+ a3
)) || (a2
< 0))
2211 ERROR("u8vector-copy!.0", "vector index invalid");
2213 // position to the start
2214 arg1
= ram_get_cdr (arg1
);
2217 arg3
= ram_get_cdr (arg3
);
2224 ram_set_fieldn (arg3
, a2
, ram_get_fieldn (arg1
, a1
));
2228 a1
%= 4; // TODO merge with the previous similar block ?
2234 // case 2 : rom to ram
2235 else if (IN_ROM(arg1
) && IN_RAM(arg3
))
2237 if (!ROM_VECTOR(arg1
) || !RAM_VECTOR(arg3
))
2238 TYPE_ERROR("u8vector-copy!.1", "vector");
2239 if ((rom_get_car (arg1
) < (a1
+ a3
)) || (a1
< 0) ||
2240 (ram_get_car (arg3
) < (a2
+ a3
)) || (a2
< 0))
2241 ERROR("u8vector-copy!.1", "vector index invalid");
2243 arg1
= rom_get_cdr (arg1
);
2245 arg1
= rom_get_cdr (arg1
);
2247 arg3
= ram_get_cdr (arg3
);
2253 ram_set_fieldn (arg3
, a2
, decode_int (rom_get_car (arg1
)));
2255 arg1
= rom_get_cdr (arg1
);
2258 a2
%= 4; // TODO very similar to the other case
2262 TYPE_ERROR("u8vector-copy!.2", "vector");
2271 /*---------------------------------------------------------------------------*/
2273 /* Miscellaneous operations */
2275 void prim_eqp (void)
2277 arg1
= encode_bool (arg1
== arg2
);
2281 void prim_not (void)
2283 arg1
= encode_bool (arg1
== OBJ_FALSE
);
2286 void prim_symbolp (void)
2289 arg1
= encode_bool (RAM_SYMBOL(arg1
));
2290 else if (IN_ROM(arg1
))
2291 arg1
= encode_bool (ROM_SYMBOL(arg1
));
2296 void prim_stringp (void)
2299 arg1
= encode_bool (RAM_STRING(arg1
));
2300 else if (IN_ROM(arg1
))
2301 arg1
= encode_bool (ROM_STRING(arg1
));
2306 void prim_string2list (void)
2310 if (!RAM_STRING(arg1
))
2311 TYPE_ERROR("string->list.0", "string");
2313 arg1
= ram_get_car (arg1
);
2315 else if (IN_ROM(arg1
))
2317 if (!ROM_STRING(arg1
))
2318 TYPE_ERROR("string->list.1", "string");
2320 arg1
= rom_get_car (arg1
);
2323 TYPE_ERROR("string->list.2", "string");
2326 void prim_list2string (void)
2328 arg1
= alloc_ram_cell_init (COMPOSITE_FIELD0
| ((arg1
& 0x1f00) >> 8),
2334 void prim_booleanp (void)
2336 arg1
= encode_bool (arg1
< 2);
2340 /*---------------------------------------------------------------------------*/
2342 /* Robot specific operations */
2345 void prim_print (void)
2360 int32
read_clock (void)
2366 now
= from_now( 0 );
2374 static int32 start
= 0;
2379 now
= tb
.time
* 1000 + tb
.millitm
;
2386 static int32 start
= 0;
2389 if (gettimeofday (&tv
, NULL
) == 0)
2391 now
= tv
.tv_sec
* 1000 + tv
.tv_usec
/ 1000;
2405 void prim_clock (void)
2407 arg1
= encode_int (read_clock ());
2411 void prim_motor (void)
2413 decode_2_int_args (); // TODO fix for bignums
2415 if (a1
< 1 || a1
> 2 || a2
< -100 || a2
> 100)
2416 ERROR("motor", "argument out of range");
2420 MOTOR_set( a1
, a2
);
2426 printf ("motor %d -> power=%d\n", a1
, a2
);
2436 void prim_led (void)
2438 decode_2_int_args (); // TODO fix for bignums
2439 a3
= decode_int (arg3
);
2441 if (a1
< 1 || a1
> 3 || a2
< 0 || a3
< 0)
2442 ERROR("led", "argument out of range");
2446 LED_set( a1
, a2
, a3
);
2452 printf ("led %d -> duty=%d period=%d\n", a1
, a2
, a3
);
2463 void prim_led2_color (void)
2465 a1
= decode_int (arg1
); // TODO fix for bignums
2467 if (a1
< 0 || a1
> 1)
2468 ERROR("led2-colors", "argument out of range");
2472 LED2_color_set( a1
);
2478 printf ("led2-color -> %s\n", (a1
==0)?"green":"red");
2487 void prim_getchar_wait (void)
2489 decode_2_int_args(); // TODO fix for bignums
2490 a1
= read_clock () + a1
;
2492 if (a1
< 0 || a2
< 1 || a2
> 3)
2493 ERROR("getchar-wait", "argument out of range");
2500 serial_port_set ports
;
2501 ports
= serial_rx_wait_with_timeout( a2
, a1
);
2503 arg1
= encode_int (serial_rx_read( ports
));
2518 arg1
= encode_int (_getch ());
2521 } while (read_clock () < a1
);
2526 arg1
= encode_int (getchar ());
2534 void prim_putchar (void)
2536 decode_2_int_args ();
2538 if (a1
< 0 || a1
> 255 || a2
< 1 || a2
> 3)
2539 ERROR("putchar", "argument out of range");
2543 serial_tx_write( a2
, a1
);
2559 void prim_beep (void)
2561 decode_2_int_args (); // TODO fix for bignums
2563 if (a1
< 1 || a1
> 255 || a2
< 0)
2564 ERROR("beep", "argument out of range");
2568 beep( a1
, from_now( a2
) );
2574 printf ("beep -> freq-div=%d duration=%d\n", a1
, a2
);
2584 void prim_adc (void)
2588 a1
= decode_int (arg1
); // TODO fix for bignums
2590 if (a1
< 1 || a1
> 3)
2591 ERROR("adc", "argument out of range");
2601 x
= read_clock () & 255;
2603 if (x
> 127) x
= 256 - x
;
2609 arg1
= encode_int (x
);
2613 void prim_dac (void) // TODO not used
2615 a1
= decode_int (arg1
); // TODO fix for bignums
2617 if (a1
< 0 || a1
> 255)
2618 ERROR("dac", "argument out of range");
2628 printf ("dac -> %d\n", a1
);
2637 void prim_sernum (void)
2653 arg1
= encode_int (x
);
2657 /*---------------------------------------------------------------------------*/
2658 // networking, currently works only on workstations
2662 void prim_network_init (void)
2663 { // TODO maybe put in the initialization of the vm
2664 handle
= pcap_open_live(INTERFACE
, MAX_PACKET_SIZE
, PROMISC
, TO_MSEC
, errbuf
);
2666 ERROR("network-init", "interface not responding");
2669 void prim_network_cleanup (void)
2670 { // TODO maybe put in halt ?
2674 void prim_receive_packet_to_u8vector (void)
2676 // arg1 is the vector in which to put the received packet
2677 if (!RAM_VECTOR(arg1
))
2678 TYPE_ERROR("receive-packet-to-u8vector", "vector");
2680 // receive the packet in the buffer
2681 struct pcap_pkthdr header
;
2682 const u_char
*packet
;
2684 packet
= pcap_next(handle
, &header
);
2689 if (ram_get_car (arg1
) < header
.len
)
2690 ERROR("receive-packet-to-u8vector", "packet longer than vector");
2692 if (header
.len
> 0) // we have received a packet, write it in the vector
2694 arg2
= rom_get_cdr (arg1
);
2695 arg1
= header
.len
; // we return the length of the received packet
2700 ram_set_fieldn (arg2
, a1
% 4, (char)packet
[a1
]);
2702 arg2
+= (a1
% 4) ? 0 : 1;
2707 else // no packet to be read
2711 void prim_send_packet_from_u8vector (void)
2713 // arg1 is the vector which contains the packet to be sent
2714 // arg2 is the length of the packet
2715 // TODO only works with ram vectors for now
2716 if (!RAM_VECTOR(arg1
))
2717 TYPE_ERROR("send-packet-from-vector!", "vector");
2718 a2
= decode_int (arg2
); // TODO fix for bignums
2721 // TODO test if the length of the packet is longer than the length of the vector
2722 if (ram_get_car (arg1
) < a2
)
2723 ERROR("send-packet-from-u8vector", "packet cannot be longer than vector");
2725 arg1
= ram_get_cdr (arg1
);
2727 // copy the packet to the output buffer
2729 buf
[a1
] = ram_get_fieldn (arg1
, a1
% 4);
2730 // TODO maybe I could just give pcap the pointer to the memory BREGG
2732 if (pcap_sendpacket(handle
, buf
, a2
) < 0) // TODO an error has occurred, can we reuse the interface ?
2742 /*---------------------------------------------------------------------------*/
2746 int hidden_fgetc (FILE *f
)
2756 #define fgetc(f) hidden_fgetc(f)
2758 void write_hex_nibble (int n
)
2760 putchar ("0123456789ABCDEF"[n
]);
2763 void write_hex (uint8 n
)
2765 write_hex_nibble (n
>> 4);
2766 write_hex_nibble (n
& 0x0f);
2771 if (c
>= '0' && c
<= '9')
2774 if (c
>= 'A' && c
<= 'F')
2775 return (c
- 'A' + 10);
2777 if (c
>= 'a' && c
<= 'f')
2778 return (c
- 'a' + 10);
2783 int read_hex_byte (FILE *f
)
2785 int h1
= hex (fgetc (f
));
2786 int h2
= hex (fgetc (f
));
2788 if (h1
>= 0 && h2
>= 0)
2789 return (h1
<<4) + h2
;
2794 int read_hex_file (char *filename
)
2797 FILE *f
= fopen (filename
, "r");
2807 for (i
=0; i
<ROM_BYTES
; i
++)
2812 while ((c
= fgetc (f
)) != EOF
)
2814 if ((c
== '\r') || (c
== '\n'))
2818 (len
= read_hex_byte (f
)) < 0 ||
2819 (a1
= read_hex_byte (f
)) < 0 ||
2820 (a2
= read_hex_byte (f
)) < 0 ||
2821 (t
= read_hex_byte (f
)) < 0)
2827 sum
= len
+ a1
+ a2
+ t
;
2835 unsigned long adr
= ((unsigned long)hi16
<< 16) + a
- CODE_START
;
2837 if ((b
= read_hex_byte (f
)) < 0)
2840 if (adr
>= 0 && adr
< ROM_BYTES
)
2843 a
= (a
+ 1) & 0xffff;
2860 if ((a1
= read_hex_byte (f
)) < 0 ||
2861 (a2
= read_hex_byte (f
)) < 0)
2866 hi16
= (a1
<<8) + a2
;
2871 if ((b
= read_hex_byte (f
)) < 0)
2878 printf ("*** HEX file checksum error (expected 0x%02x)\n", sum
);
2884 if ((c
!= '\r') && (c
!= '\n'))
2895 printf ("*** HEX file syntax error\n");
2905 /*---------------------------------------------------------------------------*/
2907 #define FETCH_NEXT_BYTECODE() bytecode = rom_get (pc++)
2909 #define BEGIN_DISPATCH() \
2911 IF_TRACE(show_state (pc)); \
2912 FETCH_NEXT_BYTECODE(); \
2913 bytecode_hi4 = bytecode & 0xf0; \
2914 bytecode_lo4 = bytecode & 0x0f; \
2915 switch (bytecode_hi4 >> 4) {
2917 #define END_DISPATCH() }
2919 #define CASE(opcode) case (opcode>>4):;
2921 #define DISPATCH(); goto dispatch;
2926 #define bytecode TABLAT
2927 #define bytecode_hi4 WREG
2930 #define PUSH_CONSTANT1 0x00
2931 #define PUSH_CONSTANT2 0x10
2932 #define PUSH_STACK1 0x20
2933 #define PUSH_STACK2 0x30
2934 #define PUSH_GLOBAL 0x40
2935 #define SET_GLOBAL 0x50
2938 #define LABEL_INSTR 0x80
2939 #define PUSH_CONSTANT_LONG 0x90
2951 char *prim_name
[64] =
2975 "prim #%graft-to-cont",
2976 "prim #%return-to-cont",
2980 "prim #%string->list",
2981 "prim #%list->string",
2982 "prim #%make-u8vector",
2983 "prim #%u8vector-ref",
2984 "prim #%u8vector-set!",
2989 "prim #%led2-color",
2990 "prim #%getchar-wait",
2996 "prim #%u8vector-length",
2997 "prim #%u8vector-copy!",
3002 "prim #%network-init",
3003 "prim #%network-cleanup",
3004 "prim #%receive-packet-to-u8vector",
3005 "prim #%send-packet-from-u8vector",
3021 #define PUSH_ARG1() push_arg1 ()
3024 void push_arg1 (void)
3026 env
= cons (arg1
, env
);
3032 obj o
= ram_get_car (env
);
3033 env
= ram_get_cdr (env
);
3037 void pop_procedure (void)
3043 if (!RAM_CLOSURE(arg1
))
3044 TYPE_ERROR("pop_procedure.0", "procedure");
3046 entry
= ram_get_entry (arg1
) + CODE_START
;
3048 else if (IN_ROM(arg1
))
3050 if (!ROM_CLOSURE(arg1
))
3051 TYPE_ERROR("pop_procedure.1", "procedure");
3053 entry
= rom_get_entry (arg1
) + CODE_START
;
3056 TYPE_ERROR("pop_procedure.2", "procedure");
3059 void handle_arity_and_rest_param (void)
3063 np
= rom_get (entry
++);
3065 if ((np
& 0x80) == 0)
3068 ERROR("handle_arity_and_rest_param.0", "wrong number of arguments");
3075 ERROR("handle_arity_and_rest_param.1", "wrong number of arguments");
3083 arg3
= cons (arg4
, arg3
);
3089 arg1
= cons (arg3
, arg1
);
3094 void build_env (void)
3100 arg1
= cons (arg3
, arg1
);
3108 void save_cont (void)
3110 // the second half is a closure
3111 arg3
= alloc_ram_cell_init (CLOSURE_FIELD0
| (pc
>> 11),
3113 ((pc
& 0x0007) << 5) | (env
>> 8),
3115 cont
= alloc_ram_cell_init (COMPOSITE_FIELD0
| (cont
>> 8),
3117 CONTINUATION_FIELD2
| (arg3
>> 8),
3122 void interpreter (void)
3124 pc
= (CODE_START
+ 4) + ((rom_addr
)rom_get (CODE_START
+2) << 2);
3126 glovars
= rom_get (CODE_START
+3); // number of global variables
3132 /***************************************************************************/
3133 CASE(PUSH_CONSTANT1
);
3135 IF_TRACE(printf(" (push-constant "); show (bytecode_lo4
); printf (")\n"));
3137 arg1
= bytecode_lo4
;
3143 /***************************************************************************/
3144 CASE(PUSH_CONSTANT2
);
3146 IF_TRACE(printf(" (push-constant "); show (bytecode_lo4
+16); printf (")\n"));
3147 arg1
= bytecode_lo4
+16;
3153 /***************************************************************************/
3156 IF_TRACE(printf(" (push-stack %d)\n", bytecode_lo4
));
3160 while (bytecode_lo4
!= 0)
3162 arg1
= ram_get_cdr (arg1
);
3166 arg1
= ram_get_car (arg1
);
3172 /***************************************************************************/
3175 IF_TRACE(printf(" (push-stack %d)\n", bytecode_lo4
+16));
3181 while (bytecode_lo4
!= 0)
3183 arg1
= ram_get_cdr (arg1
);
3187 arg1
= ram_get_car (arg1
);
3193 /***************************************************************************/
3196 IF_TRACE(printf(" (push-global %d)\n", bytecode_lo4
));
3198 arg1
= get_global (bytecode_lo4
);
3204 /***************************************************************************/
3207 IF_TRACE(printf(" (set-global %d)\n", bytecode_lo4
));
3209 set_global (bytecode_lo4
, POP());
3213 /***************************************************************************/
3216 IF_TRACE(printf(" (call %d)\n", bytecode_lo4
));
3221 handle_arity_and_rest_param ();
3232 /***************************************************************************/
3235 IF_TRACE(printf(" (jump %d)\n", bytecode_lo4
));
3240 handle_arity_and_rest_param ();
3250 /***************************************************************************/
3253 switch (bytecode_lo4
)
3255 case 0: // call-toplevel
3256 FETCH_NEXT_BYTECODE();
3259 FETCH_NEXT_BYTECODE();
3261 IF_TRACE(printf(" (call-toplevel 0x%04x)\n",
3262 ((arg2
<< 8) | bytecode
) + CODE_START
));
3264 entry
= (arg2
<< 8) + bytecode
+ CODE_START
;
3267 na
= rom_get (entry
++);
3280 case 1: // jump-toplevel
3281 FETCH_NEXT_BYTECODE();
3284 FETCH_NEXT_BYTECODE();
3286 IF_TRACE(printf(" (jump-toplevel 0x%04x)\n",
3287 ((arg2
<< 8) | bytecode
) + CODE_START
));
3289 entry
= (arg2
<< 8) + bytecode
+ CODE_START
;
3292 na
= rom_get (entry
++);
3305 FETCH_NEXT_BYTECODE();
3308 FETCH_NEXT_BYTECODE();
3310 IF_TRACE(printf(" (goto 0x%04x)\n",
3311 (arg2
<< 8) + bytecode
+ CODE_START
));
3313 pc
= (arg2
<< 8) + bytecode
+ CODE_START
;
3317 case 3: // goto-if-false
3318 FETCH_NEXT_BYTECODE();
3321 FETCH_NEXT_BYTECODE();
3323 IF_TRACE(printf(" (goto-if-false 0x%04x)\n",
3324 (arg2
<< 8) + bytecode
+ CODE_START
));
3326 if (POP() == OBJ_FALSE
)
3327 pc
= (arg2
<< 8) + bytecode
+ CODE_START
;
3332 FETCH_NEXT_BYTECODE();
3335 FETCH_NEXT_BYTECODE();
3337 IF_TRACE(printf(" (closure 0x%04x)\n", (arg2
<< 8) | bytecode
));
3339 arg3
= POP(); // env
3341 entry
= (arg2
<< 8) | bytecode
;
3343 arg1
= alloc_ram_cell_init (CLOSURE_FIELD0
| (arg2
>> 3),
3344 ((arg2
& 0x07) << 5) | (bytecode
>> 3),
3345 ((bytecode
&0x07) <<5) |((arg3
&0x1f00) >>8),
3355 case 5: // call-toplevel-short
3356 FETCH_NEXT_BYTECODE(); // TODO the short version have a lot in common with the long ones, abstract ?
3357 // TODO short instructions don't work at the moment
3358 IF_TRACE(printf(" (call-toplevel-short 0x%04x)\n",
3359 pc
+ bytecode
+ CODE_START
));
3361 entry
= pc
+ bytecode
+ CODE_START
;
3364 na
= rom_get (entry
++);
3376 case 6: // jump-toplevel-short
3377 FETCH_NEXT_BYTECODE();
3379 IF_TRACE(printf(" (jump-toplevel-short 0x%04x)\n",
3380 pc
+ bytecode
+ CODE_START
));
3382 entry
= pc
+ bytecode
+ CODE_START
;
3385 na
= rom_get (entry
++);
3396 case 7: // goto-short
3397 FETCH_NEXT_BYTECODE();
3399 IF_TRACE(printf(" (goto-short 0x%04x)\n", pc
+ bytecode
+ CODE_START
));
3401 pc
= pc
+ bytecode
+ CODE_START
;
3405 case 8: // goto-if-false-short
3406 FETCH_NEXT_BYTECODE();
3408 IF_TRACE(printf(" (goto-if-false-short 0x%04x)\n",
3409 pc
+ bytecode
+ CODE_START
));
3411 if (POP() == OBJ_FALSE
)
3412 pc
= pc
+ bytecode
+ CODE_START
;
3416 case 9: // closure-short
3417 FETCH_NEXT_BYTECODE();
3419 IF_TRACE(printf(" (closure-short 0x%04x)\n", pc
+ bytecode
));
3421 arg3
= POP(); // env
3423 entry
= pc
+ bytecode
;
3425 arg1
= alloc_ram_cell_init (CLOSURE_FIELD0
| (arg2
>> 3),
3426 ((arg2
& 0x07) << 5) | (bytecode
>> 3),
3427 ((bytecode
&0x07) <<5) |((arg3
&0x1f00) >>8),
3446 case 14: // push_global [long]
3447 FETCH_NEXT_BYTECODE();
3449 IF_TRACE(printf(" (push-global [long] %d)\n", bytecode
));
3451 arg1
= get_global (bytecode
);
3457 case 15: // set_global [long]
3458 FETCH_NEXT_BYTECODE();
3460 IF_TRACE(printf(" (set-global [long] %d)\n", bytecode
));
3462 set_global (bytecode
, POP());
3469 /***************************************************************************/
3470 CASE(PUSH_CONSTANT_LONG
);
3472 /* push-constant [long] */
3474 FETCH_NEXT_BYTECODE();
3476 IF_TRACE(printf(" (push [long] 0x%04x)\n", (bytecode_lo4
<< 8) + bytecode
));
3478 arg1
= (bytecode_lo4
<< 8) | bytecode
;
3483 /***************************************************************************/
3484 CASE(FREE1
); // FREE
3488 /***************************************************************************/
3489 CASE(FREE2
); // FREE
3493 /***************************************************************************/
3496 IF_TRACE(printf(" (%s)\n", prim_name
[bytecode_lo4
]));
3498 switch (bytecode_lo4
)
3501 arg1
= POP(); prim_numberp (); PUSH_ARG1(); break;
3503 arg2
= POP(); arg1
= POP(); prim_add (); PUSH_ARG1(); break;
3505 arg2
= POP(); arg1
= POP(); prim_sub (); PUSH_ARG1(); break;
3507 arg2
= POP(); arg1
= POP(); prim_mul (); PUSH_ARG1(); break;
3509 arg2
= POP(); arg1
= POP(); prim_div (); PUSH_ARG1(); break;
3511 arg2
= POP(); arg1
= POP(); prim_rem (); PUSH_ARG1(); break;
3513 arg1
= POP(); prim_neg (); PUSH_ARG1(); break;
3515 arg2
= POP(); arg1
= POP(); prim_eq (); PUSH_ARG1(); break;
3517 arg2
= POP(); arg1
= POP(); prim_lt (); PUSH_ARG1(); break;
3519 arg2
= POP(); arg1
= POP(); prim_ior (); PUSH_ARG1(); break;
3521 arg2
= POP(); arg1
= POP(); prim_gt (); PUSH_ARG1(); break;
3523 arg2
= POP(); arg1
= POP(); prim_xor (); PUSH_ARG1(); break;
3525 arg1
= POP(); prim_pairp (); PUSH_ARG1(); break;
3527 arg2
= POP(); arg1
= POP(); prim_cons (); PUSH_ARG1(); break;
3529 arg1
= POP(); prim_car (); PUSH_ARG1(); break;
3531 arg1
= POP(); prim_cdr (); PUSH_ARG1(); break;
3536 /***************************************************************************/
3539 IF_TRACE(printf(" (%s)\n", prim_name
[bytecode_lo4
+16]));
3541 switch (bytecode_lo4
)
3544 arg2
= POP(); arg1
= POP(); prim_set_car (); break;
3546 arg2
= POP(); arg1
= POP(); prim_set_cdr (); break;
3548 arg1
= POP(); prim_nullp (); PUSH_ARG1(); break;
3550 arg2
= POP(); arg1
= POP(); prim_eqp (); PUSH_ARG1(); break;
3552 arg1
= POP(); prim_not (); PUSH_ARG1(); break;
3554 /* prim #%get-cont */
3559 /* prim #%graft-to-cont */
3561 arg1
= POP(); /* thunk to call */
3562 cont
= POP(); /* continuation */
3569 handle_arity_and_rest_param ();
3579 /* prim #%return-to-cont */
3581 arg1
= POP(); /* value to return */
3582 cont
= POP(); /* continuation */
3584 arg2
= ram_get_cdr (cont
);
3586 pc
= ram_get_entry (arg2
);
3588 env
= ram_get_cdr (arg2
);
3589 cont
= ram_get_car (cont
);
3599 /* prim #%symbol? */
3600 arg1
= POP(); prim_symbolp (); PUSH_ARG1(); break;
3602 /* prim #%string? */
3603 arg1
= POP(); prim_stringp (); PUSH_ARG1(); break;
3605 /* prim #%string->list */
3606 arg1
= POP(); prim_string2list (); PUSH_ARG1(); break;
3608 /* prim #%list->string */
3609 arg1
= POP(); prim_list2string (); PUSH_ARG1(); break;
3611 /* prim #%make-u8vector */
3612 arg2
= POP(); arg1
= POP(); prim_make_u8vector (); PUSH_ARG1(); break;
3614 /* prim #%u8vector-ref */
3615 arg2
= POP(); arg1
= POP(); prim_u8vector_ref (); PUSH_ARG1(); break;
3617 /* prim #%u8vector-set! */
3618 arg3
= POP(); arg2
= POP(); arg1
= POP(); prim_u8vector_set (); break;
3623 /***************************************************************************/
3626 IF_TRACE(printf(" (%s)\n", prim_name
[bytecode_lo4
+32]));
3628 switch (bytecode_lo4
)
3637 prim_clock (); PUSH_ARG1(); break;
3640 arg2
= POP(); arg1
= POP(); prim_motor (); break;
3643 arg3
= POP(); arg2
= POP(); arg1
= POP(); prim_led (); ;break;
3645 /* prim #%led2-color */
3646 arg1
= POP(); prim_led2_color (); break;
3648 /* prim #%getchar-wait */
3649 arg2
= POP(); arg1
= POP(); prim_getchar_wait (); PUSH_ARG1(); break;
3651 /* prim #%putchar */
3652 arg2
= POP(); arg1
= POP(); prim_putchar (); break;
3655 arg2
= POP(); arg1
= POP(); prim_beep (); break;
3658 arg1
= POP(); prim_adc (); PUSH_ARG1(); break;
3660 /* prim #%u8vector? */
3661 arg1
= POP(); prim_u8vectorp (); PUSH_ARG1(); break;
3664 prim_sernum (); PUSH_ARG1(); break;
3666 /* prim #%u8vector-length */
3667 arg1
= POP(); prim_u8vector_length (); PUSH_ARG1(); break;
3669 /* prim #%u8vector-copy! */
3670 arg5
= POP(); arg4
= POP(); arg3
= POP(); arg2
= POP(); arg1
= POP();
3671 prim_u8vector_copy (); break;
3686 arg2
= ram_get_cdr (cont
);
3687 pc
= ram_get_entry (arg2
);
3688 env
= ram_get_cdr (arg2
);
3689 cont
= ram_get_car (cont
);
3697 /***************************************************************************/
3701 IF_TRACE(printf(" (%s)\n", prim_name
[bytecode_lo4
]));
3703 switch (bytecode_lo4
)
3706 /* prim #%boolean? */
3707 arg1
= POP(); prim_booleanp (); PUSH_ARG1(); break;
3709 /* prim #%network-init */
3710 prim_network_init (); break;
3712 /* prim #%network-cleanup */
3713 prim_network_cleanup (); break;
3715 /* prim #%receive-packet-to-u8vector */
3716 arg1
= POP(); prim_receive_packet_to_u8vector (); PUSH_ARG1(); break;
3718 /* prim #%send-packet-from-u8vector */
3719 arg2
= POP(); arg1
= POP(); prim_send_packet_from_u8vector ();
3747 /***************************************************************************/
3752 /*---------------------------------------------------------------------------*/
3758 printf ("usage: sim file.hex\n");
3762 int main (int argc
, char *argv
[])
3765 rom_addr rom_start_addr
= 0;
3767 test(); // TODO arithmetic test
3769 if (argc
> 1 && argv
[1][0] == '-' && argv
[1][1] == 's')
3776 if ((h1
= hex (argv
[1][2])) < 0 ||
3777 (h2
= hex (argv
[1][3])) < 0 ||
3778 (h3
= hex (argv
[1][4])) != 0 ||
3779 (h4
= hex (argv
[1][5])) != 0 ||
3783 rom_start_addr
= (h1
<< 12) | (h2
<< 8) | (h3
<< 4) | h4
;
3790 printf ("Start address = 0x%04x\n", rom_start_addr
+ CODE_START
);
3796 if (!read_hex_file (argv
[1]))
3797 printf ("*** Could not read hex file \"%s\"\n", argv
[1]);
3802 if (rom_get (CODE_START
+0) != 0xfb ||
3803 rom_get (CODE_START
+1) != 0xd7)
3804 printf ("*** The hex file was not compiled with PICOBIT\n");
3808 for (i
=0; i
<8192; i
++)
3809 if (rom_get (i
) != 0xff)
3810 printf ("rom_mem[0x%04x] = 0x%02x\n", i
, rom_get (i
));
3816 printf ("**************** memory needed = %d\n", max_live
+1);
3826 /*---------------------------------------------------------------------------*/