d1edaa7669f4246b9c377b90807d144920a1c5e0
1 /* file: "dispatch.c" */
4 * Copyright 2004-2009 by Marc Feeley and Vincent St-Amour, All Rights Reserved.
7 #include "picobit-vm.h"
10 env
= cons (arg1
, env
);
15 obj o
= ram_get_car (env
);
16 env
= ram_get_cdr (env
);
20 void pop_procedure () {
24 if (!RAM_CLOSURE(arg1
))
25 TYPE_ERROR("pop_procedure.0", "procedure");
27 entry
= ram_get_entry (arg1
) + CODE_START
;
29 else if (IN_ROM(arg1
)) {
30 if (!ROM_CLOSURE(arg1
))
31 TYPE_ERROR("pop_procedure.1", "procedure");
33 entry
= rom_get_entry (arg1
) + CODE_START
;
36 TYPE_ERROR("pop_procedure.2", "procedure");
39 uint8
handle_arity_and_rest_param (uint8 na
) {
42 np
= rom_get (entry
++);
45 arg1
= ram_get_car(arg1
); // closed environment
47 if ((np
& 0x80) == 0) {
49 ERROR("handle_arity_and_rest_param.0", "wrong number of arguments");
55 ERROR("handle_arity_and_rest_param.1", "wrong number of arguments");
62 arg3
= cons (arg4
, arg3
);
68 arg1
= cons (arg3
, arg1
);
75 uint8
build_env (uint8 na
) {
79 arg1
= cons (arg3
, arg1
);
88 // the second half is a closure
89 arg3
= alloc_ram_cell_init (CLOSURE_FIELD0
| (env
>> 8),
93 cont
= alloc_ram_cell_init (COMPOSITE_FIELD0
| (cont
>> 8),
95 CONTINUATION_FIELD2
| (arg3
>> 8),
100 void interpreter () {
101 pc
= rom_get (CODE_START
+2);
102 pc
= (CODE_START
+ 4) + (pc
<< 2);
104 glovars
= rom_get (CODE_START
+3); // number of global variables
109 IF_TRACE(show_state (pc
));
110 FETCH_NEXT_BYTECODE();
111 bytecode_hi4
= bytecode
& 0xf0;
112 bytecode_lo4
= bytecode
& 0x0f;
114 switch (bytecode_hi4
>> 4) {
116 /*************************************************************************/
117 case PUSH_CONSTANT1
:
119 IF_TRACE(printf(" (push-constant "); show (bytecode_lo4
); printf (")\n"));
127 /*************************************************************************/
128 case PUSH_CONSTANT2
:
130 IF_TRACE(printf(" (push-constant "); show (bytecode_lo4
+16); printf (")\n"));
131 arg1
= bytecode_lo4
+16;
137 /*************************************************************************/
140 IF_TRACE(printf(" (push-stack %d)\n", bytecode_lo4
));
144 while (bytecode_lo4
!= 0) {
145 arg1
= ram_get_cdr (arg1
);
149 arg1
= ram_get_car (arg1
);
155 /*************************************************************************/
158 IF_TRACE(printf(" (push-stack %d)\n", bytecode_lo4
+16));
164 while (bytecode_lo4
!= 0) {
165 arg1
= ram_get_cdr (arg1
);
169 arg1
= ram_get_car (arg1
);
175 /*************************************************************************/
178 IF_TRACE(printf(" (push-global %d)\n", bytecode_lo4
));
180 arg1
= get_global (bytecode_lo4
);
186 /*************************************************************************/
189 IF_TRACE(printf(" (set-global %d)\n", bytecode_lo4
));
191 set_global (bytecode_lo4
, pop());
195 /*************************************************************************/
198 IF_TRACE(printf(" (call %d)\n", bytecode_lo4
));
201 build_env (handle_arity_and_rest_param (bytecode_lo4
));
211 /*************************************************************************/
214 IF_TRACE(printf(" (jump %d)\n", bytecode_lo4
));
217 build_env (handle_arity_and_rest_param (bytecode_lo4
));
226 /*************************************************************************/
229 switch (bytecode_lo4
) {
230 case 0: // call-toplevel
231 FETCH_NEXT_BYTECODE();
234 FETCH_NEXT_BYTECODE();
236 IF_TRACE(printf(" (call-toplevel 0x%04x)\n",
237 ((arg2
<< 8) | bytecode
) + CODE_START
));
239 entry
= (arg2
<< 8) + bytecode
+ CODE_START
;
242 build_env (rom_get (entry
++));
253 case 1: // jump-toplevel
254 FETCH_NEXT_BYTECODE();
257 FETCH_NEXT_BYTECODE();
259 IF_TRACE(printf(" (jump-toplevel 0x%04x)\n",
260 ((arg2
<< 8) | bytecode
) + CODE_START
));
262 entry
= (arg2
<< 8) + bytecode
+ CODE_START
;
265 build_env (rom_get (entry
++));
276 FETCH_NEXT_BYTECODE();
279 FETCH_NEXT_BYTECODE();
281 IF_TRACE(printf(" (goto 0x%04x)\n",
282 (arg2
<< 8) + bytecode
+ CODE_START
));
284 pc
= (arg2
<< 8) + bytecode
+ CODE_START
;
288 case 3: // goto-if-false
289 FETCH_NEXT_BYTECODE();
292 FETCH_NEXT_BYTECODE();
294 IF_TRACE(printf(" (goto-if-false 0x%04x)\n",
295 (arg2
<< 8) + bytecode
+ CODE_START
));
297 if (pop() == OBJ_FALSE
)
298 pc
= (arg2
<< 8) + bytecode
+ CODE_START
;
303 FETCH_NEXT_BYTECODE();
306 FETCH_NEXT_BYTECODE();
308 entry
= (arg2
<< 8) | bytecode
;
310 IF_TRACE(printf(" (closure 0x%04x)\n", entry
));
314 arg1
= alloc_ram_cell_init (CLOSURE_FIELD0
| (arg3
>> 8),
327 case 5: // call-toplevel-rel8
328 FETCH_NEXT_BYTECODE(); // TODO the short version have a lot in common with the long ones, abstract ?
330 IF_TRACE(printf(" (call-toplevel-rel8 0x%04x)\n", pc
+ bytecode
- 128));
332 entry
= pc
+ bytecode
- 128;
335 build_env (rom_get (entry
++));
345 case 6: // jump-toplevel-rel8
346 FETCH_NEXT_BYTECODE();
348 IF_TRACE(printf(" (jump-toplevel-rel8 0x%04x)\n", pc
+ bytecode
- 128));
350 entry
= pc
+ bytecode
- 128;
353 build_env (rom_get (entry
++));
363 FETCH_NEXT_BYTECODE();
365 IF_TRACE(printf(" (goto-rel8 0x%04x)\n", pc
+ bytecode
- 128));
367 pc
= pc
+ bytecode
- 128;
371 case 8: // goto-if-false-rel8
372 FETCH_NEXT_BYTECODE();
374 IF_TRACE(printf(" (goto-if-false-rel8 0x%04x)\n", pc
+ bytecode
- 128));
376 if (pop() == OBJ_FALSE
)
377 pc
= pc
+ bytecode
- 128;
381 // TODO why does this not work? don't worry about it now, as it is disabled in the compiler
383 case 9: // closure-rel8
384 FETCH_NEXT_BYTECODE();
386 entry
= pc
+ bytecode
- 128;
388 IF_TRACE(printf(" (closure-rel8 0x%04x)\n", entry
));
392 arg1
= alloc_ram_cell_init (CLOSURE_FIELD0
| (entry
>> 11),
394 ((entry
& 0x07) << 5) | ((arg3
>> 8) & 0x1f),
414 case 14: // push_global [long]
415 FETCH_NEXT_BYTECODE();
417 IF_TRACE(printf(" (push-global [long] %d)\n", bytecode
));
419 arg1
= get_global (bytecode
);
425 case 15: // set_global [long]
426 FETCH_NEXT_BYTECODE();
428 IF_TRACE(printf(" (set-global [long] %d)\n", bytecode
));
430 set_global (bytecode
, pop());
437 /*************************************************************************/
438 case PUSH_CONSTANT_LONG
:
440 /* push-constant [long] */
442 FETCH_NEXT_BYTECODE();
444 IF_TRACE(printf(" (push [long] 0x%04x)\n", (bytecode_lo4
<< 8) + bytecode
));
446 // necessary since SIXPIC would have kept the result of the shift at 8 bits
448 arg1
= (arg1
<< 8) | bytecode
;
453 /*************************************************************************/
455 case JUMP_TOPLEVEL_REL4
:
457 IF_TRACE(printf(" (jump-toplevel-rel4 0x%04x)\n", pc
+ (bytecode
& 0x0f)));
459 entry
= pc
+ (bytecode
& 0x0f);
462 build_env (rom_get (entry
++));
471 /*************************************************************************/
473 case GOTO_IF_FALSE_REL4
:
475 IF_TRACE(printf(" (goto-if-false-rel4 0x%04x)\n", pc
+ (bytecode
& 0x0f)));
477 if (pop() == OBJ_FALSE
)
478 pc
= pc
+ (bytecode
& 0x0f);
482 /*************************************************************************/
485 IF_TRACE(printf(" (%s)\n", prim_name
[bytecode_lo4
]));
487 switch (bytecode_lo4
) {
489 arg1
= pop(); prim_numberp (); push_arg1(); break;
491 arg2
= pop(); arg1
= pop(); prim_add (); push_arg1(); break;
493 arg2
= pop(); arg1
= pop(); prim_sub (); push_arg1(); break;
495 arg2
= pop(); arg1
= pop(); prim_mul_non_neg (); push_arg1(); break;
497 arg2
= pop(); arg1
= pop(); prim_div_non_neg (); push_arg1(); break;
499 arg2
= pop(); arg1
= pop(); prim_rem (); push_arg1(); break;
505 arg2
= pop(); arg1
= pop(); prim_eq (); push_arg1(); break;
507 arg2
= pop(); arg1
= pop(); prim_lt (); push_arg1(); break;
513 arg2
= pop(); arg1
= pop(); prim_gt (); push_arg1(); break;
519 arg1
= pop(); prim_pairp (); push_arg1(); break;
521 arg2
= pop(); arg1
= pop(); prim_cons (); push_arg1(); break;
523 arg1
= pop(); prim_car (); push_arg1(); break;
525 arg1
= pop(); prim_cdr (); push_arg1(); break;
530 /*************************************************************************/
533 IF_TRACE(printf(" (%s)\n", prim_name
[bytecode_lo4
+16]));
535 switch (bytecode_lo4
) {
537 arg2
= pop(); arg1
= pop(); prim_set_car (); break;
539 arg2
= pop(); arg1
= pop(); prim_set_cdr (); break;
541 arg1
= pop(); prim_nullp (); push_arg1(); break;
543 arg2
= pop(); arg1
= pop(); prim_eqp (); push_arg1(); break;
545 arg1
= pop(); prim_not (); push_arg1(); break;
547 /* prim #%get-cont */
552 /* prim #%graft-to-cont */
554 arg1
= pop(); /* thunk to call */
555 cont
= pop(); /* continuation */
560 build_env (handle_arity_and_rest_param (0));
569 /* prim #%return-to-cont */
571 arg1
= pop(); /* value to return */
572 cont
= pop(); /* continuation */
574 arg2
= ram_get_cdr (cont
);
576 pc
= ram_get_entry (arg2
);
578 env
= ram_get_car (arg2
);
579 cont
= ram_get_car (cont
);
590 arg1
= pop(); prim_symbolp (); push_arg1(); break;
593 arg1
= pop(); prim_stringp (); push_arg1(); break;
595 /* prim #%string->list */
596 arg1
= pop(); prim_string2list (); push_arg1(); break;
598 /* prim #%list->string */
599 arg1
= pop(); prim_list2string (); push_arg1(); break;
601 /* prim #%make-u8vector */
602 // not exactly like the standard Scheme function.
603 // only takes one argument, and does not fill the vector
604 arg1
= pop(); prim_make_u8vector (); push_arg1(); break;
606 /* prim #%u8vector-ref */
607 arg2
= pop(); arg1
= pop(); prim_u8vector_ref (); push_arg1(); break;
609 /* prim #%u8vector-set! */
610 arg3
= pop(); arg2
= pop(); arg1
= pop(); prim_u8vector_set (); break;
615 /*************************************************************************/
618 IF_TRACE(printf(" (%s)\n", prim_name
[bytecode_lo4
+32]));
620 switch (bytecode_lo4
) {
628 prim_clock (); push_arg1(); break;
631 arg2
= pop(); arg1
= pop(); prim_motor (); break;
634 arg3
= pop(); arg2
= pop(); arg1
= pop(); prim_led (); ;break;
636 /* prim #%led2-color */
637 arg1
= pop(); prim_led2_color (); break;
639 /* prim #%getchar-wait */
640 arg2
= pop(); arg1
= pop(); prim_getchar_wait (); push_arg1(); break;
643 arg2
= pop(); arg1
= pop(); prim_putchar (); break;
646 arg2
= pop(); arg1
= pop(); prim_beep (); break;
649 arg1
= pop(); prim_adc (); push_arg1(); break;
651 /* prim #%u8vector? */
652 arg1
= pop(); prim_u8vectorp (); push_arg1(); break;
655 prim_sernum (); push_arg1(); break;
657 /* prim #%u8vector-length */
658 arg1
= pop(); prim_u8vector_length (); push_arg1(); break;
675 arg2
= ram_get_cdr (cont
);
676 pc
= ram_get_entry (arg2
);
677 env
= ram_get_car (arg2
);
678 cont
= ram_get_car (cont
);
686 /*************************************************************************/
690 IF_TRACE(printf(" (%s)\n", prim_name
[bytecode_lo4
]));
692 switch (bytecode_lo4
) {
694 /* prim #%boolean? */
695 arg1
= pop(); prim_booleanp (); push_arg1(); break;
698 /* prim #%network-init */
699 prim_network_init (); break;
701 /* prim #%network-cleanup */
702 prim_network_cleanup (); break;
704 /* prim #%receive-packet-to-u8vector */
705 arg1
= pop(); prim_receive_packet_to_u8vector (); push_arg1(); break;
707 /* prim #%send-packet-from-u8vector */
708 arg2
= pop(); arg1
= pop(); prim_send_packet_from_u8vector ();
712 arg2
= pop(); arg1
= pop(); prim_ior (); push_arg1(); break;
715 arg2
= pop(); arg1
= pop(); prim_xor (); push_arg1(); break;
741 /*************************************************************************/