|
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464 |
- #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_value_get_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, val->extra.buf_length);
- }
- break;
-
- case L2_VAL_TYPE_ARRAY:
- out->write(out, "[", 1);
- l2_word *data;
- if (val->flags & L2_VAL_SBO) {
- data = val->shortarray;
- } else {
- data = val->array->data;
- }
-
- for (size_t i = 0; i < val->extra.arr_length; ++i) {
- if (i != 0) {
- out->write(out, " ", 1);
- }
-
- print_val(vm, out, &vm->values[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;
- }
- }
-
- #define X(name, identity, op) \
- l2_word name(struct l2_vm *vm, l2_word argc, l2_word *argv) { \
- if (argc == 0) { \
- l2_word id = l2_vm_alloc(vm, L2_VAL_TYPE_REAL, 0); \
- vm->values[id].real = identity; \
- return id; \
- } \
- struct l2_vm_value *first = &vm->values[argv[0]]; \
- if (l2_value_get_type(first) != L2_VAL_TYPE_REAL) { \
- return l2_vm_type_error(vm, first); \
- } \
- if (argc == 1) { \
- l2_word id = l2_vm_alloc(vm, L2_VAL_TYPE_REAL, 0); \
- vm->values[id].real = identity op first->real; \
- return id; \
- } \
- double sum = first->real; \
- for (l2_word i = 1; i < argc; ++i) { \
- struct l2_vm_value *val = &vm->values[argv[i]]; \
- if (l2_value_get_type(val) != L2_VAL_TYPE_REAL) { \
- return l2_vm_type_error(vm, val); \
- } \
- sum = sum op val->real; \
- } \
- l2_word id = l2_vm_alloc(vm, L2_VAL_TYPE_REAL, 0); \
- vm->values[id].real = sum; \
- return id; \
- }
- X(l2_builtin_add, 0, +)
- X(l2_builtin_sub, 0, -)
- X(l2_builtin_mul, 1, *)
- X(l2_builtin_div, 1, /)
- #undef X
-
- 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 (l2_value_get_type(a) != l2_value_get_type(b)) {
- return vm->kfalse;
- }
-
- enum l2_value_type typ = l2_value_get_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->extra.buf_length != b->extra.buf_length) {
- return vm->kfalse;
- }
-
- if (memcmp(a->buffer, b->buffer, a->extra.buf_length) != 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;
- }
- }
-
- #define X(name, op) \
- l2_word name(struct l2_vm *vm, l2_word argc, l2_word *argv) { \
- if (argc < 2) { \
- return vm->ktrue; \
- } \
- struct l2_vm_value *lhs = &vm->values[argv[0]]; \
- if (l2_value_get_type(lhs) != L2_VAL_TYPE_REAL) { \
- return l2_vm_type_error(vm, lhs); \
- } \
- for (l2_word i = 1; i < argc; ++i) { \
- struct l2_vm_value *rhs = &vm->values[argv[i]]; \
- if (l2_value_get_type(rhs) != L2_VAL_TYPE_REAL) { \
- return l2_vm_type_error(vm, rhs); \
- } \
- if (!(lhs->real op rhs->real)) { \
- return vm->kfalse; \
- } \
- lhs = rhs; \
- } \
- return vm->ktrue; \
- }
- X(l2_builtin_lt, <)
- X(l2_builtin_lteq, <=)
- X(l2_builtin_gt, >)
- X(l2_builtin_gteq, >=)
- #undef X
-
- l2_word l2_builtin_land(struct l2_vm *vm, l2_word argc, l2_word *argv) {
- for (l2_word i = 0; i < argc; ++i) {
- struct l2_vm_value *val = &vm->values[argv[i]];
- if (l2_value_get_type(val) == L2_VAL_TYPE_ERROR) {
- return argv[i];
- }
-
- if (!l2_vm_val_is_true(vm, val)) {
- return vm->kfalse;
- }
- }
-
- return vm->ktrue;
- }
-
- l2_word l2_builtin_lor(struct l2_vm *vm, l2_word argc, l2_word *argv) {
- for (l2_word i = 0; i < argc; ++i) {
- struct l2_vm_value *val = &vm->values[argv[i]];
- if (l2_value_get_type(val) == L2_VAL_TYPE_ERROR) {
- return argv[i];
- }
-
- if (l2_vm_val_is_true(vm, val)) {
- return vm->ktrue;
- }
- }
-
- return vm->kfalse;
- }
-
- l2_word l2_builtin_first(struct l2_vm *vm, l2_word argc, l2_word *argv) {
- for (l2_word i = 0; i < argc; ++i) {
- if (l2_value_get_type(&vm->values[argv[i]]) != L2_VAL_TYPE_NONE) {
- return argv[i];
- }
- }
-
- return vm->knone;
- }
-
- 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_value_get_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:
- ret->real = val->extra.buf_length;
- break;
-
- case L2_VAL_TYPE_ARRAY:
- ret->real = val->extra.arr_length;
- 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");
- }
-
- if (l2_vm_val_is_true(vm, &vm->values[argv[0]])) {
- l2_word ret_id = l2_vm_alloc(vm, L2_VAL_TYPE_CONTINUATION, 0);
- struct l2_vm_value *ret = &vm->values[ret_id];
- ret->extra.cont_call = argv[1];
- 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->extra.cont_call = argv[2];
- return ret_id;
- } else {
- return 0;
- }
- }
-
- struct loop_context {
- struct l2_vm_contcontext base;
- l2_word func;
- };
-
- static l2_word loop_callback(struct l2_vm *vm, l2_word retval, l2_word cont) {
- struct l2_vm_value *val = &vm->values[retval];
- if (l2_value_get_type(val) == L2_VAL_TYPE_ERROR) {
- return retval;
- } else if (
- l2_value_get_type(val) == L2_VAL_TYPE_ATOM &&
- val->atom == vm->values[vm->kstop].atom) {
- return vm->knone;
- } else {
- return cont;
- }
- }
-
- static void loop_marker(
- struct l2_vm *vm, void *data, void (*mark)(struct l2_vm *vm, l2_word id)) {
- struct loop_context *ctx = data;
- mark(vm, ctx->func);
- }
-
- l2_word l2_builtin_loop(struct l2_vm *vm, l2_word argc, l2_word *argv) {
- if (argc != 1) {
- return l2_vm_error(vm, "Expected 1 argument");
- }
-
- struct loop_context *ctx = malloc(sizeof(*ctx));
- if (ctx == NULL) {
- return l2_vm_error(vm, "Allocation failure");
- }
-
- ctx->base.callback = loop_callback;
- ctx->base.marker = loop_marker;
- ctx->base.args = vm->knone;
- ctx->func = argv[0];
-
- l2_word cont_id = l2_vm_alloc(vm, L2_VAL_TYPE_CONTINUATION, 0);
- struct l2_vm_value *cont = &vm->values[cont_id];
- cont->extra.cont_call = ctx->func;
- cont->cont = &ctx->base;
- return cont_id;
- }
-
- struct while_context {
- struct l2_vm_contcontext base;
- l2_word cond, body;
- };
-
- static l2_word while_callback(struct l2_vm *vm, l2_word retval, l2_word cont_id) {
- struct l2_vm_value *cont = &vm->values[cont_id];
- struct while_context *ctx = (struct while_context *)cont->cont;
- struct l2_vm_value *ret = &vm->values[retval];
-
- if (l2_value_get_type(ret) == L2_VAL_TYPE_ERROR) {
- return retval;
- }
-
- if (cont->extra.cont_call == ctx->cond) {
- if (l2_vm_val_is_true(vm, ret)) {
- cont->extra.cont_call = ctx->body;
- return cont_id;
- } else {
- return vm->knone;
- }
- } else {
- if (l2_value_get_type(ret) == L2_VAL_TYPE_ERROR) {
- return retval;
- } else {
- cont->extra.cont_call = ctx->cond;
- return cont_id;
- }
- }
- }
-
- static void while_marker(
- struct l2_vm *vm, void *data, void (*mark)(struct l2_vm *vm, l2_word id)) {
- struct while_context *ctx = data;
- mark(vm, ctx->cond);
- mark(vm, ctx->body);
- }
-
- l2_word l2_builtin_while(struct l2_vm *vm, l2_word argc, l2_word *argv) {
- if (argc != 2) {
- return l2_vm_error(vm, "Expected 2 arguments");
- }
-
- struct while_context *ctx = malloc(sizeof(*ctx));
- if (ctx == NULL) {
- return l2_vm_error(vm, "Allocation failure");
- }
-
- ctx->base.callback = while_callback;
- ctx->base.marker = while_marker;
- ctx->base.args = vm->knone;
- ctx->cond = argv[0];
- ctx->body = argv[1];
-
- l2_word cont_id = l2_vm_alloc(vm, L2_VAL_TYPE_CONTINUATION, 0);
- struct l2_vm_value *cont = &vm->values[cont_id];
- cont->extra.cont_call = ctx->cond;
- cont->cont = &ctx->base;
- return cont_id;
- }
-
- struct for_context {
- struct l2_vm_contcontext base;
- l2_word iter;
- l2_word func;
- };
-
- static l2_word for_callback(struct l2_vm *vm, l2_word retval, l2_word cont_id) {
- struct l2_vm_value *cont = &vm->values[cont_id];
- struct for_context *ctx = (struct for_context *)cont->cont;
- struct l2_vm_value *ret = &vm->values[retval];
-
- if (l2_value_get_type(ret) == L2_VAL_TYPE_ERROR) {
- return retval;
- }
-
- struct l2_vm_value *args = &vm->values[cont->cont->args];
- if (cont->extra.cont_call == ctx->iter) {
- if (
- l2_value_get_type(ret) == L2_VAL_TYPE_ATOM &&
- ret->atom == vm->values[vm->kstop].atom) {
- return vm->knone;
- } else {
- cont->extra.cont_call = ctx->func;
- args->extra.arr_length = 1;
- args->shortarray[0] = retval;
- return cont_id;
- }
- } else {
- cont->extra.cont_call = ctx->iter;
- args->extra.arr_length = 0;
- return cont_id;
- }
- }
-
- static void for_marker(
- struct l2_vm *vm, void *data, void (*mark)(struct l2_vm *vm, l2_word id)) {
- struct for_context *ctx = data;
- mark(vm, ctx->iter);
- mark(vm, ctx->func);
- }
-
- l2_word l2_builtin_for(struct l2_vm *vm, l2_word argc, l2_word *argv) {
- if (argc != 2) {
- return l2_vm_error(vm, "Expected 2 arguments");
- }
-
- l2_word args_id = l2_vm_alloc(vm, L2_VAL_TYPE_ARRAY, L2_VAL_SBO);
- struct l2_vm_value *args = &vm->values[args_id];
- args->extra.arr_length = 0;
-
- struct for_context *ctx = malloc(sizeof(*ctx));
- ctx->base.callback = for_callback;
- ctx->base.marker = for_marker;
- ctx->base.args = args_id;
- ctx->iter = argv[0];
- ctx->func = argv[1];
-
- l2_word cont_id = l2_vm_alloc(vm, L2_VAL_TYPE_CONTINUATION, 0);
- struct l2_vm_value *cont = &vm->values[cont_id];
- cont->extra.cont_call = ctx->iter;
- cont->cont = &ctx->base;
- return cont_id;
- }
|