1 /* file: "primitives.c" */
4 * Copyright 2004-2009 by Marc Feeley and Vincent St-Amour, All Rights Reserved.
7 #include "picobit-vm.h"
9 /*---------------------------------------------------------------------------*/
36 "prim #%graft-to-cont",
37 "prim #%return-to-cont",
41 "prim #%string->list",
42 "prim #%list->string",
43 "prim #%make-u8vector",
44 "prim #%u8vector-ref",
45 "prim #%u8vector-set!",
51 "prim #%getchar-wait",
57 "prim #%u8vector-length",
58 "prim #%u8vector-copy!",
63 "prim #%network-init",
64 "prim #%network-cleanup",
65 "prim #%receive-packet-to-u8vector",
66 "prim #%send-packet-from-u8vector",
81 /*---------------------------------------------------------------------------*/
83 // numerical primitives
85 void prim_numberp () {
86 if (arg1
>= MIN_FIXNUM_ENCODING
87 && arg1
<= (MIN_FIXNUM_ENCODING
+ (MAX_FIXNUM
- MIN_FIXNUM
)))
91 arg1
= encode_bool (RAM_BIGNUM(arg1
));
92 else if (IN_ROM(arg1
))
93 arg1
= encode_bool (ROM_BIGNUM(arg1
));
100 #ifdef INFINITE_PRECISION_BIGNUMS
101 arg1
= add (arg1
, arg2
);
103 decode_2_int_args ();
104 arg1
= encode_int (a1
+ a2
);
110 #ifdef INFINITE_PRECISION_BIGNUMS
111 arg1
= sub (arg1
, arg2
);
113 decode_2_int_args ();
114 arg1
= encode_int (a1
- a2
);
120 #ifdef INFINITE_PRECISION_BIGNUMS
122 a2
= negp (arg2
); // -1 if negative
123 arg1
= mulnonneg (a1
? neg(arg1
) : arg1
,
124 a2
? neg(arg2
) : arg2
);
125 if (a1
+ a2
== 1) // only one of the 2 was negative
128 decode_2_int_args ();
129 arg1
= encode_int (a1
* a2
);
135 #ifdef INFINITE_PRECISION_BIGNUMS
136 if (obj_eq(arg2
, ZERO
))
137 ERROR("quotient", "divide by 0");
139 a2
= negp (arg2
); // -1 if negative
140 arg1
= divnonneg (a1
? neg(arg1
) : arg1
,
141 a2
? neg(arg2
) : arg2
);
142 if (a1
+ a2
== 1) // only one of the 2 was negative
145 decode_2_int_args ();
147 ERROR("quotient", "divide by 0");
148 arg1
= encode_int (a1
/ a2
);
154 #ifdef INFINITE_PRECISION_BIGNUMS
155 if (obj_eq(arg2
, ZERO
))
156 ERROR("remainder", "divide by 0");
157 if (negp(arg1
) || negp(arg2
))
158 ERROR("remainder", "only positive numbers are supported");
159 // TODO fix this to handle negatives
160 // TODO logic quite similar to mul and div (likely, once we fix), abstract ?
161 arg3
= divnonneg (arg1
, arg2
);
162 arg4
= mulnonneg (arg2
, arg3
);
163 arg1
= sub(arg1
, arg4
);
167 decode_2_int_args ();
169 ERROR("remainder", "divide by 0");
170 arg1
= encode_int (a1
% a2
);
176 #ifdef INFINITE_PRECISION_BIGNUMS
179 a1
= decode_int (arg1
);
180 arg1
= encode_int (- a1
);
185 #ifdef INFINITE_PRECISION_BIGNUMS
186 arg1
= encode_bool(cmp (arg1
, arg2
) == 1);
188 decode_2_int_args ();
189 arg1
= encode_bool(a1
== a2
);
195 #ifdef INFINITE_PRECISION_BIGNUMS
196 arg1
= encode_bool(cmp (arg1
, arg2
) < 1);
198 decode_2_int_args ();
199 arg1
= encode_bool(a1
< a2
);
205 #ifdef INFINITE_PRECISION_BIGNUMS
206 arg1
= encode_bool(cmp (arg1
, arg2
) > 1);
208 decode_2_int_args ();
209 arg1
= encode_bool(a1
> a2
);
214 void prim_leq () { // TODO these 2 are useful, but they add to the code size, is it worth it ?
215 #ifdef INFINITE_PRECISION_BIGNUMS
216 arg1
= encode_bool(cmp (arg1
, arg2
) <= 1);
218 decode_2_int_args ();
219 arg1
= encode_bool(a1
<= a2
);
226 #ifdef INFINITE_PRECISION_BIGNUMS
227 arg1
= encode_bool(cmp (arg1
, arg2
) >= 1);
229 decode_2_int_args ();
230 arg1
= encode_bool(a1
>= a2
);
236 #ifdef INFINITE_PRECISION_BIGNUMS
237 arg1
= bitwise_ior(arg1
, arg2
);
239 decode_2_int_args ();
240 arg1
= encode_int (a1
| a2
);
246 #ifdef INFINITE_PRECISION_BIGNUMS
247 arg1
= bitwise_xor(arg1
, arg2
);
249 decode_2_int_args ();
250 arg1
= encode_int (a1
^ a2
);
255 // TODO primitives for shifting ?
257 /*---------------------------------------------------------------------------*/
263 arg1
= encode_bool (RAM_PAIR(arg1
));
264 else if (IN_ROM(arg1
))
265 arg1
= encode_bool (ROM_PAIR(arg1
));
270 obj
cons (obj car
, obj cdr
) {
271 return alloc_ram_cell_init (COMPOSITE_FIELD0
| (car
>> 8),
273 PAIR_FIELD2
| (cdr
>> 8),
278 arg1
= cons (arg1
, arg2
);
285 TYPE_ERROR("car.0", "pair");
286 arg1
= ram_get_car (arg1
);
288 else if (IN_ROM(arg1
)) {
290 TYPE_ERROR("car.1", "pair");
291 arg1
= rom_get_car (arg1
);
294 TYPE_ERROR("car.2", "pair");
300 TYPE_ERROR("cdr.0", "pair");
301 arg1
= ram_get_cdr (arg1
);
303 else if (IN_ROM(arg1
)) {
305 TYPE_ERROR("cdr.1", "pair");
306 arg1
= rom_get_cdr (arg1
);
309 TYPE_ERROR("cdr.2", "pair");
312 void prim_set_car () {
315 TYPE_ERROR("set-car!.0", "pair");
317 ram_set_car (arg1
, arg2
);
322 TYPE_ERROR("set-car!.1", "pair");
325 void prim_set_cdr () {
328 TYPE_ERROR("set-cdr!.0", "pair");
330 ram_set_cdr (arg1
, arg2
);
335 TYPE_ERROR("set-cdr!.1", "pair");
339 arg1
= encode_bool (arg1
== OBJ_NULL
);
342 /*---------------------------------------------------------------------------*/
346 void prim_u8vectorp () {
348 arg1
= encode_bool (RAM_VECTOR(arg1
));
349 else if (IN_ROM(arg1
))
350 arg1
= encode_bool (ROM_VECTOR(arg1
));
355 void prim_make_u8vector () {
356 decode_2_int_args (); // arg1 is length, arg2 is contents
357 // TODO adapt for the new bignums
359 ERROR("make-u8vector", "byte vectors can only contain bytes");
361 arg3
= alloc_vec_cell (a1
);
362 arg1
= alloc_ram_cell_init (COMPOSITE_FIELD0
| (a1
>> 8),
364 VECTOR_FIELD2
| (arg3
>> 8),
367 a1
= (a1
+ 3) >> 2; // actual length, in words
369 ram_set_field0 (arg3
, a2
);
370 ram_set_field1 (arg3
, a2
);
371 ram_set_field2 (arg3
, a2
);
372 ram_set_field3 (arg3
, a2
);
377 void prim_u8vector_ref () {
378 a2
= decode_int (arg2
);
379 // TODO adapt for the new bignums
381 if (!RAM_VECTOR(arg1
))
382 TYPE_ERROR("u8vector-ref.0", "vector");
383 if (ram_get_car (arg1
) <= a2
)
384 ERROR("u8vector-ref.0", "vector index invalid");
385 arg1
= ram_get_cdr (arg1
);
387 else if (IN_ROM(arg1
)) {
388 if (!ROM_VECTOR(arg1
))
389 TYPE_ERROR("u8vector-ref.1", "vector");
390 if (rom_get_car (arg1
) <= a2
)
391 ERROR("u8vector-ref.1", "vector index invalid");
392 arg1
= rom_get_cdr (arg1
);
395 TYPE_ERROR("u8vector-ref.2", "vector");
401 arg1
= encode_int (ram_get_fieldn (arg1
, a2
));
403 else { // rom vector, stored as a list
405 arg1
= rom_get_cdr (arg1
);
407 // the contents are already encoded as fixnums
408 arg1
= rom_get_car (arg1
);
416 void prim_u8vector_set () { // TODO a lot in common with ref, abstract that
417 a2
= decode_int (arg2
); // TODO adapt for bignums
418 a3
= decode_int (arg3
);
421 ERROR("u8vector-set!", "byte vectors can only contain bytes");
424 if (!RAM_VECTOR(arg1
))
425 TYPE_ERROR("u8vector-set!.0", "vector");
426 if (ram_get_car (arg1
) <= a2
)
427 ERROR("u8vector-set!", "vector index invalid");
428 arg1
= ram_get_cdr (arg1
);
431 TYPE_ERROR("u8vector-set!.1", "vector");
436 ram_set_fieldn (arg1
, a2
, a3
);
443 void prim_u8vector_length () {
445 if (!RAM_VECTOR(arg1
))
446 TYPE_ERROR("u8vector-length.0", "vector");
447 arg1
= encode_int (ram_get_car (arg1
));
449 else if (IN_ROM(arg1
)) {
450 if (!ROM_VECTOR(arg1
))
451 TYPE_ERROR("u8vector-length.1", "vector");
452 arg1
= encode_int (rom_get_car (arg1
));
455 TYPE_ERROR("u8vector-length.2", "vector");
458 void prim_u8vector_copy () {
459 // arg1 is source, arg2 is source-start, arg3 is target, arg4 is target-start
460 // arg5 is number of bytes to copy
462 a1
= decode_int (arg2
);
463 a2
= decode_int (arg4
);
464 a3
= decode_int (arg5
);
466 // case 1 : ram to ram
467 if (IN_RAM(arg1
) && IN_RAM(arg3
)) {
468 if (!RAM_VECTOR(arg1
) || !RAM_VECTOR(arg3
))
469 TYPE_ERROR("u8vector-copy!.0", "vector");
470 if ((ram_get_car (arg1
) < (a1
+ a3
)) || (ram_get_car (arg3
) < (a2
+ a3
)))
471 ERROR("u8vector-copy!.0", "vector index invalid");
473 // position to the start
474 arg1
= ram_get_cdr (arg1
);
477 arg3
= ram_get_cdr (arg3
);
483 ram_set_fieldn (arg3
, a2
, ram_get_fieldn (arg1
, a1
));
487 a1
%= 4; // TODO merge with the previous similar block ?
493 // case 2 : rom to ram
494 else if (IN_ROM(arg1
) && IN_RAM(arg3
)) {
495 if (!ROM_VECTOR(arg1
) || !RAM_VECTOR(arg3
))
496 TYPE_ERROR("u8vector-copy!.1", "vector");
497 if ((rom_get_car (arg1
) < (a1
+ a3
)) || (ram_get_car (arg3
) < (a2
+ a3
)))
498 ERROR("u8vector-copy!.1", "vector index invalid");
500 arg1
= rom_get_cdr (arg1
);
502 arg1
= rom_get_cdr (arg1
);
504 arg3
= ram_get_cdr (arg3
);
509 ram_set_fieldn (arg3
, a2
, decode_int (rom_get_car (arg1
)));
511 arg1
= rom_get_cdr (arg1
);
514 a2
%= 4; // TODO very similar to the other case
518 TYPE_ERROR("u8vector-copy!.2", "vector");
527 /*---------------------------------------------------------------------------*/
529 // miscellaneous primitives
532 arg1
= encode_bool (arg1
== arg2
);
537 arg1
= encode_bool (arg1
== OBJ_FALSE
);
540 void prim_symbolp () {
542 arg1
= encode_bool (RAM_SYMBOL(arg1
));
543 else if (IN_ROM(arg1
))
544 arg1
= encode_bool (ROM_SYMBOL(arg1
));
549 void prim_stringp () {
551 arg1
= encode_bool (RAM_STRING(arg1
));
552 else if (IN_ROM(arg1
))
553 arg1
= encode_bool (ROM_STRING(arg1
));
558 void prim_string2list () {
560 if (!RAM_STRING(arg1
))
561 TYPE_ERROR("string->list.0", "string");
563 arg1
= ram_get_car (arg1
);
565 else if (IN_ROM(arg1
)) {
566 if (!ROM_STRING(arg1
))
567 TYPE_ERROR("string->list.1", "string");
569 arg1
= rom_get_car (arg1
);
572 TYPE_ERROR("string->list.2", "string");
575 void prim_list2string () {
576 arg1
= alloc_ram_cell_init (COMPOSITE_FIELD0
| ((arg1
& 0x1f00) >> 8),
582 void prim_booleanp () {
583 arg1
= encode_bool (arg1
< 2);
586 /*---------------------------------------------------------------------------*/
588 // robot-specific primitives
599 else if (o
== OBJ_TRUE
)
601 else if (o
== OBJ_NULL
)
603 else if (o
<= (MIN_FIXNUM_ENCODING
+ (MAX_FIXNUM
- MIN_FIXNUM
)))
604 printf ("%d", DECODE_FIXNUM(o
));
613 if ((in_ram
&& RAM_BIGNUM(o
)) || (!in_ram
&& ROM_BIGNUM(o
))) // TODO fix for new bignums, especially for the sign, a -5 is displayed as 251
614 printf ("%d", decode_int (o
));
615 else if ((in_ram
&& RAM_COMPOSITE(o
)) || (!in_ram
&& ROM_COMPOSITE(o
))) {
619 if ((in_ram
&& RAM_PAIR(o
)) || (!in_ram
&& ROM_PAIR(o
))) {
621 car
= ram_get_car (o
);
622 cdr
= ram_get_cdr (o
);
625 car
= rom_get_car (o
);
626 cdr
= rom_get_cdr (o
);
637 else if ((IN_RAM(cdr
) && RAM_PAIR(cdr
))
638 || (IN_ROM(cdr
) && ROM_PAIR(cdr
))) {
640 car
= ram_get_car (cdr
);
641 cdr
= ram_get_cdr (cdr
);
644 car
= rom_get_car (cdr
);
645 cdr
= rom_get_cdr (cdr
);
657 else if ((in_ram
&& RAM_SYMBOL(o
)) || (!in_ram
&& ROM_SYMBOL(o
)))
658 printf ("#<symbol>");
659 else if ((in_ram
&& RAM_STRING(o
)) || (!in_ram
&& ROM_STRING(o
)))
660 printf ("#<string>");
661 else if ((in_ram
&& RAM_VECTOR(o
)) || (!in_ram
&& ROM_VECTOR(o
)))
662 printf ("#<vector %d>", o
);
665 cdr
= ram_get_car (o
);
666 car
= ram_get_cdr (o
);
667 // ugly hack, takes advantage of the fact that pairs and
668 // continuations have the same layout
677 env
= ram_get_cdr (o
);
679 env
= rom_get_cdr (o
);
682 pc
= ram_get_entry (o
);
684 pc
= rom_get_entry (o
);
686 printf ("{0x%04x ", pc
);
711 uint32
read_clock () {
720 static int32 start
= 0;
723 now
= tb
.time
* 1000 + tb
.millitm
;
728 static int32 start
= 0;
730 if (gettimeofday (&tv
, NULL
) == 0) {
731 now
= tv
.tv_sec
* 1000 + tv
.tv_usec
/ 1000;
743 arg1
= encode_int (read_clock ());
747 decode_2_int_args ();
749 if (a1
< 1 || a1
> 2 || a2
< -100 || a2
> 100) // TODO since we now use undigned values, we can't go backwards anymore
750 ERROR("motor", "argument out of range");
757 printf ("motor %d -> power=%d\n", a1
, a2
);
767 decode_2_int_args ();
768 a3
= decode_int (arg3
);
770 if (a1
< 1 || a1
> 3)
771 ERROR("led", "argument out of range");
774 LED_set( a1
, a2
, a3
);
778 printf ("led %d -> duty=%d period=%d\n", a1
, a2
, a3
);
788 void prim_led2_color () {
789 a1
= decode_int (arg1
);
792 ERROR("led2-colors", "argument out of range");
795 LED2_color_set( a1
);
799 printf ("led2-color -> %s\n", (a1
==0)?"green":"red");
807 void prim_getchar_wait () {
809 a1
= read_clock () + a1
;
811 if (a2
< 1 || a2
> 3)
812 ERROR("getchar-wait", "argument out of range");
818 serial_port_set ports
;
819 ports
= serial_rx_wait_with_timeout( a2
, a1
);
821 arg1
= encode_int (serial_rx_read( ports
));
830 arg1
= encode_int (_getch ());
833 } while (read_clock () < a1
);
835 arg1
= encode_int (getchar ());
841 void prim_putchar () {
842 decode_2_int_args ();
844 if (a1
> 255 || a2
< 1 || a2
> 3)
845 ERROR("putchar", "argument out of range");
848 serial_tx_write( a2
, a1
);
865 decode_2_int_args ();
867 if (a1
< 1 || a1
> 255)
868 ERROR("beep", "argument out of range");
871 beep( a1
, from_now( a2
) );
875 printf ("beep -> freq-div=%d duration=%d\n", a1
, a2
);
887 a1
= decode_int (arg1
);
889 if (a1
< 1 || a1
> 3)
890 ERROR("adc", "argument out of range");
897 x
= read_clock () & 255;
898 if (x
> 127) x
= 256 - x
;
902 arg1
= encode_int (x
);
905 void prim_sernum () {
916 arg1
= encode_int (x
);
919 /*---------------------------------------------------------------------------*/
921 // networking primitives
923 void prim_network_init () { // TODO maybe put in the initialization of the vm
925 handle
= pcap_open_live(INTERFACE
, MAX_PACKET_SIZE
, PROMISC
, TO_MSEC
, errbuf
);
927 ERROR("network-init", "interface not responding");
931 void prim_network_cleanup () { // TODO maybe put in halt ?
937 void prim_receive_packet_to_u8vector () {
938 // arg1 is the vector in which to put the received packet
939 if (!RAM_VECTOR(arg1
))
940 TYPE_ERROR("receive-packet-to-u8vector", "vector");
943 // receive the packet in the buffer
944 struct pcap_pkthdr header
;
945 const u_char
*packet
;
947 packet
= pcap_next(handle
, &header
);
952 if (ram_get_car (arg1
) < header
.len
)
953 ERROR("receive-packet-to-u8vector", "packet longer than vector");
955 if (header
.len
> 0) { // we have received a packet, write it in the vector
956 arg2
= rom_get_cdr (arg1
);
957 arg1
= header
.len
; // we return the length of the received packet
961 ram_set_fieldn (arg2
, a1
% 4, (char)packet
[a1
]);
963 arg2
+= (a1
% 4) ? 0 : 1;
968 else // no packet to be read
973 void prim_send_packet_from_u8vector () {
974 // arg1 is the vector which contains the packet to be sent
975 // arg2 is the length of the packet
976 // TODO only works with ram vectors for now
977 if (!RAM_VECTOR(arg1
))
978 TYPE_ERROR("send-packet-from-vector!", "vector");
980 a2
= decode_int (arg2
); // TODO fix for bignums
983 // TODO test if the length of the packet is longer than the length of the vector
984 if (ram_get_car (arg1
) < a2
)
985 ERROR("send-packet-from-u8vector", "packet cannot be longer than vector");
987 arg1
= ram_get_cdr (arg1
);
990 // copy the packet to the output buffer
992 buf
[a1
] = ram_get_fieldn (arg1
, a1
% 4);
993 // TODO maybe I could just give pcap the pointer to the memory
995 if (pcap_sendpacket(handle
, buf
, a2
) < 0) // TODO an error has occurred, can we reuse the interface ?