|
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300 |
- #include "vm/builtins.h"
-
- #include <stdio.h>
-
- static void print_val(struct l2_vm *vm, struct l2_io_writer *out, struct l2_vm_value *val) {
- switch (l2_vm_value_type(val)) {
- case L2_VAL_TYPE_NONE:
- l2_io_printf(out, "(none)");
- break;
-
- case L2_VAL_TYPE_ATOM:
- if (val->atom == vm->values[vm->ktrue].atom) {
- l2_io_printf(out, "(true)");
- } else if (val->atom == vm->values[vm->kfalse].atom) {
- l2_io_printf(out, "(false)");
- } else {
- l2_io_printf(out, "(atom %u)", val->atom);
- }
- break;
-
- case L2_VAL_TYPE_REAL:
- l2_io_printf(out, "%g", val->real);
- break;
-
- case L2_VAL_TYPE_BUFFER:
- if (val->buffer != NULL) {
- out->write(out, val->buffer->data, val->buffer->len);
- }
- break;
-
- case L2_VAL_TYPE_ARRAY:
- if (val->array == NULL) {
- out->write(out, "[]", 2);
- break;
- }
-
- out->write(out, "[", 1);
- for (size_t i = 0; i < val->array->len; ++i) {
- if (i != 0) {
- out->write(out, " ", 1);
- }
-
- print_val(vm, out, &vm->values[val->array->data[i]]);
- }
- out->write(out, "]", 1);
- break;
-
- case L2_VAL_TYPE_NAMESPACE:
- l2_io_printf(out, "(namespace)");
- break;
-
- case L2_VAL_TYPE_FUNCTION:
- case L2_VAL_TYPE_CFUNCTION:
- l2_io_printf(out, "(function)");
- break;
-
- case L2_VAL_TYPE_ERROR:
- l2_io_printf(out, "(error: %s)", val->error);
- break;
-
- case L2_VAL_TYPE_CONTINUATION:
- l2_io_printf(out, "(continuation)");
- break;
- }
- }
-
- l2_word l2_builtin_add(struct l2_vm *vm, l2_word argc, l2_word *argv) {
- if (argc < 1) {
- return 0;
- }
-
- struct l2_vm_value *val = &vm->values[argv[0]];
- if (l2_vm_value_type(val) != L2_VAL_TYPE_REAL) {
- return l2_vm_type_error(vm, val);
- }
-
- double sum = val->real;
- for (l2_word i = 1; i < argc; ++i) {
- val = &vm->values[argv[i]];
- if (l2_vm_value_type(val) != L2_VAL_TYPE_REAL) {
- return l2_vm_type_error(vm, val);
- }
-
- sum += val->real;
- }
-
- l2_word id = l2_vm_alloc(vm, L2_VAL_TYPE_REAL, 0);
- vm->values[id].real = sum;
- return id;
- }
-
- l2_word l2_builtin_sub(struct l2_vm *vm, l2_word argc, l2_word *argv) {
- if (argc < 1) {
- return 0;
- }
-
- struct l2_vm_value *val = &vm->values[argv[0]];
- if (l2_vm_value_type(val) != L2_VAL_TYPE_REAL) {
- return l2_vm_type_error(vm, val);
- }
-
- double sum = val->real;
- for (l2_word i = 1; i < argc; ++i) {
- val = &vm->values[argv[i]];
- if (l2_vm_value_type(val) != L2_VAL_TYPE_REAL) {
- return l2_vm_type_error(vm, val);
- }
-
- sum -= val->real;
- }
-
- l2_word id = l2_vm_alloc(vm, L2_VAL_TYPE_REAL, 0);
- vm->values[id].real = sum;
- return id;
- }
-
- l2_word l2_builtin_mul(struct l2_vm *vm, l2_word argc, l2_word *argv) {
- if (argc < 1) {
- return 0;
- }
-
- struct l2_vm_value *val = &vm->values[argv[0]];
- if (l2_vm_value_type(val) != L2_VAL_TYPE_REAL) {
- return l2_vm_type_error(vm, val);
- }
-
- double sum = val->real;
- for (l2_word i = 1; i < argc; ++i) {
- val = &vm->values[argv[i]];
- if (l2_vm_value_type(val) != L2_VAL_TYPE_REAL) {
- return l2_vm_type_error(vm, val);
- }
-
- sum *= val->real;
- }
-
- l2_word id = l2_vm_alloc(vm, L2_VAL_TYPE_REAL, 0);
- vm->values[id].real = sum;
- return id;
- }
-
- l2_word l2_builtin_div(struct l2_vm *vm, l2_word argc, l2_word *argv) {
- if (argc < 1) {
- return 0;
- }
-
- struct l2_vm_value *val = &vm->values[argv[0]];
- if (l2_vm_value_type(val) != L2_VAL_TYPE_REAL) {
- return l2_vm_type_error(vm, val);
- }
-
- double sum = val->real;
- for (l2_word i = 1; i < argc; ++i) {
- val = &vm->values[argv[i]];
- if (l2_vm_value_type(val) != L2_VAL_TYPE_REAL) {
- return l2_vm_type_error(vm, val);
- }
-
- sum /= val->real;
- }
-
- l2_word id = l2_vm_alloc(vm, L2_VAL_TYPE_REAL, 0);
- vm->values[id].real = sum;
- return id;
- }
-
- l2_word l2_builtin_eq(struct l2_vm *vm, l2_word argc, l2_word *argv) {
- if (argc < 2) {
- return vm->ktrue;
- }
-
- for (l2_word i = 1; i < argc; ++i) {
- if (argv[i - 1] == argv[i]) continue;
- struct l2_vm_value *a = &vm->values[argv[i - 1]];
- struct l2_vm_value *b = &vm->values[argv[i]];
- if (a->flags != b->flags) {
- return vm->kfalse;
- }
-
- enum l2_value_type typ = l2_vm_value_type(a);
- if (typ == L2_VAL_TYPE_ATOM) {
- if (a->atom != b->atom) {
- return vm->kfalse;
- }
- } else if (typ == L2_VAL_TYPE_REAL) {
- if (a->real != b->real) {
- return vm->kfalse;
- }
- } else if (typ == L2_VAL_TYPE_BUFFER) {
- if (a->buffer == NULL && b->buffer == NULL) continue;
- if (a->buffer == NULL || b->buffer == NULL) {
- return vm->kfalse;
- }
-
- if (a->buffer->len != b->buffer->len) {
- return vm->kfalse;
- }
-
- if (memcmp(a->buffer->data, b->buffer->data, a->buffer->len) != 0) {
- return vm->kfalse;
- }
- } else {
- return vm->kfalse;
- }
- }
-
- return vm->ktrue;
- }
-
- l2_word l2_builtin_neq(struct l2_vm *vm, l2_word argc, l2_word *argv) {
- l2_word ret_id = l2_builtin_eq(vm, argc, argv);
- if (ret_id == vm->ktrue) {
- return vm->kfalse;
- } else if (ret_id == vm->kfalse) {
- return vm->ktrue;
- } else {
- return ret_id;
- }
- }
-
- l2_word l2_builtin_print(struct l2_vm *vm, l2_word argc, l2_word *argv) {
- for (size_t i = 0; i < argc; ++i) {
- if (i != 0) {
- vm->std_output->write(vm->std_output, " ", 1);
- }
-
- struct l2_vm_value *val = &vm->values[argv[i]];
- print_val(vm, vm->std_output, val);
- }
-
- vm->std_output->write(vm->std_output, "\n", 1);
- return 0;
- }
-
- l2_word l2_builtin_len(struct l2_vm *vm, l2_word argc, l2_word *argv) {
- if (argc != 1) {
- return l2_vm_error(vm, "Expected 1 argument");
- }
-
- l2_word ret_id = l2_vm_alloc(vm, L2_VAL_TYPE_REAL, 0);
- struct l2_vm_value *ret = &vm->values[ret_id];
- ret->real = 0;
-
- struct l2_vm_value *val = &vm->values[argv[0]];
- switch (l2_vm_value_type(val)) {
- case L2_VAL_TYPE_NONE:
- case L2_VAL_TYPE_ATOM:
- case L2_VAL_TYPE_REAL:
- case L2_VAL_TYPE_FUNCTION:
- case L2_VAL_TYPE_CFUNCTION:
- case L2_VAL_TYPE_ERROR:
- case L2_VAL_TYPE_CONTINUATION:
- break;
-
- case L2_VAL_TYPE_BUFFER:
- if (val->buffer) {
- ret->real = val->buffer->len;
- }
- break;
-
- case L2_VAL_TYPE_ARRAY:
- if (val->array) {
- ret->real = val->array->len;
- }
- break;
-
- case L2_VAL_TYPE_NAMESPACE:
- if (val->ns) {
- ret->real = val->ns->len;
- }
- }
-
- return ret_id;
- }
-
- l2_word l2_builtin_if(struct l2_vm *vm, l2_word argc, l2_word *argv) {
- if (argc != 2 && argc != 3) {
- return l2_vm_error(vm, "Expected 2 or 3 arguments");
- }
-
- struct l2_vm_value *cond = &vm->values[argv[0]];
-
- if (
- l2_vm_value_type(cond) == L2_VAL_TYPE_ATOM &&
- cond->atom == vm->values[vm->ktrue].atom) {
- l2_word ret_id = l2_vm_alloc(vm, L2_VAL_TYPE_CONTINUATION, 0);
- struct l2_vm_value *ret = &vm->values[ret_id];
- ret->cont.call = argv[1];
- ret->cont.arg = 0;
- return ret_id;
- } else if (argc == 3) {
- l2_word ret_id = l2_vm_alloc(vm, L2_VAL_TYPE_CONTINUATION, 0);
- struct l2_vm_value *ret = &vm->values[ret_id];
- ret->cont.call = argv[2];
- ret->cont.arg = 0;
- return ret_id;
- } else {
- return 0;
- }
- }
|