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
) == 0);
188 decode_2_int_args ();
189 arg1
= encode_bool(a1
== a2
);
195 #ifdef INFINITE_PRECISION_BIGNUMS
196 arg1
= encode_bool(cmp (arg1
, arg2
) < 0);
198 decode_2_int_args ();
199 arg1
= encode_bool(a1
< a2
);
205 #ifdef INFINITE_PRECISION_BIGNUMS
206 arg1
= encode_bool(cmp (arg1
, arg2
) > 0);
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
) <= 0);
218 decode_2_int_args ();
219 arg1
= encode_bool(a1
<= a2
);
226 #ifdef INFINITE_PRECISION_BIGNUMS
227 arg1
= encode_bool(cmp (arg1
, arg2
) >= 0);
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 (); // TODO is the function call overhead worth it ?
240 arg1
= encode_int (a1
| a2
);
246 #ifdef INFINITE_PRECISION_BIGNUMS
247 arg1
= bitwise_xor(arg1
, arg2
);
249 decode_2_int_args (); // TODO is the function call overhead worth it ?
250 arg1
= encode_int (a1
^ a2
);
255 // TODO primitives de shift ?
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
) || (a2
< 0))
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
) || (a2
< 0))
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
) || (a2
< 0))
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
)) || (a1
< 0) ||
471 (ram_get_car (arg3
) < (a2
+ a3
)) || (a2
< 0))
472 ERROR("u8vector-copy!.0", "vector index invalid");
474 // position to the start
475 arg1
= ram_get_cdr (arg1
);
478 arg3
= ram_get_cdr (arg3
);
484 ram_set_fieldn (arg3
, a2
, ram_get_fieldn (arg1
, a1
));
488 a1
%= 4; // TODO merge with the previous similar block ?
494 // case 2 : rom to ram
495 else if (IN_ROM(arg1
) && IN_RAM(arg3
)) {
496 if (!ROM_VECTOR(arg1
) || !RAM_VECTOR(arg3
))
497 TYPE_ERROR("u8vector-copy!.1", "vector");
498 if ((rom_get_car (arg1
) < (a1
+ a3
)) || (a1
< 0) ||
499 (ram_get_car (arg3
) < (a2
+ a3
)) || (a2
< 0))
500 ERROR("u8vector-copy!.1", "vector index invalid");
502 arg1
= rom_get_cdr (arg1
);
504 arg1
= rom_get_cdr (arg1
);
506 arg3
= ram_get_cdr (arg3
);
511 ram_set_fieldn (arg3
, a2
, decode_int (rom_get_car (arg1
)));
513 arg1
= rom_get_cdr (arg1
);
516 a2
%= 4; // TODO very similar to the other case
520 TYPE_ERROR("u8vector-copy!.2", "vector");
529 /*---------------------------------------------------------------------------*/
531 // miscellaneous primitives
534 arg1
= encode_bool (arg1
== arg2
);
539 arg1
= encode_bool (arg1
== OBJ_FALSE
);
542 void prim_symbolp () {
544 arg1
= encode_bool (RAM_SYMBOL(arg1
));
545 else if (IN_ROM(arg1
))
546 arg1
= encode_bool (ROM_SYMBOL(arg1
));
551 void prim_stringp () {
553 arg1
= encode_bool (RAM_STRING(arg1
));
554 else if (IN_ROM(arg1
))
555 arg1
= encode_bool (ROM_STRING(arg1
));
560 void prim_string2list () {
562 if (!RAM_STRING(arg1
))
563 TYPE_ERROR("string->list.0", "string");
565 arg1
= ram_get_car (arg1
);
567 else if (IN_ROM(arg1
)) {
568 if (!ROM_STRING(arg1
))
569 TYPE_ERROR("string->list.1", "string");
571 arg1
= rom_get_car (arg1
);
574 TYPE_ERROR("string->list.2", "string");
577 void prim_list2string () {
578 arg1
= alloc_ram_cell_init (COMPOSITE_FIELD0
| ((arg1
& 0x1f00) >> 8),
584 void prim_booleanp () {
585 arg1
= encode_bool (arg1
< 2);
588 /*---------------------------------------------------------------------------*/
590 // robot-specific primitives
601 else if (o
== OBJ_TRUE
)
603 else if (o
== OBJ_NULL
)
605 else if (o
<= (MIN_FIXNUM_ENCODING
+ (MAX_FIXNUM
- MIN_FIXNUM
)))
606 printf ("%d", DECODE_FIXNUM(o
));
615 if ((in_ram
&& RAM_BIGNUM(o
)) || (!in_ram
&& ROM_BIGNUM(o
))) // TODO fix for new bignums
616 printf ("%d", decode_int (o
));
617 else if ((in_ram
&& RAM_COMPOSITE(o
)) || (!in_ram
&& ROM_COMPOSITE(o
))) {
621 if ((in_ram
&& RAM_PAIR(o
)) || (!in_ram
&& ROM_PAIR(o
))) {
623 car
= ram_get_car (o
);
624 cdr
= ram_get_cdr (o
);
627 car
= rom_get_car (o
);
628 cdr
= rom_get_cdr (o
);
639 else if ((IN_RAM(cdr
) && RAM_PAIR(cdr
))
640 || (IN_ROM(cdr
) && ROM_PAIR(cdr
))) {
642 car
= ram_get_car (cdr
);
643 cdr
= ram_get_cdr (cdr
);
646 car
= rom_get_car (cdr
);
647 cdr
= rom_get_cdr (cdr
);
659 else if ((in_ram
&& RAM_SYMBOL(o
)) || (!in_ram
&& ROM_SYMBOL(o
)))
660 printf ("#<symbol>");
661 else if ((in_ram
&& RAM_STRING(o
)) || (!in_ram
&& ROM_STRING(o
)))
662 printf ("#<string>");
663 else if ((in_ram
&& RAM_VECTOR(o
)) || (!in_ram
&& ROM_VECTOR(o
)))
664 printf ("#<vector %d>", o
);
667 cdr
= ram_get_car (o
);
668 car
= ram_get_cdr (o
);
669 // ugly hack, takes advantage of the fact that pairs and
670 // continuations have the same layout
679 env
= ram_get_cdr (o
);
681 env
= rom_get_cdr (o
);
684 pc
= ram_get_entry (o
);
686 pc
= rom_get_entry (o
);
688 printf ("{0x%04x ", pc
);
713 int32
read_clock () {
722 static int32 start
= 0;
725 now
= tb
.time
* 1000 + tb
.millitm
;
730 static int32 start
= 0;
732 if (gettimeofday (&tv
, NULL
) == 0) {
733 now
= tv
.tv_sec
* 1000 + tv
.tv_usec
/ 1000;
745 arg1
= encode_int (read_clock ());
749 decode_2_int_args ();
751 if (a1
< 1 || a1
> 2 || a2
< -100 || a2
> 100)
752 ERROR("motor", "argument out of range");
759 printf ("motor %d -> power=%d\n", a1
, a2
);
769 decode_2_int_args ();
770 a3
= decode_int (arg3
);
772 if (a1
< 1 || a1
> 3 || a2
< 0 || a3
< 0)
773 ERROR("led", "argument out of range");
776 LED_set( a1
, a2
, a3
);
780 printf ("led %d -> duty=%d period=%d\n", a1
, a2
, a3
);
790 void prim_led2_color () {
791 a1
= decode_int (arg1
);
793 if (a1
< 0 || a1
> 1)
794 ERROR("led2-colors", "argument out of range");
797 LED2_color_set( a1
);
801 printf ("led2-color -> %s\n", (a1
==0)?"green":"red");
809 void prim_getchar_wait () {
811 a1
= read_clock () + a1
;
813 if (a1
< 0 || a2
< 1 || a2
> 3)
814 ERROR("getchar-wait", "argument out of range");
819 serial_port_set ports
;
820 ports
= serial_rx_wait_with_timeout( a2
, a1
);
822 arg1
= encode_int (serial_rx_read( ports
));
831 arg1
= encode_int (_getch ());
834 } while (read_clock () < a1
);
836 arg1
= encode_int (getchar ());
842 void prim_putchar () {
843 decode_2_int_args ();
845 if (a1
< 0 || a1
> 255 || a2
< 1 || a2
> 3)
846 ERROR("putchar", "argument out of range");
849 serial_tx_write( a2
, a1
);
863 decode_2_int_args ();
865 if (a1
< 1 || a1
> 255 || a2
< 0)
866 ERROR("beep", "argument out of range");
869 beep( a1
, from_now( a2
) );
873 printf ("beep -> freq-div=%d duration=%d\n", a1
, a2
);
885 a1
= decode_int (arg1
);
887 if (a1
< 1 || a1
> 3)
888 ERROR("adc", "argument out of range");
895 x
= read_clock () & 255;
896 if (x
> 127) x
= 256 - x
;
900 arg1
= encode_int (x
);
903 void prim_sernum () {
914 arg1
= encode_int (x
);
917 /*---------------------------------------------------------------------------*/
919 // networking primitives
921 void prim_network_init () { // TODO maybe put in the initialization of the vm
923 handle
= pcap_open_live(INTERFACE
, MAX_PACKET_SIZE
, PROMISC
, TO_MSEC
, errbuf
);
925 ERROR("network-init", "interface not responding");
929 void prim_network_cleanup () { // TODO maybe put in halt ?
935 void prim_receive_packet_to_u8vector () {
936 // arg1 is the vector in which to put the received packet
937 if (!RAM_VECTOR(arg1
))
938 TYPE_ERROR("receive-packet-to-u8vector", "vector");
941 // receive the packet in the buffer
942 struct pcap_pkthdr header
;
943 const u_char
*packet
;
945 packet
= pcap_next(handle
, &header
);
950 if (ram_get_car (arg1
) < header
.len
)
951 ERROR("receive-packet-to-u8vector", "packet longer than vector");
953 if (header
.len
> 0) { // we have received a packet, write it in the vector
954 arg2
= rom_get_cdr (arg1
);
955 arg1
= header
.len
; // we return the length of the received packet
959 ram_set_fieldn (arg2
, a1
% 4, (char)packet
[a1
]);
961 arg2
+= (a1
% 4) ? 0 : 1;
966 else // no packet to be read
971 void prim_send_packet_from_u8vector () {
972 // arg1 is the vector which contains the packet to be sent
973 // arg2 is the length of the packet
974 // TODO only works with ram vectors for now
975 if (!RAM_VECTOR(arg1
))
976 TYPE_ERROR("send-packet-from-vector!", "vector");
978 a2
= decode_int (arg2
); // TODO fix for bignums
981 // TODO test if the length of the packet is longer than the length of the vector
982 if (ram_get_car (arg1
) < a2
)
983 ERROR("send-packet-from-u8vector", "packet cannot be longer than vector");
985 arg1
= ram_get_cdr (arg1
);
988 // copy the packet to the output buffer
990 buf
[a1
] = ram_get_fieldn (arg1
, a1
% 4);
991 // TODO maybe I could just give pcap the pointer to the memory
993 if (pcap_sendpacket(handle
, buf
, a2
) < 0) // TODO an error has occurred, can we reuse the interface ?