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 #define INFINITE_PRECISION_BIGNUMS
18 /*---------------------------------------------------------------------------*/
23 typedef unsigned char uint8
;
24 typedef unsigned short uint16
;
25 typedef unsigned long uint32
;
27 /*---------------------------------------------------------------------------*/
47 static volatile near uint8 FW_VALUE_UP @
0x33;
48 static volatile near uint8 FW_VALUE_HI @
0x33;
49 static volatile near uint8 FW_VALUE_LO @
0x33;
51 #define ACTIVITY_LED1_LAT LATB
52 #define ACTIVITY_LED1_BIT 5
53 #define ACTIVITY_LED2_LAT LATB
54 #define ACTIVITY_LED2_BIT 4
55 static volatile near bit ACTIVITY_LED1 @
((unsigned)&ACTIVITY_LED1_LAT
*8)+ACTIVITY_LED1_BIT
;
56 static volatile near bit ACTIVITY_LED2 @
((unsigned)&ACTIVITY_LED2_LAT
*8)+ACTIVITY_LED2_BIT
;
69 #define MAX_PACKET_SIZE BUFSIZ
73 char errbuf
[PCAP_ERRBUF_SIZE
];
76 #define INTERFACE "eth0"
78 char buf
[MAX_PACKET_SIZE
]; // buffer for writing
82 #include <sys/types.h>
83 #include <sys/timeb.h>
92 /*---------------------------------------------------------------------------*/
96 #define CODE_START 0x5000
100 #define IF_GC_TRACE(x) x
103 #define IF_GC_TRACE(x)
106 /*---------------------------------------------------------------------------*/
111 #define ERROR(prim, msg) halt_with_error()
112 #define TYPE_ERROR(prim, type) halt_with_error()
119 #define ERROR(prim, msg) error (prim, msg)
120 #define TYPE_ERROR(prim, type) type_error (prim, type)
122 void error (char *prim
, char *msg
)
124 printf ("ERROR: %s: %s\n", prim
, msg
);
128 void type_error (char *prim
, char *type
)
130 printf ("ERROR: %s: An argument of type %s was expected\n", prim
, type
);
137 /*---------------------------------------------------------------------------*/
145 typedef uint16 ram_addr
;
146 typedef uint16 rom_addr
;
150 #ifdef INFINITE_PRECISION_BIGNUMS
152 #define digit_width 16
155 typedef uint16 digit
;
156 typedef uint32 two_digit
;
160 /*---------------------------------------------------------------------------*/
162 #define MAX_VEC_ENCODING 8191
163 #define MIN_VEC_ENCODING 4096
164 #define VEC_BYTES ((MAX_VEC_ENCODING - MIN_VEC_ENCODING + 1)*4)
165 // TODO this is new. if the pic has less than 8k of memory, start this lower
166 // TODO the pic actually has 2k, so change these
167 // 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
169 #define MAX_RAM_ENCODING 4095
170 #define MIN_RAM_ENCODING 512
171 #define RAM_BYTES ((MAX_RAM_ENCODING - MIN_RAM_ENCODING + 1)*4)
172 // TODO watch out if we address more than what the PIC actually has
175 #define OBJ_TO_VEC_ADDR(o,f) (((ram_addr)((uint16)(o) - MIN_RAM_ENCODING) << 2) + (f))
176 #define OBJ_TO_RAM_ADDR(o,f) (((ram_addr)((uint16)(o) - MIN_RAM_ENCODING) << 2) + (f))
177 #define OBJ_TO_ROM_ADDR(o,f) (((rom_addr)((uint16)(o) - MIN_ROM_ENCODING) << 2) + (CODE_START + 4 + (f)))
182 #define ram_get(a) *(uint8*)(a+0x200)
183 #define ram_set(a,x) *(uint8*)(a+0x200) = (x)
189 uint8 ram_mem
[RAM_BYTES
+ VEC_BYTES
];
191 #define ram_get(a) ram_mem[a]
192 #define ram_set(a,x) ram_mem[a] = (x)
197 /*---------------------------------------------------------------------------*/
201 uint8
rom_get (rom_addr a
)
203 return *(rom uint8
*)a
;
211 #define ROM_BYTES 8192
212 // TODO the new pics have 32k, change this ? minus the vm size, firmware ?
214 uint8 rom_mem
[ROM_BYTES
] =
217 #define PUTCHAR_LIGHT_not
220 0xFB, 0xD7, 0x03, 0x00, 0x00, 0x00, 0x00, 0x32
221 , 0x03, 0x00, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00
222 , 0x08, 0x50, 0x80, 0x16, 0xFE, 0xE8, 0x00, 0xFC
223 , 0x32, 0x80, 0x2D, 0xFE, 0xFC, 0x31, 0x80, 0x43
224 , 0xFE, 0xFC, 0x33, 0x80, 0x2D, 0xFE, 0xFC, 0x31
225 , 0x80, 0x43, 0xFE, 0x90, 0x16, 0x01, 0x20, 0xFC
226 , 0x32, 0xE3, 0xB0, 0x37, 0x09, 0xF3, 0xFF, 0x20
227 , 0xFC, 0x33, 0xE3, 0xB0, 0x40, 0x0A, 0xF3, 0xFF
228 , 0x08, 0xF3, 0xFF, 0x01, 0x40, 0x21, 0xD1, 0x00
229 , 0x02, 0xC0, 0x4C, 0x71, 0x01, 0x20, 0x50, 0x90
230 , 0x51, 0x00, 0xF1, 0x40, 0xD8, 0xB0, 0x59, 0x90
234 0xFB, 0xD7, 0x00, 0x00, 0x80, 0x08, 0xFE, 0xE8
235 , 0x00, 0xF6, 0xF5, 0x90, 0x08
239 uint8
rom_get (rom_addr a
)
241 return rom_mem
[a
-CODE_START
];
246 /*---------------------------------------------------------------------------*/
254 fixnum n MIN_FIXNUM -> 3 ... MAX_FIXNUM -> 3 + (MAX_FIXNUM-MIN_FIXNUM)
255 rom object 4 + (MAX_FIXNUM-MIN_FIXNUM) ... MIN_RAM_ENCODING-1
256 ram object MIN_RAM_ENCODING ... MAX_RAM_ENCODING
257 u8vector MIN_VEC_ENCODING ... 8191
259 layout of memory allocated objects:
261 G's represent mark bits used by the gc
263 ifdef INFINITE_PRECISION_BIGNUMS
264 bignum n 000***** **next** hhhhhhhh llllllll (16 bit digit)
265 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, not implement this pointer FOOBIGNUM
267 ifndef INFINITE_PRECISION_BIGNUMS
268 bignum n 00000000 uuuuuuuu hhhhhhhh llllllll (24 bit signed integer)
270 pair 1GGaaaaa aaaaaaaa 000ddddd dddddddd
273 gives an address space of 2^13 * 4 = 32k divided between simple objects,
276 symbol 1GG00000 00000000 00100000 00000000
278 string 1GG***** *chars** 01000000 00000000
280 u8vector 1GGxxxxx xxxxxxxx 011yyyyy yyyyyyyy
281 x is length of the vector, in bytes (stored raw, not encoded as an object)
282 y is pointer to the elements themselves (stored in vector space)
284 closure 01Gaaaaa aaaaaaaa aaaxxxxx xxxxxxxx
285 0x5ff<a<0x4000 is entry
286 x is pointer to environment
287 the reason why the environment is on the cdr (and the entry is split on 3
288 bytes) is that, when looking for a variable, a closure is considered to be a
289 pair. The compiler adds an extra offset to any variable in the closure's
290 environment, so the car of the closure (which doesn't really exist) is never
291 checked, but the cdr is followed to find the other bindings
293 continuation 1GGxxxxx xxxxxxxx 100yyyyy yyyyyyyy
294 x is parent continuation
295 y is pointer to the second half, which is a closure (contains env and entry)
297 An environment is a list of objects built out of pairs. On entry to
298 a procedure the environment is the list of parameters to which is
299 added the environment of the closure being called.
301 The first byte at the entry point of a procedure gives the arity of
304 n = 0 to 127 -> procedure has n parameters (no rest parameter)
305 n = -128 to -1 -> procedure has -n parameters, the last is
311 #define encode_bool(x) ((obj)(x))
315 #define MIN_FIXNUM_ENCODING 3
316 // TODO change these ? were -5 and 40, with the new bignums, the needs for these might change
318 #define MAX_FIXNUM 255
319 #define MIN_ROM_ENCODING (MIN_FIXNUM_ENCODING+MAX_FIXNUM-MIN_FIXNUM+1)
321 #define ENCODE_FIXNUM(n) ((obj)(n) + (MIN_FIXNUM_ENCODING - MIN_FIXNUM))
322 #define DECODE_FIXNUM(o) ((int32)(o) - (MIN_FIXNUM_ENCODING - MIN_FIXNUM))
324 // TODO why this ifdef ?
326 #define IN_VEC(o) ((o) >= MIN_VEC_ENCODING)
327 #define IN_RAM(o) (!IN_VEC(o) && ((o) >= MIN_RAM_ENCODING))
328 #define IN_ROM(o) (!IN_VEC(o) && !IN_RAM(o) && ((o) >= MIN_ROM_ENCODING))
331 // bignum first byte : 00Gxxxxx
332 #define BIGNUM_FIELD0 0
333 #define RAM_BIGNUM(o) ((ram_get_field0 (o) & 0xc0) == BIGNUM_FIELD0)
334 #define ROM_BIGNUM(o) ((rom_get_field0 (o) & 0xc0) == BIGNUM_FIELD0)
336 // composite first byte : 1GGxxxxx
337 #define COMPOSITE_FIELD0 0x80
338 #define RAM_COMPOSITE(o) ((ram_get_field0 (o) & 0x80) == COMPOSITE_FIELD0)
339 #define ROM_COMPOSITE(o) ((rom_get_field0 (o) & 0x80) == COMPOSITE_FIELD0)
341 // pair third byte : 000xxxxx
342 #define PAIR_FIELD2 0
343 #define RAM_PAIR(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == PAIR_FIELD2))
344 #define ROM_PAIR(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == PAIR_FIELD2))
346 // symbol third byte : 001xxxxx
347 #define SYMBOL_FIELD2 0x20
348 #define RAM_SYMBOL(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == SYMBOL_FIELD2))
349 #define ROM_SYMBOL(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == SYMBOL_FIELD2))
351 // string third byte : 010xxxxx
352 #define STRING_FIELD2 0x40
353 #define RAM_STRING(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == STRING_FIELD2))
354 #define ROM_STRING(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == STRING_FIELD2))
356 // vector third byte : 011xxxxx
357 #define VECTOR_FIELD2 0x60
358 #define RAM_VECTOR(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == VECTOR_FIELD2))
359 #define ROM_VECTOR(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == VECTOR_FIELD2))
361 // continuation third byte : 100xxxxx
362 #define CONTINUATION_FIELD2 0x80
363 #define RAM_CONTINUATION(o) (RAM_COMPOSITE (o) && ((ram_get_field2 (o) & 0xe0) == CONTINUATION_FIELD2))
364 #define ROM_CONTINUATION(o) (ROM_COMPOSITE (o) && ((rom_get_field2 (o) & 0xe0) == CONTINUATION_FIELD2))
366 // closure first byte : 01Gxxxxx
367 #define CLOSURE_FIELD0 0x40
368 #define RAM_CLOSURE(o) ((ram_get_field0 (o) & 0xc0) == CLOSURE_FIELD0)
369 #define ROM_CLOSURE(o) ((rom_get_field0 (o) & 0xc0) == CLOSURE_FIELD0)
372 /*---------------------------------------------------------------------------*/
374 #define RAM_GET_FIELD0_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,0))
375 #define RAM_SET_FIELD0_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,0), val)
376 #define ROM_GET_FIELD0_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,0))
378 #define RAM_GET_GC_TAGS_MACRO(o) (RAM_GET_FIELD0_MACRO(o) & 0x60)
379 #define RAM_GET_GC_TAG0_MACRO(o) (RAM_GET_FIELD0_MACRO(o) & 0x20)
380 #define RAM_GET_GC_TAG1_MACRO(o) (RAM_GET_FIELD0_MACRO(o) & 0x40)
381 #define RAM_SET_GC_TAGS_MACRO(o,tags) \
382 (RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0x9f) | (tags)))
383 #define RAM_SET_GC_TAG0_MACRO(o,tag) \
384 RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xdf) | (tag))
385 #define RAM_SET_GC_TAG1_MACRO(o,tag) \
386 RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xbf) | (tag))
389 #define RAM_GET_FIELD1_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,1))
390 #define RAM_GET_FIELD2_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,2))
391 #define RAM_GET_FIELD3_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,3))
392 #define RAM_SET_FIELD1_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,1), val)
393 #define RAM_SET_FIELD2_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,2), val)
394 #define RAM_SET_FIELD3_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,3), val)
395 #define ROM_GET_FIELD1_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,1))
396 #define ROM_GET_FIELD2_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,2))
397 #define ROM_GET_FIELD3_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,3))
398 #define VEC_GET_BYTE0_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,0))
399 #define VEC_GET_BYTE1_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,1))
400 #define VEC_GET_BYTE2_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,2))
401 #define VEC_GET_BYTE3_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,3))
402 #define VEC_SET_BYTE0_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,0), val)
403 #define VEC_SET_BYTE1_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,1), val)
404 #define VEC_SET_BYTE2_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,2), val)
405 #define VEC_SET_BYTE3_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,3), val)
408 uint8
ram_get_gc_tags (obj o
) { return RAM_GET_GC_TAGS_MACRO(o
); }
409 uint8
ram_get_gc_tag0 (obj o
) { return RAM_GET_GC_TAG0_MACRO(o
); }
410 uint8
ram_get_gc_tag1 (obj o
) { return RAM_GET_GC_TAG1_MACRO(o
); }
411 void ram_set_gc_tags (obj o
, uint8 tags
) { RAM_SET_GC_TAGS_MACRO(o
, tags
); }
412 void ram_set_gc_tag0 (obj o
, uint8 tag
) { RAM_SET_GC_TAG0_MACRO(o
,tag
); }
413 void ram_set_gc_tag1 (obj o
, uint8 tag
) { RAM_SET_GC_TAG1_MACRO(o
,tag
); }
414 uint8
ram_get_field0 (obj o
) { return RAM_GET_FIELD0_MACRO(o
); }
415 word
ram_get_field1 (obj o
) { return RAM_GET_FIELD1_MACRO(o
); }
416 word
ram_get_field2 (obj o
) { return RAM_GET_FIELD2_MACRO(o
); }
417 word
ram_get_field3 (obj o
) { return RAM_GET_FIELD3_MACRO(o
); }
418 word
ram_get_fieldn (obj o
, uint8 n
)
422 case 0: return ram_get_field0 (o
);
423 case 1: return ram_get_field1 (o
);
424 case 2: return ram_get_field2 (o
);
425 case 3: return ram_get_field3 (o
);
428 void ram_set_field0 (obj o
, uint8 val
) { RAM_SET_FIELD0_MACRO(o
,val
); }
429 void ram_set_field1 (obj o
, word val
) { RAM_SET_FIELD1_MACRO(o
,val
); }
430 void ram_set_field2 (obj o
, word val
) { RAM_SET_FIELD2_MACRO(o
,val
); }
431 void ram_set_field3 (obj o
, word val
) { RAM_SET_FIELD3_MACRO(o
,val
); }
432 void ram_set_fieldn (obj o
, uint8 n
, word val
)
436 case 0: ram_set_field0 (o
, val
); break;
437 case 1: ram_set_field1 (o
, val
); break;
438 case 2: ram_set_field2 (o
, val
); break;
439 case 3: ram_set_field3 (o
, val
); break;
442 uint8
rom_get_field0 (obj o
) { return ROM_GET_FIELD0_MACRO(o
); }
443 word
rom_get_field1 (obj o
) { return ROM_GET_FIELD1_MACRO(o
); }
444 word
rom_get_field2 (obj o
) { return ROM_GET_FIELD2_MACRO(o
); }
445 word
rom_get_field3 (obj o
) { return ROM_GET_FIELD3_MACRO(o
); }
446 /* word vec_get_byte0 (obj o) { return VEC_GET_BYTE0_MACRO(o); } */
447 /* word vec_get_byte1 (obj o) { return VEC_GET_BYTE1_MACRO(o); } */
448 /* word vec_get_byte2 (obj o) { return VEC_GET_BYTE2_MACRO(o); } */
449 /* word vec_get_byte3 (obj o) { return VEC_GET_BYTE3_MACRO(o); } */
450 /* word vec_set_byte0 (obj o, word val) { VEC_SET_BYTE0_MACRO(o,val); } */
451 /* word vec_set_byte1 (obj o, word val) { VEC_SET_BYTE1_MACRO(o,val); } */
452 /* word vec_set_byte2 (obj o, word val) { VEC_SET_BYTE2_MACRO(o,val); } */
453 /* word vec_set_byte3 (obj o, word val) { VEC_SET_BYTE3_MACRO(o,val); } */
455 obj
get_field0 (obj o
) // TODO these are not used yet, will they be useful at all ?
458 return ram_get_field0 (o
);
460 return rom_get_field0 (o
);
462 obj
get_field1 (obj o
)
465 return ram_get_field1 (o
);
467 return rom_get_field1 (o
);
469 obj
get_field2 (obj o
)
472 return ram_get_field2 (o
);
474 return rom_get_field2 (o
);
476 obj
get_field3 (obj o
)
479 return ram_get_field3 (o
);
481 return rom_get_field3 (o
);
485 obj
ram_get_car (obj o
)
486 { return ((ram_get_field0 (o
) & 0x1f) << 8) | ram_get_field1 (o
); }
487 obj
rom_get_car (obj o
)
488 { return ((rom_get_field0 (o
) & 0x1f) << 8) | rom_get_field1 (o
); }
489 obj
ram_get_cdr (obj o
)
490 { return ((ram_get_field2 (o
) & 0x1f) << 8) | ram_get_field3 (o
); }
491 obj
rom_get_cdr (obj o
)
492 { return ((rom_get_field2 (o
) & 0x1f) << 8) | rom_get_field3 (o
); }
496 return ram_get_car (o
);
498 return rom_get_car (o
);
503 return ram_get_cdr (o
);
505 return rom_get_cdr (o
);
508 void ram_set_car (obj o
, obj val
)
510 ram_set_field0 (o
, (val
>> 8) | (ram_get_field0 (o
) & 0xe0));
511 ram_set_field1 (o
, val
& 0xff);
513 void ram_set_cdr (obj o
, obj val
)
515 ram_set_field2 (o
, (val
>> 8) | (ram_get_field2 (o
) & 0xe0));
516 ram_set_field3 (o
, val
& 0xff);
519 obj
ram_get_entry (obj o
)
521 return (((ram_get_field0 (o
) & 0x1f) << 11)
522 | (ram_get_field1 (o
) << 3)
523 | (ram_get_field2 (o
) >> 5));
525 obj
rom_get_entry (obj o
)
527 return (((rom_get_field0 (o
) & 0x1f) << 11)
528 | (rom_get_field1 (o
) << 3)
529 | (rom_get_field2 (o
) >> 5));
531 obj
get_entry (obj o
)
534 return ram_get_entry (o
);
536 return rom_get_entry (o
);
540 obj
get_global (uint8 i
)
541 // globals occupy the beginning of ram, with 2 globals per word
544 return ram_get_cdr (MIN_RAM_ENCODING
+ (i
/ 2));
546 return ram_get_car (MIN_RAM_ENCODING
+ (i
/ 2));
549 void set_global (uint8 i
, obj o
)
552 ram_set_cdr (MIN_RAM_ENCODING
+ (i
/ 2), o
);
554 ram_set_car (MIN_RAM_ENCODING
+ (i
/ 2), o
);
558 void show_type (obj o
) // for debugging purposes
561 if (o
== OBJ_FALSE
) printf("#f");
562 else if (o
== OBJ_TRUE
) printf("#t");
563 else if (o
== OBJ_NULL
) printf("()");
564 else if (o
< MIN_ROM_ENCODING
) printf("fixnum");
567 if (RAM_BIGNUM(o
)) printf("ram bignum");
568 else if (RAM_PAIR(o
)) printf("ram pair");
569 else if (RAM_SYMBOL(o
)) printf("ram symbol");
570 else if (RAM_STRING(o
)) printf("ram string");
571 else if (RAM_VECTOR(o
)) printf("ram vector");
572 else if (RAM_CONTINUATION(o
)) printf("ram continuation");
573 else if (RAM_CLOSURE(o
)) printf("ram closure");
577 if (ROM_BIGNUM(o
)) printf("rom bignum");
578 else if (ROM_PAIR(o
)) printf("rom pair");
579 else if (ROM_SYMBOL(o
)) printf("rom symbol");
580 else if (ROM_STRING(o
)) printf("rom string");
581 else if (ROM_VECTOR(o
)) printf("rom vector");
582 else if (ROM_CONTINUATION(o
)) printf("rom continuation");
583 else if (RAM_CLOSURE(o
)) printf("rom closure");
590 /*---------------------------------------------------------------------------*/
592 /* Interface to GC */
594 // TODO explain what each tag means, with 1-2 mark bits
595 #define GC_TAG_0_LEFT (1<<5)
596 #define GC_TAG_1_LEFT (2<<5)
597 #define GC_TAG_UNMARKED (0<<5)
599 /* Number of object fields of objects in ram */
600 #define HAS_2_OBJECT_FIELDS(visit) (RAM_PAIR(visit) || RAM_CONTINUATION(visit))
601 #ifdef INFINITE_PRECISION_BIGNUMS
602 #define HAS_1_OBJECT_FIELD(visit) (RAM_COMPOSITE(visit) \
603 || RAM_CLOSURE(visit) || RAM_BIGNUM(visit))
605 #define HAS_1_OBJECT_FIELD(visit) (RAM_COMPOSITE(visit) || RAM_CLOSURE(visit))
607 // all composites except pairs and continuations have 1 object field
609 #define NIL OBJ_FALSE
611 /*---------------------------------------------------------------------------*/
613 /* Garbage collector */
615 obj free_list
; /* list of unused cells */
616 obj free_list_vec
; /* list of unused cells in vector space */
618 obj arg1
; /* root set */
626 uint8 na
; /* interpreter variables */
637 void init_ram_heap (void)
640 obj o
= MAX_RAM_ENCODING
;
644 while (o
> (MIN_RAM_ENCODING
+ (glovars
+ 1) / 2))
645 // we don't want to add globals to the free list, and globals occupy the
646 // beginning of memory at the rate of 2 globals per word (car and cdr)
648 ram_set_gc_tags (o
, GC_TAG_UNMARKED
);
649 ram_set_car (o
, free_list
);
654 free_list_vec
= MIN_VEC_ENCODING
;
655 ram_set_car (free_list_vec
, 0);
656 // each node of the free list must know the free length that follows it
657 // this free length is stored in words, not in bytes
658 // if we did count in bytes, the number might need more than 13 bits
659 ram_set_cdr (free_list_vec
, VEC_BYTES
/ 4);
661 for (i
=0; i
<glovars
; i
++)
662 set_global (i
, OBJ_FALSE
);
689 IF_GC_TRACE(printf ("push stack=%d visit=%d (tag=%d)\n", stack
, visit
, ram_get_gc_tags (visit
)>>5));
691 if ((HAS_1_OBJECT_FIELD (visit
) && ram_get_gc_tag0 (visit
))
692 || (HAS_2_OBJECT_FIELDS (visit
)
693 && (ram_get_gc_tags (visit
) != GC_TAG_UNMARKED
)))
694 IF_GC_TRACE(printf ("case 1\n"));
697 if (HAS_2_OBJECT_FIELDS(visit
)) // pairs and continuations
699 IF_GC_TRACE(printf ("case 2\n"));
703 temp
= ram_get_cdr (visit
);
707 IF_GC_TRACE(printf ("case 3\n"));
708 ram_set_gc_tags (visit
, GC_TAG_1_LEFT
);
709 ram_set_cdr (visit
, stack
);
713 IF_GC_TRACE(printf ("case 4\n"));
718 if (HAS_1_OBJECT_FIELD(visit
))
720 IF_GC_TRACE(printf ("case 5\n"));
724 if (RAM_CLOSURE(visit
)) // closures have the pointer in the cdr
725 temp
= ram_get_cdr (visit
);
727 temp
= ram_get_car (visit
);
731 IF_GC_TRACE(printf ("case 6\n"));
732 ram_set_gc_tag0 (visit
, GC_TAG_0_LEFT
);
733 if (RAM_CLOSURE(visit
))
734 ram_set_cdr (visit
, stack
);
736 ram_set_car (visit
, stack
);
741 IF_GC_TRACE(printf ("case 7\n"));
744 IF_GC_TRACE(printf ("case 8\n"));
746 ram_set_gc_tag0 (visit
, GC_TAG_0_LEFT
);
751 IF_GC_TRACE(printf ("pop stack=%d visit=%d (tag=%d)\n", stack
, visit
, ram_get_gc_tags (visit
)>>6));
755 if (HAS_2_OBJECT_FIELDS(stack
) && ram_get_gc_tag1 (stack
))
757 IF_GC_TRACE(printf ("case 9\n"));
759 temp
= ram_get_cdr (stack
); /* pop through cdr */
760 ram_set_cdr (stack
, visit
);
764 ram_set_gc_tag1(visit
, GC_TAG_UNMARKED
);
765 // we unset the "1-left" bit
770 if (RAM_CLOSURE(stack
))
771 // closures have one object field, but it's in the cdr
773 IF_GC_TRACE(printf ("case 10\n"));
775 temp
= ram_get_cdr (stack
); /* pop through cdr */
776 ram_set_cdr (stack
, visit
);
783 IF_GC_TRACE(printf ("case 11\n"));
785 temp
= ram_get_car (stack
); /* pop through car */
786 ram_set_car (stack
, visit
);
807 obj visit
= MAX_RAM_ENCODING
;
811 while (visit
>= (MIN_RAM_ENCODING
+ ((glovars
+ 1) / 2)))
812 // we don't want to sweep the global variables area
814 if ((RAM_COMPOSITE(visit
)
815 && (ram_get_gc_tags (visit
) == GC_TAG_UNMARKED
)) // 2 mark bit
816 || !(ram_get_gc_tags (visit
) & GC_TAG_0_LEFT
)) // 1 mark bit
819 if (RAM_VECTOR(visit
))
820 // when we sweep a vector, we also have to sweep its contents
822 obj o
= ram_get_cdr (visit
);
823 uint16 i
= ram_get_car (visit
); // number of elements
824 ram_set_car (o
, free_list_vec
);
825 ram_set_cdr (o
, (i
+ 3) / 4); // free length, in words
827 // TODO merge free spaces
829 ram_set_car (visit
, free_list
);
834 if (RAM_COMPOSITE(visit
))
835 ram_set_gc_tags (visit
, GC_TAG_UNMARKED
);
836 else // only 1 mark bit to unset
837 ram_set_gc_tag0 (visit
, GC_TAG_UNMARKED
);
849 printf ("**************** memory needed = %d\n", max_live
+1);
859 IF_TRACE(printf("\nGC BEGINS\n"));
861 IF_GC_TRACE(printf("arg1\n"));
863 IF_GC_TRACE(printf("arg2\n"));
865 IF_GC_TRACE(printf("arg3\n"));
867 IF_GC_TRACE(printf("arg4\n"));
869 IF_GC_TRACE(printf("arg5\n"));
871 IF_GC_TRACE(printf("cont\n"));
873 IF_GC_TRACE(printf("env\n"));
876 IF_GC_TRACE(printf("globals\n"));
877 for (i
=0; i
<glovars
; i
++)
878 mark (get_global (i
));
883 obj
alloc_ram_cell (void)
897 ERROR("alloc_ram_cell", "memory is full");
902 free_list
= ram_get_car (o
);
907 obj
alloc_ram_cell_init (uint8 f0
, uint8 f1
, uint8 f2
, uint8 f3
)
909 obj o
= alloc_ram_cell ();
911 ram_set_field0 (o
, f0
);
912 ram_set_field1 (o
, f1
);
913 ram_set_field2 (o
, f2
);
914 ram_set_field3 (o
, f3
);
919 obj
alloc_vec_cell (uint16 n
)
921 obj o
= free_list_vec
;
930 while ((ram_get_cdr (o
) * 4) < n
) // free space too small
932 if (o
== 0) // no free space, or none big enough
934 if (gc_done
) // we gc'd, but no space is big enough for the vector
935 ERROR("alloc_vec_cell", "no room for vector");
943 } // TODO merge adjacent free spaces, maybe compact ?
948 // case 1 : the new vector fills every free word advertized, we remove the
949 // node from the free list
950 if (((ram_get_cdr(o
) * 4) - n
) < 4)
953 ram_set_car (prec
, ram_get_car (o
));
955 free_list_vec
= ram_get_car (o
);
957 // case 2 : there is still some space left in the free section, create a new
958 // node to represent this space
961 obj new_free
= o
+ (n
+ 3)/4;
963 ram_set_car (prec
, new_free
);
965 free_list_vec
= new_free
;
966 ram_set_car (new_free
, ram_get_car (o
));
967 ram_set_cdr (new_free
, ram_get_cdr (o
) - (n
+ 3)/4);
973 /*---------------------------------------------------------------------------*/
975 #ifdef INFINITE_PRECISION_BIGNUMS
977 // TODO FOOBIGNUMS this was taken from the bignum code, see if it works
978 int8
decode_int8 (obj o
)
982 if (o
< MIN_FIXNUM_ENCODING
)
983 TYPE_ERROR("decode_int8", "integer");
985 if (o
<= (MIN_FIXNUM_ENCODING
+ (MAX_FIXNUM
- MIN_FIXNUM
)))
986 return DECODE_FIXNUM(o
);
991 TYPE_ERROR("decode_int8", "integer");
993 return ram_get_field3 (o
);
998 TYPE_ERROR("decode_int8", "integer");
1000 return rom_get_field3 (o
);
1003 TYPE_ERROR("decode_int8", "integer");
1005 // TODO how could this possibly work ? it does not consider other fields, same for encoding, get to the bottom of this
1007 int32
decode_int (obj o
)
1009 return decode_int8 (o
);
1013 obj
encode_int (int32 n
)
1015 if (n
>= MIN_FIXNUM
&& n
<= MAX_FIXNUM
)
1016 return ENCODE_FIXNUM(n
);
1018 // 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 ?
1019 return alloc_ram_cell_init (BIGNUM_FIELD0
, ENCODE_FIXNUM(0), n
>> 8, n
);
1024 int32
decode_int (obj o
)
1030 if (o
< MIN_FIXNUM_ENCODING
)
1031 TYPE_ERROR("decode_int", "integer");
1033 if (o
<= (MIN_FIXNUM_ENCODING
+ (MAX_FIXNUM
- MIN_FIXNUM
)))
1034 return DECODE_FIXNUM(o
);
1039 TYPE_ERROR("decode_int", "integer");
1041 u
= ram_get_field1 (o
);
1042 h
= ram_get_field2 (o
);
1043 l
= ram_get_field3 (o
);
1048 TYPE_ERROR("decode_int", "integer");
1050 u
= rom_get_field1 (o
);
1051 h
= rom_get_field2 (o
);
1052 l
= rom_get_field3 (o
);
1055 TYPE_ERROR("decode_int", "integer");
1057 if (u
>= 128) // TODO FOOBIGNUMS uhh, what's that again ? is here since the beginning
1058 return ((int32
)((((int16
)u
- 256) << 8) + h
) << 8) + l
;
1060 return ((int32
)(((int16
)u
<< 8) + h
) << 8) + l
;
1063 obj
encode_int (int32 n
)
1065 if (n
>= MIN_FIXNUM
&& n
<= MAX_FIXNUM
)
1066 return ENCODE_FIXNUM(n
);
1068 return alloc_ram_cell_init (BIGNUM_FIELD0
, n
>> 16, n
>> 8, n
);
1073 /*---------------------------------------------------------------------------*/
1085 else if (o
== OBJ_TRUE
)
1087 else if (o
== OBJ_NULL
)
1089 else if (o
<= (MIN_FIXNUM_ENCODING
+ (MAX_FIXNUM
- MIN_FIXNUM
)))
1090 printf ("%d", DECODE_FIXNUM(o
));
1100 if ((in_ram
&& RAM_BIGNUM(o
)) || (!in_ram
&& ROM_BIGNUM(o
)))
1101 printf ("%d", decode_int (o
));
1102 else if ((in_ram
&& RAM_COMPOSITE(o
)) || (!in_ram
&& ROM_COMPOSITE(o
)))
1107 if ((in_ram
&& RAM_PAIR(o
)) || (!in_ram
&& ROM_PAIR(o
)))
1111 car
= ram_get_car (o
);
1112 cdr
= ram_get_cdr (o
);
1116 car
= rom_get_car (o
);
1117 cdr
= rom_get_cdr (o
);
1126 if (cdr
== OBJ_NULL
)
1128 else if ((IN_RAM(cdr
) && RAM_PAIR(cdr
))
1129 || (IN_ROM(cdr
) && ROM_PAIR(cdr
)))
1133 car
= ram_get_car (cdr
);
1134 cdr
= ram_get_cdr (cdr
);
1138 car
= rom_get_car (cdr
);
1139 cdr
= rom_get_cdr (cdr
);
1152 else if ((in_ram
&& RAM_SYMBOL(o
)) || (!in_ram
&& ROM_SYMBOL(o
)))
1153 printf ("#<symbol>");
1154 else if ((in_ram
&& RAM_STRING(o
)) || (!in_ram
&& ROM_STRING(o
)))
1155 printf ("#<string>");
1156 else if ((in_ram
&& RAM_VECTOR(o
)) || (!in_ram
&& ROM_VECTOR(o
)))
1157 printf ("#<vector %d>", o
);
1161 car
= ram_get_car (o
);
1162 cdr
= ram_get_cdr (o
);
1163 // ugly hack, takes advantage of the fact that pairs and
1164 // continuations have the same layout
1174 env
= ram_get_cdr (o
);
1176 env
= rom_get_cdr (o
);
1179 pc
= ram_get_entry (o
);
1181 pc
= rom_get_entry (o
);
1183 printf ("{0x%04x ", pc
);
1192 void show_state (rom_addr pc
)
1195 printf ("pc=0x%04x bytecode=0x%02x env=", pc
, rom_get (pc
));
1212 /*---------------------------------------------------------------------------*/
1214 /* Integer operations */
1216 // TODO FOOBIGNUMS big pasted and NOT CHECKED section here
1217 #ifdef INFINITE_PRECISION_BIGNUMS
1219 #define obj_eq(x,y) ((x) == (y))
1221 #define integer_hi_set(x,y) ram_set_field1 (x, y)
1223 #define ZERO ENCODE_FIXNUM(0)
1224 #define NEG1 (ZERO-1)
1225 #define POS1 (ZERO+1)
1227 integer
fixnum (int8 n
)
1229 return ENCODE_FIXNUM (n
);
1232 integer
make_integer (digit lo
, integer hi
)
1234 return alloc_ram_cell_init (BIGNUM_FIELD0
, hi
, lo
>> 8, lo
);
1237 integer
integer_hi (integer x
)
1240 return ram_get_field1 (x
);
1242 return rom_get_field1 (x
);
1243 else if (x
< (MIN_FIXNUM_ENCODING
- MIN_FIXNUM
))
1244 return NEG1
; /* negative fixnum */
1246 return ZERO
; /* nonnegative fixnum */
1249 digit
integer_lo (integer x
)
1252 return (((digit
)ram_get_field2 (x
)) << 8) + ram_get_field3 (x
);
1254 return (((digit
)rom_get_field2 (x
)) << 8) + rom_get_field3 (x
);
1256 return DECODE_FIXNUM(x
);
1259 integer
norm (obj prefix
, integer n
)
1261 /* norm(prefix,n) returns a normalized integer whose value is the
1262 integer n prefixed with the digits in prefix (a list of digits) */
1264 while (prefix
!= NIL
)
1266 digit d
= integer_lo (prefix
);
1269 prefix
= integer_hi (temp
);
1271 if (obj_eq (n
, ZERO
))
1273 if (d
<= MAX_FIXNUM
)
1275 n
= fixnum ((int8
)d
);
1279 else if (obj_eq (n
, NEG1
))
1281 if (d
>= (1<<digit_width
) + MIN_FIXNUM
)
1283 n
= fixnum ((int8
)(d
- (1<<digit_width
)));
1288 integer_hi_set (temp
, n
);
1295 boolean
negp (integer x
)
1297 /* negp(x) returns true iff x is negative */
1302 if (obj_eq (x
, ZERO
)) return false;
1303 } while (!obj_eq (x
, NEG1
));
1308 int8
cmp (integer x
, integer y
)
1310 /* cmp(x,y) return -1 when x<y, 1 when x>y, and 0 when x=y */
1318 if (obj_eq (x
, ZERO
) || obj_eq (x
, NEG1
))
1321 { if (negp (y
)) result
= 1; else result
= -1; }
1325 if (obj_eq (y
, ZERO
) || obj_eq (y
, NEG1
))
1327 if (negp (x
)) result
= -1; else result
= 1;
1331 xlo
= integer_lo (x
);
1332 ylo
= integer_lo (y
);
1336 { if (xlo
< ylo
) result
= -1; else result
= 1; }
1342 uint16
integer_length (integer x
)
1344 /* integer_length(x) returns the number of bits in the binary
1345 representation of the nonnegative integer x */
1351 while (!obj_eq ((next
= integer_hi (x
)), ZERO
))
1353 result
+= digit_width
;
1368 integer
shr (integer x
)
1370 /* shr(x) returns the integer x shifted one bit to the right */
1377 if (obj_eq (x
, ZERO
) || obj_eq (x
, NEG1
))
1379 result
= norm (result
, x
);
1385 result
= make_integer ((d
>> 1) |
1386 ((integer_lo (x
) & 1) ? (1<<(digit_width
-1)) : 0),
1393 integer
negative_carry (boolean carry
)
1401 integer
shl (integer x
)
1403 /* shl(x) returns the integer x shifted one bit to the left */
1405 integer negc
= ZERO
; /* negative carry */
1412 if (obj_eq (x
, negc
))
1414 result
= norm (result
, x
);
1421 negc
= negative_carry (d
& (1<<(digit_width
-1)));
1422 result
= make_integer ((d
<< 1) | obj_eq (temp
, NEG1
), result
);
1428 integer
shift_left (integer x
, uint16 n
)
1430 /* shift_left(x,n) returns the integer x shifted n bits to the left */
1432 if (obj_eq (x
, ZERO
))
1435 while (n
& (digit_width
-1))
1443 x
= make_integer (0, x
);
1450 integer
add (integer x
, integer y
)
1452 /* add(x,y) returns the sum of the integers x and y */
1454 integer negc
= ZERO
; /* negative carry */
1461 if (obj_eq (x
, negc
))
1463 result
= norm (result
, y
);
1467 if (obj_eq (y
, negc
))
1469 result
= norm (result
, x
);
1473 dx
= integer_lo (x
);
1474 dy
= integer_lo (y
);
1475 dx
= dx
+ dy
; /* may wrap around */
1477 if (obj_eq (negc
, ZERO
))
1478 negc
= negative_carry (dx
< dy
);
1481 dx
++; /* may wrap around */
1482 negc
= negative_carry (dx
<= dy
);
1488 result
= make_integer (dx
, result
);
1494 integer
invert (integer x
)
1496 if (obj_eq (x
, ZERO
))
1502 integer
sub (integer x
, integer y
)
1504 /* sub(x,y) returns the difference of the integers x and y */
1506 integer negc
= NEG1
; /* negative carry */
1513 if (obj_eq (x
, negc
) && (obj_eq (y
, ZERO
) || obj_eq (y
, NEG1
)))
1515 result
= norm (result
, invert (y
));
1519 if (obj_eq (y
, invert (negc
)))
1521 result
= norm (result
, x
);
1525 dx
= integer_lo (x
);
1526 dy
= ~integer_lo (y
);
1527 dx
= dx
+ dy
; /* may wrap around */
1529 if (obj_eq (negc
, ZERO
))
1530 negc
= negative_carry (dx
< dy
);
1533 dx
++; /* may wrap around */
1534 negc
= negative_carry (dx
<= dy
);
1540 result
= make_integer (dx
, result
);
1546 integer
neg (integer x
)
1548 /* neg(x) returns the integer -x */
1550 return sub (ZERO
, x
);
1553 integer
scale (digit n
, integer x
)
1555 /* scale(n,x) returns the integer n*x */
1561 if ((n
== 0) || obj_eq (x
, ZERO
))
1572 if (obj_eq (x
, ZERO
))
1574 if (carry
<= MAX_FIXNUM
)
1575 result
= norm (result
, fixnum ((int8
)carry
));
1577 result
= norm (result
, make_integer (carry
, ZERO
));
1581 if (obj_eq (x
, NEG1
))
1584 if (carry
>= ((1<<digit_width
) + MIN_FIXNUM
))
1585 result
= norm (result
, fixnum ((int8
)carry
));
1587 result
= norm (result
, make_integer (carry
, NEG1
));
1591 m
= (two_digit
)integer_lo (x
) * n
+ carry
;
1594 carry
= m
>> digit_width
;
1595 result
= make_integer ((digit
)m
, result
);
1601 integer
mulnonneg (integer x
, integer y
)
1603 /* mulnonneg(x,y) returns the product of the integers x and y
1604 where x is nonnegative */
1607 integer s
= scale (integer_lo (x
), y
);
1611 result
= make_integer (integer_lo (s
), result
);
1615 if (obj_eq (x
, ZERO
))
1618 s
= add (s
, scale (integer_lo (x
), y
));
1621 return norm (result
, s
);
1624 integer
mul (integer x
, integer y
)
1626 /* mul(x,y) returns the product of the integers x and y */
1629 return neg (mulnonneg (neg (x
), y
));
1631 return mulnonneg (x
, y
);
1634 integer
divnonneg (integer x
, integer y
)
1636 /* divnonneg(x,y) returns the quotient and remainder of
1637 the integers x and y where x and y are nonnegative */
1639 integer result
= ZERO
;
1640 uint16 lx
= integer_length (x
);
1641 uint16 ly
= integer_length (y
);
1647 y
= shift_left (y
, lx
);
1651 result
= shl (result
);
1652 if (cmp (x
, y
) >= 0)
1655 result
= add (POS1
, result
);
1658 } while (lx
-- != 0);
1668 x
= ((long long)integer_lo (integer_hi (integer_hi (integer_hi (n
))))<<48)+
1669 ((long long)integer_lo (integer_hi (integer_hi (n
)))<<32)+
1670 ((long long)integer_lo (integer_hi (n
))<<16)+
1671 (long long)integer_lo (n
);
1672 printf ("%lld ", x
);
1675 integer
enc (long long n
)
1677 integer result
= NIL
;
1679 while (n
!= 0 && n
!= -1)
1681 result
= make_integer ((digit
)n
, result
);
1686 return norm (result
, NEG1
);
1688 return norm (result
, ZERO
);
1701 zero
= make_integer (0x0000, 0);
1702 min1
= make_integer (0xffff, 0);
1703 integer_hi_set (zero
, ZERO
);
1704 integer_hi_set (min1
, NEG1
);
1706 min2
= make_integer (0xfffe, NEG1
);
1707 one
= make_integer (0x0001, ZERO
);
1708 two
= make_integer (0x0002, ZERO
);
1709 three
= make_integer (0x0003, ZERO
);
1710 four
= make_integer (0x0004, ZERO
);
1713 if (negp (ZERO
)) printf ("zero is negp\n");
1714 if (negp (NEG1
)) printf ("min1 is negp\n");
1716 printf ("cmp(5,5) = %d\n",cmp (make_integer (5, ZERO
), make_integer (5, ZERO
)));
1717 printf ("cmp(2,5) = %d\n",cmp (make_integer (2, ZERO
), make_integer (5, ZERO
)));
1718 printf ("cmp(5,2) = %d\n",cmp (make_integer (5, ZERO
), make_integer (2, ZERO
)));
1720 printf ("cmp(-5,-5) = %d\n",cmp (make_integer (-5, NEG1
), make_integer (-5, NEG1
)));
1721 printf ("cmp(-2,-5) = %d\n",cmp (make_integer (-2, NEG1
), make_integer (-5, NEG1
)));
1722 printf ("cmp(-5,-2) = %d\n",cmp (make_integer (-5, NEG1
), make_integer (-2, NEG1
)));
1724 printf ("cmp(-5,65533) = %d\n",cmp (make_integer (-5, NEG1
), make_integer (65533, ZERO
)));
1725 printf ("cmp(-5,2) = %d\n",cmp (make_integer (-5, NEG1
), make_integer (2, ZERO
)));
1726 printf ("cmp(5,-65533) = %d\n",cmp (make_integer (5, ZERO
), make_integer (-65533, NEG1
)));
1727 printf ("cmp(5,-2) = %d\n",cmp (make_integer (5, ZERO
), make_integer (-2, NEG1
)));
1729 printf ("integer_length(0) = %d\n", integer_length (ZERO
));
1730 printf ("integer_length(1) = %d\n", integer_length (make_integer (1, ZERO
)));
1731 printf ("integer_length(2) = %d\n", integer_length (make_integer (2, ZERO
)));
1732 printf ("integer_length(3) = %d\n", integer_length (make_integer (3, ZERO
)));
1733 printf ("integer_length(4) = %d\n", integer_length (make_integer (4, ZERO
)));
1734 printf ("integer_length(65536 + 4) = %d\n", integer_length (make_integer (4, make_integer (1, ZERO
))));
1737 printf ("1 = %d\n", one
);
1738 printf ("2 = %d\n", two
);
1739 printf ("4 = %d\n", four
);
1740 printf ("norm(2) = %d\n", norm (make_integer (0, make_integer (2, NIL
)), ZERO
));
1741 printf ("norm(2) = %d\n", norm (make_integer (0, make_integer (2, NIL
)), ZERO
));
1742 printf ("norm(3) = %d\n", norm (make_integer (0, make_integer (3, NIL
)), ZERO
));
1743 printf ("norm(3) = %d\n", norm (make_integer (0, make_integer (3, NIL
)), ZERO
));
1745 printf ("shl(1) = %d\n", shl (one
));
1746 printf ("shl(2) = %d\n", shl (two
));
1751 for (i
=1; i
<=34; i
++)
1756 for (i
=1; i
<=35; i
++)
1764 integer n
= shift_left (four
, 5);
1767 for (i
=0; i
<=14; i
++)
1769 p (shift_left (n
, i
*4));
1773 p (add (enc (32768), enc (32768)));
1774 p (add (enc (32768+(65536*65535LL)), enc (32768)));
1776 p (sub (enc (32768), enc (-32768)));
1777 p (sub (enc (32768+(65536*65535LL)), enc (-32768)));
1779 p (sub (enc (32768), enc (32769)));
1781 p (mul (enc (123456789), enc (1000000000)));
1782 p (mul (enc (123456789), enc (-1000000000)));
1783 p (mul (enc (-123456789), enc (1000000000)));
1784 p (mul (enc (-123456789), enc (-1000000000)));
1788 p (divnonneg (enc (10000000-1), enc (500000)));
1797 // TODO FOOBIGNUMS end pasted section
1799 void prim_numberp (void)
1801 if (arg1
>= MIN_FIXNUM_ENCODING
1802 && arg1
<= (MIN_FIXNUM_ENCODING
+ (MAX_FIXNUM
- MIN_FIXNUM
)))
1807 arg1
= encode_bool (RAM_BIGNUM(arg1
));
1808 else if (IN_ROM(arg1
))
1809 arg1
= encode_bool (ROM_BIGNUM(arg1
));
1815 void decode_2_int_args (void)
1817 a1
= decode_int (arg1
);
1818 a2
= decode_int (arg2
);
1821 void prim_add (void)
1823 decode_2_int_args ();
1824 #ifdef INFINITE_PRECISION_BIGNUMS
1825 arg1
= add (arg1
, arg2
);
1827 arg1
= encode_int (a1
+ a2
);
1832 void prim_sub (void)
1834 decode_2_int_args ();
1835 #ifdef INFINITE_PRECISION_BIGNUMS
1836 arg1
= sub (arg1
, arg2
);
1838 arg1
= encode_int (a1
- a2
);
1843 void prim_mul (void)
1845 decode_2_int_args ();
1846 #ifdef INFINITE_PRECISION_BIGNUMS
1847 arg1
= mul (arg1
, arg2
);
1849 arg1
= encode_int (a1
* a2
);
1854 void prim_div (void)
1856 decode_2_int_args ();
1858 ERROR("quotient", "divide by 0");
1859 #ifdef INFINITE_PRECISION_BIGNUMS
1862 arg1
= encode_int (a1
/ a2
);
1867 void prim_rem (void)
1869 decode_2_int_args ();
1871 ERROR("remainder", "divide by 0");
1872 #ifdef INFINITE_PRECISION_BIGNUMS
1875 arg1
= encode_int (a1
% a2
);
1880 void prim_neg (void)
1882 a1
= decode_int (arg1
);
1883 #ifdef INFINITE_PRECISION_BIGNUMS
1886 arg1
= encode_int (- a1
);
1892 decode_2_int_args ();
1893 #ifdef INFINITE_PRECISION_BIGNUMS
1894 arg1
= encode_bool(cmp (arg1
, arg2
) == 0);
1896 arg1
= encode_bool(a1
== a2
);
1903 decode_2_int_args ();
1904 #ifdef INFINITE_PRECISION_BIGNUMS
1905 arg1
= encode_bool(cmp (arg1
, arg2
) < 0);
1907 arg1
= encode_bool(a1
< a2
);
1914 decode_2_int_args ();
1915 #ifdef INFINITE_PRECISION_BIGNUMS
1916 arg1
= encode_bool(cmp (arg1
, arg2
) > 0);
1918 arg1
= encode_bool(a1
> a2
);
1923 void prim_ior (void) // TODO FOOBIGNUMS these have not been implemented with bignums, do it
1925 a1
= decode_int (arg1
);
1926 a2
= decode_int (arg2
);
1927 arg1
= encode_int (a1
| a2
);
1931 void prim_xor (void)
1933 a1
= decode_int (arg1
);
1934 a2
= decode_int (arg2
);
1935 arg1
= encode_int (a1
^ a2
);
1940 /*---------------------------------------------------------------------------*/
1942 /* List operations */
1944 void prim_pairp (void)
1947 arg1
= encode_bool (RAM_PAIR(arg1
));
1948 else if (IN_ROM(arg1
))
1949 arg1
= encode_bool (ROM_PAIR(arg1
));
1954 obj
cons (obj car
, obj cdr
)
1956 return alloc_ram_cell_init (COMPOSITE_FIELD0
| (car
>> 8),
1958 PAIR_FIELD2
| (cdr
>> 8),
1962 void prim_cons (void)
1964 arg1
= cons (arg1
, arg2
);
1968 void prim_car (void)
1972 if (!RAM_PAIR(arg1
))
1973 TYPE_ERROR("car", "pair");
1974 arg1
= ram_get_car (arg1
);
1976 else if (IN_ROM(arg1
))
1978 if (!ROM_PAIR(arg1
))
1979 TYPE_ERROR("car", "pair");
1980 arg1
= rom_get_car (arg1
);
1984 TYPE_ERROR("car", "pair");
1988 void prim_cdr (void)
1992 if (!RAM_PAIR(arg1
))
1993 TYPE_ERROR("cdr", "pair");
1994 arg1
= ram_get_cdr (arg1
);
1996 else if (IN_ROM(arg1
))
1998 if (!ROM_PAIR(arg1
))
1999 TYPE_ERROR("cdr", "pair");
2000 arg1
= rom_get_cdr (arg1
);
2004 TYPE_ERROR("cdr", "pair");
2008 void prim_set_car (void)
2012 if (!RAM_PAIR(arg1
))
2013 TYPE_ERROR("set-car!", "pair");
2015 ram_set_car (arg1
, arg2
);
2021 TYPE_ERROR("set-car!", "pair");
2025 void prim_set_cdr (void)
2029 if (!RAM_PAIR(arg1
))
2030 TYPE_ERROR("set-cdr!", "pair");
2032 ram_set_cdr (arg1
, arg2
);
2038 TYPE_ERROR("set-cdr!", "pair");
2042 void prim_nullp (void)
2044 arg1
= encode_bool (arg1
== OBJ_NULL
);
2047 /*---------------------------------------------------------------------------*/
2049 /* Vector operations */
2051 void prim_u8vectorp (void)
2054 arg1
= encode_bool (RAM_VECTOR(arg1
));
2055 else if (IN_ROM(arg1
))
2056 arg1
= encode_bool (ROM_VECTOR(arg1
));
2061 void prim_make_u8vector (void)
2063 decode_2_int_args (); // arg1 is length, arg2 is contents
2066 ERROR("make-u8vector", "byte vectors can only contain bytes");
2068 arg3
= alloc_vec_cell (a1
);
2069 arg1
= alloc_ram_cell_init (COMPOSITE_FIELD0
| (a1
>> 8),
2071 VECTOR_FIELD2
| (arg3
>> 8),
2074 a1
= (a1
+ 3) / 4; // actual length, in words
2077 ram_set_field0 (arg3
, a2
);
2078 ram_set_field1 (arg3
, a2
);
2079 ram_set_field2 (arg3
, a2
);
2080 ram_set_field3 (arg3
, a2
);
2085 void prim_u8vector_ref (void)
2087 a2
= decode_int (arg2
);
2091 if (!RAM_VECTOR(arg1
))
2092 TYPE_ERROR("u8vector-ref", "vector");
2093 if ((ram_get_car (arg1
) <= a2
) || (a2
< 0))
2094 ERROR("u8vector-ref", "vector index invalid");
2095 arg1
= ram_get_cdr (arg1
);
2097 else if (IN_ROM(arg1
))
2099 if (!ROM_VECTOR(arg1
))
2100 TYPE_ERROR("u8vector-ref", "vector");
2101 if ((rom_get_car (arg1
) <= a2
) || (a2
< 0))
2102 ERROR("u8vector-ref", "vector index invalid");
2103 arg1
= rom_get_cdr (arg1
);
2106 TYPE_ERROR("u8vector-ref", "vector");
2113 arg1
= encode_int (ram_get_fieldn (arg1
, a2
));
2115 else // rom vector, stored as a list
2118 arg1
= rom_get_cdr (arg1
);
2120 // the contents are already encoded as fixnums
2121 arg1
= rom_get_car (arg1
);
2129 void prim_u8vector_set (void)
2130 { // TODO a lot in common with ref, abstract that
2131 a2
= decode_int (arg2
);
2132 a3
= decode_int (arg3
);
2135 ERROR("u8vector-set!", "byte vectors can only contain bytes");
2139 if (!RAM_VECTOR(arg1
))
2140 TYPE_ERROR("u8vector-set!", "vector");
2141 if ((ram_get_car (arg1
) <= a2
) || (a2
< 0))
2142 ERROR("u8vector-set!", "vector index invalid");
2143 arg1
= ram_get_cdr (arg1
);
2146 TYPE_ERROR("u8vector-set!", "vector");
2151 ram_set_fieldn (arg1
, a2
, a3
);
2158 void prim_u8vector_length (void)
2162 if (!RAM_VECTOR(arg1
))
2163 TYPE_ERROR("u8vector-length", "vector");
2164 arg1
= encode_int (ram_get_car (arg1
));
2166 else if (IN_ROM(arg1
))
2168 if (!ROM_VECTOR(arg1
))
2169 TYPE_ERROR("u8vector-length", "vector");
2170 arg1
= encode_int (rom_get_car (arg1
));
2173 TYPE_ERROR("u8vector-length", "vector");
2176 void prim_u8vector_copy (void)
2178 // arg1 is source, arg2 is source-start, arg3 is target, arg4 is target-start
2179 // arg5 is number of bytes to copy
2181 a1
= decode_int (arg2
);
2182 a2
= decode_int (arg4
);
2183 a3
= decode_int (arg5
);
2185 // case 1 : ram to ram
2186 if (IN_RAM(arg1
) && IN_RAM(arg3
))
2188 if (!RAM_VECTOR(arg1
) || !RAM_VECTOR(arg3
))
2189 TYPE_ERROR("u8vector-copy!", "vector");
2190 if ((ram_get_car (arg1
) < (a1
+ a3
)) || (a1
< 0) ||
2191 (ram_get_car (arg3
) < (a2
+ a3
)) || (a2
< 0))
2192 ERROR("u8vector-copy!", "vector index invalid");
2194 // position to the start
2195 arg1
= ram_get_cdr (arg1
);
2198 arg3
= ram_get_cdr (arg3
);
2205 ram_set_fieldn (arg3
, a2
, ram_get_fieldn (arg1
, a1
));
2209 a1
%= 4; // TODO merge with the previous similar block ?
2215 // case 2 : rom to ram
2216 else if (IN_ROM(arg1
) && IN_RAM(arg3
))
2218 if (!ROM_VECTOR(arg1
) || !RAM_VECTOR(arg3
))
2219 TYPE_ERROR("u8vector-copy!", "vector");
2220 if ((rom_get_car (arg1
) < (a1
+ a3
)) || (a1
< 0) ||
2221 (ram_get_car (arg3
) < (a2
+ a3
)) || (a2
< 0))
2222 ERROR("u8vector-copy!", "vector index invalid");
2224 arg1
= rom_get_cdr (arg1
);
2226 arg1
= rom_get_cdr (arg1
);
2228 arg3
= ram_get_cdr (arg3
);
2234 ram_set_fieldn (arg3
, a2
, decode_int (rom_get_car (arg1
)));
2236 arg1
= rom_get_cdr (arg1
);
2239 a2
%= 4; // TODO very similar to the other case
2243 TYPE_ERROR("u8vector-copy!", "vector");
2252 /*---------------------------------------------------------------------------*/
2254 /* Miscellaneous operations */
2256 void prim_eqp (void)
2258 arg1
= encode_bool (arg1
== arg2
);
2262 void prim_not (void)
2264 arg1
= encode_bool (arg1
== OBJ_FALSE
);
2267 void prim_symbolp (void)
2270 arg1
= encode_bool (RAM_SYMBOL(arg1
));
2271 else if (IN_ROM(arg1
))
2272 arg1
= encode_bool (ROM_SYMBOL(arg1
));
2277 void prim_stringp (void)
2280 arg1
= encode_bool (RAM_STRING(arg1
));
2281 else if (IN_ROM(arg1
))
2282 arg1
= encode_bool (ROM_STRING(arg1
));
2287 void prim_string2list (void)
2291 if (!RAM_STRING(arg1
))
2292 TYPE_ERROR("string->list", "string");
2294 arg1
= ram_get_car (arg1
);
2296 else if (IN_ROM(arg1
))
2298 if (!ROM_STRING(arg1
))
2299 TYPE_ERROR("string->list", "string");
2301 arg1
= rom_get_car (arg1
);
2304 TYPE_ERROR("string->list", "string");
2307 void prim_list2string (void)
2309 arg1
= alloc_ram_cell_init (COMPOSITE_FIELD0
| ((arg1
& 0x1f00) >> 8),
2315 void prim_booleanp (void)
2317 arg1
= encode_bool (arg1
< 2);
2321 /*---------------------------------------------------------------------------*/
2323 /* Robot specific operations */
2326 void prim_print (void)
2341 int32
read_clock (void)
2347 now
= from_now( 0 );
2355 static int32 start
= 0;
2360 now
= tb
.time
* 1000 + tb
.millitm
;
2367 static int32 start
= 0;
2370 if (gettimeofday (&tv
, NULL
) == 0)
2372 now
= tv
.tv_sec
* 1000 + tv
.tv_usec
/ 1000;
2386 void prim_clock (void)
2388 arg1
= encode_int (read_clock ());
2392 void prim_motor (void)
2394 decode_2_int_args ();
2396 if (a1
< 1 || a1
> 2 || a2
< -100 || a2
> 100)
2397 ERROR("motor", "argument out of range");
2401 MOTOR_set( a1
, a2
);
2407 printf ("motor %d -> power=%d\n", a1
, a2
);
2417 void prim_led (void)
2419 decode_2_int_args ();
2420 a3
= decode_int (arg3
);
2422 if (a1
< 1 || a1
> 3 || a2
< 0 || a3
< 0)
2423 ERROR("led", "argument out of range");
2427 LED_set( a1
, a2
, a3
);
2433 printf ("led %d -> duty=%d period=%d\n", a1
, a2
, a3
);
2444 void prim_led2_color (void)
2446 a1
= decode_int (arg1
);
2448 if (a1
< 0 || a1
> 1)
2449 ERROR("led2-colors", "argument out of range");
2453 LED2_color_set( a1
);
2459 printf ("led2-color -> %s\n", (a1
==0)?"green":"red");
2468 void prim_getchar_wait (void)
2470 decode_2_int_args();
2471 a1
= read_clock () + a1
;
2473 if (a1
< 0 || a2
< 1 || a2
> 3)
2474 ERROR("getchar-wait", "argument out of range");
2481 serial_port_set ports
;
2482 ports
= serial_rx_wait_with_timeout( a2
, a1
);
2484 arg1
= encode_int (serial_rx_read( ports
));
2499 arg1
= encode_int (_getch ());
2502 } while (read_clock () < a1
);
2507 arg1
= encode_int (getchar ());
2515 void prim_putchar (void)
2517 decode_2_int_args ();
2519 if (a1
< 0 || a1
> 255 || a2
< 1 || a2
> 3)
2520 ERROR("putchar", "argument out of range");
2524 serial_tx_write( a2
, a1
);
2540 void prim_beep (void)
2542 decode_2_int_args ();
2544 if (a1
< 1 || a1
> 255 || a2
< 0)
2545 ERROR("beep", "argument out of range");
2549 beep( a1
, from_now( a2
) );
2555 printf ("beep -> freq-div=%d duration=%d\n", a1
, a2
);
2565 void prim_adc (void)
2569 a1
= decode_int (arg1
);
2571 if (a1
< 1 || a1
> 3)
2572 ERROR("adc", "argument out of range");
2582 x
= read_clock () & 255;
2584 if (x
> 127) x
= 256 - x
;
2590 arg1
= encode_int (x
);
2594 void prim_dac (void) // TODO not used
2596 a1
= decode_int (arg1
);
2598 if (a1
< 0 || a1
> 255)
2599 ERROR("dac", "argument out of range");
2609 printf ("dac -> %d\n", a1
);
2618 void prim_sernum (void)
2634 arg1
= encode_int (x
);
2638 /*---------------------------------------------------------------------------*/
2639 // networking, currently works only on workstations
2643 void prim_network_init (void)
2644 { // TODO maybe put in the initialization of the vm
2645 handle
= pcap_open_live(INTERFACE
, MAX_PACKET_SIZE
, PROMISC
, TO_MSEC
, errbuf
);
2647 ERROR("network-init", "interface not responding");
2650 void prim_network_cleanup (void)
2651 { // TODO maybe put in halt ?
2655 void prim_receive_packet_to_u8vector (void)
2657 // arg1 is the vector in which to put the received packet
2658 if (!RAM_VECTOR(arg1
))
2659 TYPE_ERROR("u8vector-copy!", "vector");
2661 // receive the packet in the buffer
2662 struct pcap_pkthdr header
;
2663 const u_char
*packet
;
2665 packet
= pcap_next(handle
, &header
);
2670 if (ram_get_car (arg1
) < header
.len
)
2671 ERROR("receive-packet-to-u8vector", "packet longer than vector");
2673 if (header
.len
> 0) // we have received a packet, write it in the vector
2675 arg2
= rom_get_cdr (arg1
);
2676 arg1
= header
.len
; // we return the length of the received packet
2681 ram_set_fieldn (arg2
, a1
% 4, (char)packet
[a1
]);
2683 arg2
+= (a1
% 4) ? 0 : 1;
2688 else // no packet to be read
2692 void prim_send_packet_from_u8vector (void)
2694 // arg1 is the vector which contains the packet to be sent
2695 // arg2 is the length of the packet
2696 // TODO only works with ram vectors for now
2697 if (!RAM_VECTOR(arg1
))
2698 TYPE_ERROR("u8vector-copy!", "vector");
2699 a2
= decode_int (arg2
);
2702 // TODO test if the length of the packet is longer than the length of the vector
2703 if (ram_get_car (arg1
) < a2
)
2704 ERROR("send-packet-from-u8vector", "packet cannot be longer than vector");
2706 arg1
= ram_get_cdr (arg1
);
2708 // copy the packet to the output buffer
2710 buf
[a1
] = ram_get_fieldn (arg1
, a1
% 4);
2711 // TODO maybe I could just give pcap the pointer to the memory BREGG
2713 if (pcap_sendpacket(handle
, buf
, a2
) < 0) // TODO an error has occurred, can we reuse the interface ?
2723 /*---------------------------------------------------------------------------*/
2727 int hidden_fgetc (FILE *f
)
2737 #define fgetc(f) hidden_fgetc(f)
2739 void write_hex_nibble (int n
)
2741 putchar ("0123456789ABCDEF"[n
]);
2744 void write_hex (uint8 n
)
2746 write_hex_nibble (n
>> 4);
2747 write_hex_nibble (n
& 0x0f);
2752 if (c
>= '0' && c
<= '9')
2755 if (c
>= 'A' && c
<= 'F')
2756 return (c
- 'A' + 10);
2758 if (c
>= 'a' && c
<= 'f')
2759 return (c
- 'a' + 10);
2764 int read_hex_byte (FILE *f
)
2766 int h1
= hex (fgetc (f
));
2767 int h2
= hex (fgetc (f
));
2769 if (h1
>= 0 && h2
>= 0)
2770 return (h1
<<4) + h2
;
2775 int read_hex_file (char *filename
)
2778 FILE *f
= fopen (filename
, "r");
2788 for (i
=0; i
<ROM_BYTES
; i
++)
2793 while ((c
= fgetc (f
)) != EOF
)
2795 if ((c
== '\r') || (c
== '\n'))
2799 (len
= read_hex_byte (f
)) < 0 ||
2800 (a1
= read_hex_byte (f
)) < 0 ||
2801 (a2
= read_hex_byte (f
)) < 0 ||
2802 (t
= read_hex_byte (f
)) < 0)
2808 sum
= len
+ a1
+ a2
+ t
;
2816 unsigned long adr
= ((unsigned long)hi16
<< 16) + a
- CODE_START
;
2818 if ((b
= read_hex_byte (f
)) < 0)
2821 if (adr
>= 0 && adr
< ROM_BYTES
)
2824 a
= (a
+ 1) & 0xffff;
2841 if ((a1
= read_hex_byte (f
)) < 0 ||
2842 (a2
= read_hex_byte (f
)) < 0)
2847 hi16
= (a1
<<8) + a2
;
2852 if ((b
= read_hex_byte (f
)) < 0)
2859 printf ("*** HEX file checksum error (expected 0x%02x)\n", sum
);
2865 if ((c
!= '\r') && (c
!= '\n'))
2876 printf ("*** HEX file syntax error\n");
2886 /*---------------------------------------------------------------------------*/
2888 #define FETCH_NEXT_BYTECODE() bytecode = rom_get (pc++)
2890 #define BEGIN_DISPATCH() \
2892 IF_TRACE(show_state (pc)); \
2893 FETCH_NEXT_BYTECODE(); \
2894 bytecode_hi4 = bytecode & 0xf0; \
2895 bytecode_lo4 = bytecode & 0x0f; \
2896 switch (bytecode_hi4 >> 4) {
2898 #define END_DISPATCH() }
2900 #define CASE(opcode) case (opcode>>4):;
2902 #define DISPATCH(); goto dispatch;
2907 #define bytecode TABLAT
2908 #define bytecode_hi4 WREG
2911 #define PUSH_CONSTANT1 0x00
2912 #define PUSH_CONSTANT2 0x10
2913 #define PUSH_STACK1 0x20
2914 #define PUSH_STACK2 0x30
2915 #define PUSH_GLOBAL 0x40
2916 #define SET_GLOBAL 0x50
2919 #define LABEL_INSTR 0x80
2920 #define PUSH_CONSTANT_LONG 0x90
2932 char *prim_name
[64] =
2956 "prim #%graft-to-cont",
2957 "prim #%return-to-cont",
2961 "prim #%string->list",
2962 "prim #%list->string",
2963 "prim #%make-u8vector",
2964 "prim #%u8vector-ref",
2965 "prim #%u8vector-set!",
2970 "prim #%led2-color",
2971 "prim #%getchar-wait",
2977 "prim #%u8vector-length",
2978 "prim #%u8vector-copy!",
2983 "prim #%network-init",
2984 "prim #%network-cleanup",
2985 "prim #%receive-packet-to-u8vector",
2986 "prim #%send-packet-from-u8vector",
3002 #define PUSH_ARG1() push_arg1 ()
3005 void push_arg1 (void)
3007 env
= cons (arg1
, env
);
3013 obj o
= ram_get_car (env
);
3014 env
= ram_get_cdr (env
);
3018 void pop_procedure (void)
3024 if (!RAM_CLOSURE(arg1
))
3025 TYPE_ERROR("pop_procedure", "procedure");
3027 entry
= ram_get_entry (arg1
) + CODE_START
;
3029 else if (IN_ROM(arg1
))
3031 if (!ROM_CLOSURE(arg1
))
3032 TYPE_ERROR("pop_procedure", "procedure");
3034 entry
= rom_get_entry (arg1
) + CODE_START
;
3037 TYPE_ERROR("pop_procedure", "procedure");
3040 void handle_arity_and_rest_param (void)
3044 np
= rom_get (entry
++);
3046 if ((np
& 0x80) == 0)
3049 ERROR("handle_arity_and_rest_param", "wrong number of arguments");
3056 ERROR("handle_arity_and_rest_param", "wrong number of arguments");
3064 arg3
= cons (arg4
, arg3
);
3070 arg1
= cons (arg3
, arg1
);
3075 void build_env (void)
3081 arg1
= cons (arg3
, arg1
);
3089 void save_cont (void)
3091 // the second half is a closure
3092 arg3
= alloc_ram_cell_init (CLOSURE_FIELD0
| (pc
>> 11),
3094 ((pc
& 0x0007) << 5) | (env
>> 8),
3096 cont
= alloc_ram_cell_init (COMPOSITE_FIELD0
| (cont
>> 8),
3098 CONTINUATION_FIELD2
| (arg3
>> 8),
3103 void interpreter (void)
3105 pc
= (CODE_START
+ 4) + ((rom_addr
)rom_get (CODE_START
+2) << 2);
3107 glovars
= rom_get (CODE_START
+3); // number of global variables
3113 /***************************************************************************/
3114 CASE(PUSH_CONSTANT1
);
3116 IF_TRACE(printf(" (push-constant "); show (bytecode_lo4
); printf (")\n"));
3118 arg1
= bytecode_lo4
;
3124 /***************************************************************************/
3125 CASE(PUSH_CONSTANT2
);
3127 IF_TRACE(printf(" (push-constant "); show (bytecode_lo4
+16); printf (")\n"));
3128 arg1
= bytecode_lo4
+16;
3134 /***************************************************************************/
3137 IF_TRACE(printf(" (push-stack %d)\n", bytecode_lo4
));
3141 while (bytecode_lo4
!= 0)
3143 arg1
= ram_get_cdr (arg1
);
3147 arg1
= ram_get_car (arg1
);
3153 /***************************************************************************/
3156 IF_TRACE(printf(" (push-stack %d)\n", bytecode_lo4
+16));
3162 while (bytecode_lo4
!= 0)
3164 arg1
= ram_get_cdr (arg1
);
3168 arg1
= ram_get_car (arg1
);
3174 /***************************************************************************/
3177 IF_TRACE(printf(" (push-global %d)\n", bytecode_lo4
));
3179 arg1
= get_global (bytecode_lo4
);
3185 /***************************************************************************/
3188 IF_TRACE(printf(" (set-global %d)\n", bytecode_lo4
));
3190 set_global (bytecode_lo4
, POP());
3194 /***************************************************************************/
3197 IF_TRACE(printf(" (call %d)\n", bytecode_lo4
));
3202 handle_arity_and_rest_param ();
3213 /***************************************************************************/
3216 IF_TRACE(printf(" (jump %d)\n", bytecode_lo4
));
3221 handle_arity_and_rest_param ();
3231 /***************************************************************************/
3234 switch (bytecode_lo4
)
3236 case 0: // call-toplevel
3237 FETCH_NEXT_BYTECODE();
3240 FETCH_NEXT_BYTECODE();
3242 IF_TRACE(printf(" (call-toplevel 0x%04x)\n",
3243 ((arg2
<< 8) | bytecode
) + CODE_START
));
3245 entry
= (arg2
<< 8) + bytecode
+ CODE_START
;
3248 na
= rom_get (entry
++);
3261 case 1: // jump-toplevel
3262 FETCH_NEXT_BYTECODE();
3265 FETCH_NEXT_BYTECODE();
3267 IF_TRACE(printf(" (jump-toplevel 0x%04x)\n",
3268 ((arg2
<< 8) | bytecode
) + CODE_START
));
3270 entry
= (arg2
<< 8) + bytecode
+ CODE_START
;
3273 na
= rom_get (entry
++);
3286 FETCH_NEXT_BYTECODE();
3289 FETCH_NEXT_BYTECODE();
3291 IF_TRACE(printf(" (goto 0x%04x)\n",
3292 (arg2
<< 8) + bytecode
+ CODE_START
));
3294 pc
= (arg2
<< 8) + bytecode
+ CODE_START
;
3298 case 3: // goto-if-false
3299 FETCH_NEXT_BYTECODE();
3302 FETCH_NEXT_BYTECODE();
3304 IF_TRACE(printf(" (goto-if-false 0x%04x)\n",
3305 (arg2
<< 8) + bytecode
+ CODE_START
));
3307 if (POP() == OBJ_FALSE
)
3308 pc
= (arg2
<< 8) + bytecode
+ CODE_START
;
3313 FETCH_NEXT_BYTECODE();
3316 FETCH_NEXT_BYTECODE();
3318 IF_TRACE(printf(" (closure 0x%04x)\n", (arg2
<< 8) | bytecode
));
3320 arg3
= POP(); // env
3322 entry
= (arg2
<< 8) | bytecode
;
3324 arg1
= alloc_ram_cell_init (CLOSURE_FIELD0
| (arg2
>> 3),
3325 ((arg2
& 0x07) << 5) | (bytecode
>> 3),
3326 ((bytecode
&0x07) <<5) |((arg3
&0x1f00) >>8),
3336 case 5: // call-toplevel-short
3337 FETCH_NEXT_BYTECODE(); // TODO the short version have a lot in common with the long ones, abstract ?
3338 // TODO short instructions don't work at the moment
3339 IF_TRACE(printf(" (call-toplevel-short 0x%04x)\n",
3340 pc
+ bytecode
+ CODE_START
));
3342 entry
= pc
+ bytecode
+ CODE_START
;
3345 na
= rom_get (entry
++);
3357 case 6: // jump-toplevel-short
3358 FETCH_NEXT_BYTECODE();
3360 IF_TRACE(printf(" (jump-toplevel-short 0x%04x)\n",
3361 pc
+ bytecode
+ CODE_START
));
3363 entry
= pc
+ bytecode
+ CODE_START
;
3366 na
= rom_get (entry
++);
3377 case 7: // goto-short
3378 FETCH_NEXT_BYTECODE();
3380 IF_TRACE(printf(" (goto-short 0x%04x)\n", pc
+ bytecode
+ CODE_START
));
3382 pc
= pc
+ bytecode
+ CODE_START
;
3386 case 8: // goto-if-false-short
3387 FETCH_NEXT_BYTECODE();
3389 IF_TRACE(printf(" (goto-if-false-short 0x%04x)\n",
3390 pc
+ bytecode
+ CODE_START
));
3392 if (POP() == OBJ_FALSE
)
3393 pc
= pc
+ bytecode
+ CODE_START
;
3397 case 9: // closure-short
3398 FETCH_NEXT_BYTECODE();
3400 IF_TRACE(printf(" (closure-short 0x%04x)\n", pc
+ bytecode
));
3402 arg3
= POP(); // env
3404 entry
= pc
+ bytecode
;
3406 arg1
= alloc_ram_cell_init (CLOSURE_FIELD0
| (arg2
>> 3),
3407 ((arg2
& 0x07) << 5) | (bytecode
>> 3),
3408 ((bytecode
&0x07) <<5) |((arg3
&0x1f00) >>8),
3427 case 14: // push_global [long]
3428 FETCH_NEXT_BYTECODE();
3430 IF_TRACE(printf(" (push-global [long] %d)\n", bytecode
));
3432 arg1
= get_global (bytecode
);
3438 case 15: // set_global [long]
3439 FETCH_NEXT_BYTECODE();
3441 IF_TRACE(printf(" (set-global [long] %d)\n", bytecode
));
3443 set_global (bytecode
, POP());
3450 /***************************************************************************/
3451 CASE(PUSH_CONSTANT_LONG
);
3453 /* push-constant [long] */
3455 FETCH_NEXT_BYTECODE();
3457 IF_TRACE(printf(" (push [long] 0x%04x)\n", (bytecode_lo4
<< 8) + bytecode
));
3459 arg1
= (bytecode_lo4
<< 8) | bytecode
;
3464 /***************************************************************************/
3465 CASE(FREE1
); // FREE
3469 /***************************************************************************/
3470 CASE(FREE2
); // FREE
3474 /***************************************************************************/
3477 IF_TRACE(printf(" (%s)\n", prim_name
[bytecode_lo4
]));
3479 switch (bytecode_lo4
)
3482 arg1
= POP(); prim_numberp (); PUSH_ARG1(); break;
3484 arg2
= POP(); arg1
= POP(); prim_add (); PUSH_ARG1(); break;
3486 arg2
= POP(); arg1
= POP(); prim_sub (); PUSH_ARG1(); break;
3488 arg2
= POP(); arg1
= POP(); prim_mul (); PUSH_ARG1(); break;
3490 arg2
= POP(); arg1
= POP(); prim_div (); PUSH_ARG1(); break;
3492 arg2
= POP(); arg1
= POP(); prim_rem (); PUSH_ARG1(); break;
3494 arg1
= POP(); prim_neg (); PUSH_ARG1(); break;
3496 arg2
= POP(); arg1
= POP(); prim_eq (); PUSH_ARG1(); break;
3498 arg2
= POP(); arg1
= POP(); prim_lt (); PUSH_ARG1(); break;
3500 arg2
= POP(); arg1
= POP(); prim_ior (); PUSH_ARG1(); break;
3502 arg2
= POP(); arg1
= POP(); prim_gt (); PUSH_ARG1(); break;
3504 arg2
= POP(); arg1
= POP(); prim_xor (); PUSH_ARG1(); break;
3506 arg1
= POP(); prim_pairp (); PUSH_ARG1(); break;
3508 arg2
= POP(); arg1
= POP(); prim_cons (); PUSH_ARG1(); break;
3510 arg1
= POP(); prim_car (); PUSH_ARG1(); break;
3512 arg1
= POP(); prim_cdr (); PUSH_ARG1(); break;
3517 /***************************************************************************/
3520 IF_TRACE(printf(" (%s)\n", prim_name
[bytecode_lo4
+16]));
3522 switch (bytecode_lo4
)
3525 arg2
= POP(); arg1
= POP(); prim_set_car (); break;
3527 arg2
= POP(); arg1
= POP(); prim_set_cdr (); break;
3529 arg1
= POP(); prim_nullp (); PUSH_ARG1(); break;
3531 arg2
= POP(); arg1
= POP(); prim_eqp (); PUSH_ARG1(); break;
3533 arg1
= POP(); prim_not (); PUSH_ARG1(); break;
3535 /* prim #%get-cont */
3540 /* prim #%graft-to-cont */
3542 arg1
= POP(); /* thunk to call */
3543 cont
= POP(); /* continuation */
3550 handle_arity_and_rest_param ();
3560 /* prim #%return-to-cont */
3562 arg1
= POP(); /* value to return */
3563 cont
= POP(); /* continuation */
3565 arg2
= ram_get_cdr (cont
);
3567 pc
= ram_get_entry (arg2
);
3569 env
= ram_get_cdr (arg2
);
3570 cont
= ram_get_car (cont
);
3580 /* prim #%symbol? */
3581 arg1
= POP(); prim_symbolp (); PUSH_ARG1(); break;
3583 /* prim #%string? */
3584 arg1
= POP(); prim_stringp (); PUSH_ARG1(); break;
3586 /* prim #%string->list */
3587 arg1
= POP(); prim_string2list (); PUSH_ARG1(); break;
3589 /* prim #%list->string */
3590 arg1
= POP(); prim_list2string (); PUSH_ARG1(); break;
3592 /* prim #%make-u8vector */
3593 arg2
= POP(); arg1
= POP(); prim_make_u8vector (); PUSH_ARG1(); break;
3595 /* prim #%u8vector-ref */
3596 arg2
= POP(); arg1
= POP(); prim_u8vector_ref (); PUSH_ARG1(); break;
3598 /* prim #%u8vector-set! */
3599 arg3
= POP(); arg2
= POP(); arg1
= POP(); prim_u8vector_set (); break;
3604 /***************************************************************************/
3607 IF_TRACE(printf(" (%s)\n", prim_name
[bytecode_lo4
+32]));
3609 switch (bytecode_lo4
)
3618 prim_clock (); PUSH_ARG1(); break;
3621 arg2
= POP(); arg1
= POP(); prim_motor (); break;
3624 arg3
= POP(); arg2
= POP(); arg1
= POP(); prim_led (); ;break;
3626 /* prim #%led2-color */
3627 arg1
= POP(); prim_led2_color (); break;
3629 /* prim #%getchar-wait */
3630 arg2
= POP(); arg1
= POP(); prim_getchar_wait (); PUSH_ARG1(); break;
3632 /* prim #%putchar */
3633 arg2
= POP(); arg1
= POP(); prim_putchar (); break;
3636 arg2
= POP(); arg1
= POP(); prim_beep (); break;
3639 arg1
= POP(); prim_adc (); PUSH_ARG1(); break;
3641 /* prim #%u8vector? */
3642 arg1
= POP(); prim_u8vectorp (); PUSH_ARG1(); break;
3645 prim_sernum (); PUSH_ARG1(); break;
3647 /* prim #%u8vector-length */
3648 arg1
= POP(); prim_u8vector_length (); PUSH_ARG1(); break;
3650 /* prim #%u8vector-copy! */
3651 arg5
= POP(); arg4
= POP(); arg3
= POP(); arg2
= POP(); arg1
= POP();
3652 prim_u8vector_copy (); break;
3667 arg2
= ram_get_cdr (cont
);
3668 pc
= ram_get_entry (arg2
);
3669 env
= ram_get_cdr (arg2
);
3670 cont
= ram_get_car (cont
);
3678 /***************************************************************************/
3682 IF_TRACE(printf(" (%s)\n", prim_name
[bytecode_lo4
]));
3684 switch (bytecode_lo4
)
3687 /* prim #%boolean? */
3688 arg1
= POP(); prim_booleanp (); PUSH_ARG1(); break;
3690 /* prim #%network-init */
3691 prim_network_init (); break;
3693 /* prim #%network-cleanup */
3694 prim_network_cleanup (); break;
3696 /* prim #%receive-packet-to-u8vector */
3697 arg1
= POP(); prim_receive_packet_to_u8vector (); PUSH_ARG1(); break;
3699 /* prim #%send-packet-from-u8vector */
3700 arg2
= POP(); arg1
= POP(); prim_send_packet_from_u8vector ();
3728 /***************************************************************************/
3733 /*---------------------------------------------------------------------------*/
3739 printf ("usage: sim file.hex\n");
3743 int main (int argc
, char *argv
[])
3746 rom_addr rom_start_addr
= 0;
3748 if (argc
> 1 && argv
[1][0] == '-' && argv
[1][1] == 's')
3755 if ((h1
= hex (argv
[1][2])) < 0 ||
3756 (h2
= hex (argv
[1][3])) < 0 ||
3757 (h3
= hex (argv
[1][4])) != 0 ||
3758 (h4
= hex (argv
[1][5])) != 0 ||
3762 rom_start_addr
= (h1
<< 12) | (h2
<< 8) | (h3
<< 4) | h4
;
3769 printf ("Start address = 0x%04x\n", rom_start_addr
+ CODE_START
);
3775 if (!read_hex_file (argv
[1]))
3776 printf ("*** Could not read hex file \"%s\"\n", argv
[1]);
3781 if (rom_get (CODE_START
+0) != 0xfb ||
3782 rom_get (CODE_START
+1) != 0xd7)
3783 printf ("*** The hex file was not compiled with PICOBIT\n");
3787 for (i
=0; i
<8192; i
++)
3788 if (rom_get (i
) != 0xff)
3789 printf ("rom_mem[0x%04x] = 0x%02x\n", i
, rom_get (i
));
3795 printf ("**************** memory needed = %d\n", max_live
+1);
3805 /*---------------------------------------------------------------------------*/