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",
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
);
215 #ifdef INFINITE_PRECISION_BIGNUMS
216 arg1
= bitwise_ior(arg1
, arg2
);
218 decode_2_int_args ();
219 arg1
= encode_int (a1
| a2
);
225 #ifdef INFINITE_PRECISION_BIGNUMS
226 arg1
= bitwise_xor(arg1
, arg2
);
228 decode_2_int_args ();
229 arg1
= encode_int (a1
^ a2
);
234 // TODO primitives for shifting ?
236 /*---------------------------------------------------------------------------*/
242 arg1
= encode_bool (RAM_PAIR(arg1
));
243 else if (IN_ROM(arg1
))
244 arg1
= encode_bool (ROM_PAIR(arg1
));
249 obj
cons (obj car
, obj cdr
) {
250 return alloc_ram_cell_init (COMPOSITE_FIELD0
| (car
>> 8),
252 PAIR_FIELD2
| (cdr
>> 8),
257 arg1
= cons (arg1
, arg2
);
264 TYPE_ERROR("car.0", "pair");
265 arg1
= ram_get_car (arg1
);
267 else if (IN_ROM(arg1
)) {
269 TYPE_ERROR("car.1", "pair");
270 arg1
= rom_get_car (arg1
);
273 TYPE_ERROR("car.2", "pair");
279 TYPE_ERROR("cdr.0", "pair");
280 arg1
= ram_get_cdr (arg1
);
282 else if (IN_ROM(arg1
)) {
284 TYPE_ERROR("cdr.1", "pair");
285 arg1
= rom_get_cdr (arg1
);
288 TYPE_ERROR("cdr.2", "pair");
291 void prim_set_car () {
294 TYPE_ERROR("set-car!.0", "pair");
296 ram_set_car (arg1
, arg2
);
301 TYPE_ERROR("set-car!.1", "pair");
304 void prim_set_cdr () {
307 TYPE_ERROR("set-cdr!.0", "pair");
309 ram_set_cdr (arg1
, arg2
);
314 TYPE_ERROR("set-cdr!.1", "pair");
318 arg1
= encode_bool (arg1
== OBJ_NULL
);
321 /*---------------------------------------------------------------------------*/
325 void prim_u8vectorp () {
327 arg1
= encode_bool (RAM_VECTOR(arg1
));
328 else if (IN_ROM(arg1
))
329 arg1
= encode_bool (ROM_VECTOR(arg1
));
334 void prim_make_u8vector () {
335 a1
= decode_int (arg1
); // arg1 is length
336 // TODO adapt for the new bignums
338 arg2
= alloc_vec_cell (a1
);
339 arg1
= alloc_ram_cell_init (COMPOSITE_FIELD0
| (a1
>> 8),
341 VECTOR_FIELD2
| (arg2
>> 8),
346 void prim_u8vector_ref () {
347 a2
= decode_int (arg2
);
348 // TODO adapt for the new bignums
350 if (!RAM_VECTOR(arg1
))
351 TYPE_ERROR("u8vector-ref.0", "vector");
352 if (ram_get_car (arg1
) <= a2
)
353 ERROR("u8vector-ref.0", "vector index invalid");
354 arg1
= ram_get_cdr (arg1
);
356 else if (IN_ROM(arg1
)) {
357 if (!ROM_VECTOR(arg1
))
358 TYPE_ERROR("u8vector-ref.1", "vector");
359 if (rom_get_car (arg1
) <= a2
)
360 ERROR("u8vector-ref.1", "vector index invalid");
361 arg1
= rom_get_cdr (arg1
);
364 TYPE_ERROR("u8vector-ref.2", "vector");
370 arg1
= encode_int (ram_get_fieldn (arg1
, a2
));
372 else { // rom vector, stored as a list
374 arg1
= rom_get_cdr (arg1
);
376 // the contents are already encoded as fixnums
377 arg1
= rom_get_car (arg1
);
385 void prim_u8vector_set () { // TODO a lot in common with ref, abstract that
386 a2
= decode_int (arg2
); // TODO adapt for bignums
387 a3
= decode_int (arg3
);
390 ERROR("u8vector-set!", "byte vectors can only contain bytes");
393 if (!RAM_VECTOR(arg1
))
394 TYPE_ERROR("u8vector-set!.0", "vector");
395 if (ram_get_car (arg1
) <= a2
)
396 ERROR("u8vector-set!", "vector index invalid");
397 arg1
= ram_get_cdr (arg1
);
400 TYPE_ERROR("u8vector-set!.1", "vector");
405 ram_set_fieldn (arg1
, a2
, a3
);
412 void prim_u8vector_length () {
414 if (!RAM_VECTOR(arg1
))
415 TYPE_ERROR("u8vector-length.0", "vector");
416 arg1
= encode_int (ram_get_car (arg1
));
418 else if (IN_ROM(arg1
)) {
419 if (!ROM_VECTOR(arg1
))
420 TYPE_ERROR("u8vector-length.1", "vector");
421 arg1
= encode_int (rom_get_car (arg1
));
424 TYPE_ERROR("u8vector-length.2", "vector");
428 /*---------------------------------------------------------------------------*/
430 // miscellaneous primitives
433 arg1
= encode_bool (arg1
== arg2
);
438 arg1
= encode_bool (arg1
== OBJ_FALSE
);
441 void prim_symbolp () {
443 arg1
= encode_bool (RAM_SYMBOL(arg1
));
444 else if (IN_ROM(arg1
))
445 arg1
= encode_bool (ROM_SYMBOL(arg1
));
450 void prim_stringp () {
452 arg1
= encode_bool (RAM_STRING(arg1
));
453 else if (IN_ROM(arg1
))
454 arg1
= encode_bool (ROM_STRING(arg1
));
459 void prim_string2list () {
461 if (!RAM_STRING(arg1
))
462 TYPE_ERROR("string->list.0", "string");
464 arg1
= ram_get_car (arg1
);
466 else if (IN_ROM(arg1
)) {
467 if (!ROM_STRING(arg1
))
468 TYPE_ERROR("string->list.1", "string");
470 arg1
= rom_get_car (arg1
);
473 TYPE_ERROR("string->list.2", "string");
476 void prim_list2string () {
477 arg1
= alloc_ram_cell_init (COMPOSITE_FIELD0
| ((arg1
& 0x1f00) >> 8),
483 void prim_booleanp () {
484 arg1
= encode_bool (arg1
< 2);
487 /*---------------------------------------------------------------------------*/
489 // robot-specific primitives
500 else if (o
== OBJ_TRUE
)
502 else if (o
== OBJ_NULL
)
504 else if (o
<= (MIN_FIXNUM_ENCODING
+ (MAX_FIXNUM
- MIN_FIXNUM
)))
505 printf ("%d", DECODE_FIXNUM(o
));
514 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
515 printf ("%d", decode_int (o
));
516 else if ((in_ram
&& RAM_COMPOSITE(o
)) || (!in_ram
&& ROM_COMPOSITE(o
))) {
520 if ((in_ram
&& RAM_PAIR(o
)) || (!in_ram
&& ROM_PAIR(o
))) {
522 car
= ram_get_car (o
);
523 cdr
= ram_get_cdr (o
);
526 car
= rom_get_car (o
);
527 cdr
= rom_get_cdr (o
);
538 else if ((IN_RAM(cdr
) && RAM_PAIR(cdr
))
539 || (IN_ROM(cdr
) && ROM_PAIR(cdr
))) {
541 car
= ram_get_car (cdr
);
542 cdr
= ram_get_cdr (cdr
);
545 car
= rom_get_car (cdr
);
546 cdr
= rom_get_cdr (cdr
);
558 else if ((in_ram
&& RAM_SYMBOL(o
)) || (!in_ram
&& ROM_SYMBOL(o
)))
559 printf ("#<symbol>");
560 else if ((in_ram
&& RAM_STRING(o
)) || (!in_ram
&& ROM_STRING(o
)))
561 printf ("#<string>");
562 else if ((in_ram
&& RAM_VECTOR(o
)) || (!in_ram
&& ROM_VECTOR(o
)))
563 printf ("#<vector %d>", o
);
566 cdr
= ram_get_car (o
);
567 car
= ram_get_cdr (o
);
568 // ugly hack, takes advantage of the fact that pairs and
569 // continuations have the same layout
578 env
= ram_get_cdr (o
);
580 env
= rom_get_cdr (o
);
583 pc
= ram_get_entry (o
);
585 pc
= rom_get_entry (o
);
587 printf ("{0x%04x ", pc
);
612 uint32
read_clock () {
621 static int32 start
= 0;
624 now
= tb
.time
* 1000 + tb
.millitm
;
629 static int32 start
= 0;
631 if (gettimeofday (&tv
, NULL
) == 0) {
632 now
= tv
.tv_sec
* 1000 + tv
.tv_usec
/ 1000;
644 arg1
= encode_int (read_clock ());
648 decode_2_int_args ();
650 if (a1
< 1 || a1
> 2 || a2
< -100 || a2
> 100) // TODO since we now use undigned values, we can't go backwards anymore
651 ERROR("motor", "argument out of range");
658 printf ("motor %d -> power=%d\n", a1
, a2
);
668 decode_2_int_args ();
669 a3
= decode_int (arg3
);
671 if (a1
< 1 || a1
> 3)
672 ERROR("led", "argument out of range");
675 LED_set( a1
, a2
, a3
);
679 printf ("led %d -> duty=%d period=%d\n", a1
, a2
, a3
);
689 void prim_led2_color () {
690 a1
= decode_int (arg1
);
693 ERROR("led2-colors", "argument out of range");
696 LED2_color_set( a1
);
700 printf ("led2-color -> %s\n", (a1
==0)?"green":"red");
708 void prim_getchar_wait () {
710 a1
= read_clock () + a1
;
712 if (a2
< 1 || a2
> 3)
713 ERROR("getchar-wait", "argument out of range");
719 serial_port_set ports
;
720 ports
= serial_rx_wait_with_timeout( a2
, a1
);
722 arg1
= encode_int (serial_rx_read( ports
));
731 arg1
= encode_int (_getch ());
734 } while (read_clock () < a1
);
736 arg1
= encode_int (getchar ());
742 void prim_putchar () {
743 decode_2_int_args ();
745 if (a1
> 255 || a2
< 1 || a2
> 3)
746 ERROR("putchar", "argument out of range");
749 serial_tx_write( a2
, a1
);
766 decode_2_int_args ();
768 if (a1
< 1 || a1
> 255)
769 ERROR("beep", "argument out of range");
772 beep( a1
, from_now( a2
) );
776 printf ("beep -> freq-div=%d duration=%d\n", a1
, a2
);
788 a1
= decode_int (arg1
);
790 if (a1
< 1 || a1
> 3)
791 ERROR("adc", "argument out of range");
798 x
= read_clock () & 255;
799 if (x
> 127) x
= 256 - x
;
803 arg1
= encode_int (x
);
806 void prim_sernum () {
817 arg1
= encode_int (x
);
820 /*---------------------------------------------------------------------------*/
822 // networking primitives
824 void prim_network_init () { // TODO maybe put in the initialization of the vm
826 handle
= pcap_open_live(INTERFACE
, MAX_PACKET_SIZE
, PROMISC
, TO_MSEC
, errbuf
);
828 ERROR("network-init", "interface not responding");
832 void prim_network_cleanup () { // TODO maybe put in halt ?
838 void prim_receive_packet_to_u8vector () {
839 // arg1 is the vector in which to put the received packet
840 if (!RAM_VECTOR(arg1
))
841 TYPE_ERROR("receive-packet-to-u8vector", "vector");
844 // receive the packet in the buffer
845 struct pcap_pkthdr header
;
846 const u_char
*packet
;
848 packet
= pcap_next(handle
, &header
);
853 if (ram_get_car (arg1
) < header
.len
)
854 ERROR("receive-packet-to-u8vector", "packet longer than vector");
856 if (header
.len
> 0) { // we have received a packet, write it in the vector
857 arg2
= rom_get_cdr (arg1
);
858 arg1
= header
.len
; // we return the length of the received packet
862 ram_set_fieldn (arg2
, a1
% 4, (char)packet
[a1
]);
864 arg2
+= (a1
% 4) ? 0 : 1;
869 else // no packet to be read
874 void prim_send_packet_from_u8vector () {
875 // arg1 is the vector which contains the packet to be sent
876 // arg2 is the length of the packet
877 // TODO only works with ram vectors for now
878 if (!RAM_VECTOR(arg1
))
879 TYPE_ERROR("send-packet-from-vector!", "vector");
881 a2
= decode_int (arg2
); // TODO fix for bignums
884 // TODO test if the length of the packet is longer than the length of the vector
885 if (ram_get_car (arg1
) < a2
)
886 ERROR("send-packet-from-u8vector", "packet cannot be longer than vector");
888 arg1
= ram_get_cdr (arg1
);
891 // copy the packet to the output buffer
893 buf
[a1
] = ram_get_fieldn (arg1
, a1
% 4);
894 // TODO maybe I could just give pcap the pointer to the memory
896 if (pcap_sendpacket(handle
, buf
, a2
) < 0) // TODO an error has occurred, can we reuse the interface ?