implement bytecode interpreter and compiler
This commit is contained in:
parent
d23a9a4827
commit
c63c1eaf6e
19 changed files with 1055 additions and 547 deletions
389
src/prim.c
389
src/prim.c
|
|
@ -2,317 +2,176 @@
|
|||
#include <stdlib.h>
|
||||
#include <wolflisp.h>
|
||||
|
||||
static O nextarg(In *in, O *list) {
|
||||
if (*list == NIL)
|
||||
return NIL;
|
||||
O arg = pair_unwrap(in, *list)->head;
|
||||
*list = pair_unwrap(in, *list)->tail;
|
||||
return arg;
|
||||
}
|
||||
#define BOOL(x) ((x) ? in->t : NIL)
|
||||
|
||||
static O bool(In *in, I i) {
|
||||
if (i)
|
||||
return in->t;
|
||||
else
|
||||
return NIL;
|
||||
}
|
||||
|
||||
O prim_make(In *in, const char *name, O (*fn)(In *, O, O)) {
|
||||
O prim_make(In *in, const char *name, O (*fn)(In *, O *, int, O), int min_args,
|
||||
int max_args) {
|
||||
Pr *pr = malloc(sizeof(Pr));
|
||||
pr->name = name;
|
||||
pr->fn = fn;
|
||||
pr->min_args = min_args;
|
||||
pr->max_args = max_args;
|
||||
O sym = BOX(TAG(intern(&in->symtab, name, 0), TAG_SYM));
|
||||
O prim = BOX(TAG(pr, TAG_PRIM));
|
||||
return pair_make(in, sym, prim);
|
||||
}
|
||||
|
||||
O prim_cons(In *in, O args, O env) {
|
||||
args = interp_eval_list(in, args, env);
|
||||
O head = nextarg(in, &args);
|
||||
O tail = nextarg(in, &args);
|
||||
return pair_make(in, head, tail);
|
||||
}
|
||||
|
||||
O prim_list(In *in, O args, O env) { return interp_eval_list(in, args, env); }
|
||||
|
||||
O prim_head(In *in, O args, O env) {
|
||||
args = interp_eval_list(in, args, env);
|
||||
return pair_unwrap(in, nextarg(in, &args))->head;
|
||||
}
|
||||
|
||||
O prim_tail(In *in, O args, O env) {
|
||||
args = interp_eval_list(in, args, env);
|
||||
return pair_unwrap(in, nextarg(in, &args))->tail;
|
||||
}
|
||||
|
||||
O prim_print(In *in, O args, O env) {
|
||||
args = interp_eval_list(in, args, env);
|
||||
print(nextarg(in, &args));
|
||||
return NIL;
|
||||
}
|
||||
|
||||
O prim_println(In *in, O args, O env) {
|
||||
args = interp_eval_list(in, args, env);
|
||||
O arg = nextarg(in, &args);
|
||||
println(arg);
|
||||
return NIL;
|
||||
}
|
||||
|
||||
O prim_quote(In *in, O args, O env) {
|
||||
(void)in;
|
||||
O prim_cons(In *in, O *args, int argc, O env) {
|
||||
(void)env;
|
||||
return nextarg(in, &args);
|
||||
if (argc != 2)
|
||||
error_throw(in, "cons: expected 2 arguments, got %d", argc);
|
||||
return pair_make(in, args[0], args[1]);
|
||||
}
|
||||
|
||||
O prim_if(In *in, O args, O env) {
|
||||
O cond_expr = nextarg(in, &args);
|
||||
O then_expr = nextarg(in, &args);
|
||||
O else_expr = nextarg(in, &args);
|
||||
|
||||
if (cond_expr == NIL || then_expr == NIL) {
|
||||
fprintf(stderr, "if: expected at least 2 arguments\n");
|
||||
abort();
|
||||
}
|
||||
|
||||
if (interp_eval(in, cond_expr, env) != NIL) {
|
||||
return interp_eval(in, then_expr, env);
|
||||
} else {
|
||||
return interp_eval(in, else_expr, env);
|
||||
}
|
||||
}
|
||||
|
||||
O prim_progn(In *in, O args, O env) {
|
||||
O prim_list(In *in, O *args, int argc, O env) {
|
||||
(void)env;
|
||||
O result = NIL;
|
||||
for (O expr = nextarg(in, &args); expr != NIL; expr = nextarg(in, &args))
|
||||
result = interp_eval(in, expr, env);
|
||||
I mark = gc_rootmark(&in->gc);
|
||||
gc_addroot(&in->gc, &result);
|
||||
for (int i = argc - 1; i >= 0; i--) {
|
||||
result = pair_make(in, args[i], result);
|
||||
}
|
||||
gc_rootreset(&in->gc, mark);
|
||||
return result;
|
||||
}
|
||||
|
||||
O prim_add(In *in, O args, O env) {
|
||||
args = interp_eval_list(in, args, env);
|
||||
I result = nextarg(in, &args);
|
||||
if (result == NIL) {
|
||||
O prim_head(In *in, O *args, int argc, O env) {
|
||||
(void)env;
|
||||
if (argc != 1)
|
||||
error_throw(in, "head: expected 1 argument, got %d", argc);
|
||||
return pair_unwrap(in, args[0])->head;
|
||||
}
|
||||
|
||||
O prim_tail(In *in, O *args, int argc, O env) {
|
||||
(void)env;
|
||||
if (argc != 1)
|
||||
error_throw(in, "tail: expected 1 argument, got %d", argc);
|
||||
return pair_unwrap(in, args[0])->tail;
|
||||
}
|
||||
|
||||
O prim_print(In *in, O *args, int argc, O env) {
|
||||
(void)env;
|
||||
if (argc != 1)
|
||||
error_throw(in, "print: expected 1 argument, got %d", argc);
|
||||
print(args[0]);
|
||||
return NIL;
|
||||
}
|
||||
|
||||
O prim_println(In *in, O *args, int argc, O env) {
|
||||
(void)env;
|
||||
if (argc != 1)
|
||||
error_throw(in, "println: expected 1 argument, got %d", argc);
|
||||
println(args[0]);
|
||||
return NIL;
|
||||
}
|
||||
|
||||
O prim_write(In *in, O *args, int argc, O env) {
|
||||
(void)env;
|
||||
if (argc != 1)
|
||||
error_throw(in, "write: expected 1 argument, got %d", argc);
|
||||
if (type(args[0]) != TYPE_STR)
|
||||
error_throw(in, "write: expected string argument, got %s", typename(type(args[0])));
|
||||
Ss *s = (Ss *)(UNBOX(args[0]) + 1);
|
||||
printf("%.*s", (int)s->len, s->data);
|
||||
return NIL;
|
||||
}
|
||||
|
||||
O prim_add(In *in, O *args, int argc, O env) {
|
||||
(void)env;
|
||||
I result = 0;
|
||||
for (int i = 0; i < argc; i++) {
|
||||
if (!IMM(args[i]))
|
||||
error_throw(in, "+: non numeric argument at position %d", i);
|
||||
result += ORD(args[i]);
|
||||
}
|
||||
return NUM(result);
|
||||
}
|
||||
|
||||
O prim_sub(In *in, O *args, int argc, O env) {
|
||||
(void)env;
|
||||
if (argc == 0)
|
||||
return NUM(0);
|
||||
} else {
|
||||
result = ORD(result);
|
||||
}
|
||||
for (O arg = nextarg(in, &args); arg != NIL; arg = nextarg(in, &args)) {
|
||||
if (!IMM(arg)) {
|
||||
error_throw(in, "+: non numeric argument");
|
||||
}
|
||||
result += ORD(arg);
|
||||
if (!IMM(args[0]))
|
||||
error_throw(in, "-: non numeric argument at position 0");
|
||||
I result = ORD(args[0]);
|
||||
if (argc == 1)
|
||||
return NUM(-result);
|
||||
for (int i = 1; i < argc; i++) {
|
||||
if (!IMM(args[i]))
|
||||
error_throw(in, "-: non numeric argument at position %d", i);
|
||||
result -= ORD(args[i]);
|
||||
}
|
||||
return NUM(result);
|
||||
}
|
||||
|
||||
O prim_sub(In *in, O args, O env) {
|
||||
args = interp_eval_list(in, args, env);
|
||||
I result = nextarg(in, &args);
|
||||
if (result == NIL) {
|
||||
return NUM(0);
|
||||
} else {
|
||||
result = ORD(result);
|
||||
}
|
||||
for (O arg = nextarg(in, &args); arg != NIL; arg = nextarg(in, &args)) {
|
||||
if (!IMM(arg)) {
|
||||
error_throw(in, "-: non numeric argument");
|
||||
}
|
||||
result -= ORD(arg);
|
||||
O prim_mul(In *in, O *args, int argc, O env) {
|
||||
(void)env;
|
||||
I result = 1;
|
||||
for (int i = 0; i < argc; i++) {
|
||||
if (!IMM(args[i]))
|
||||
error_throw(in, "*: non numeric argument at position %d", i);
|
||||
result *= ORD(args[i]);
|
||||
}
|
||||
return NUM(result);
|
||||
}
|
||||
|
||||
O prim_mul(In *in, O args, O env) {
|
||||
args = interp_eval_list(in, args, env);
|
||||
I result = nextarg(in, &args);
|
||||
if (result == NIL) {
|
||||
O prim_div(In *in, O *args, int argc, O env) {
|
||||
(void)env;
|
||||
if (argc == 0)
|
||||
return NUM(1);
|
||||
} else {
|
||||
result = ORD(result);
|
||||
}
|
||||
for (O arg = nextarg(in, &args); arg != NIL; arg = nextarg(in, &args)) {
|
||||
if (!IMM(arg)) {
|
||||
error_throw(in, "*: non numeric argument");
|
||||
}
|
||||
result *= ORD(arg);
|
||||
if (!IMM(args[0]))
|
||||
error_throw(in, "/: non numeric argument at position 0");
|
||||
I result = ORD(args[0]);
|
||||
for (int i = 1; i < argc; i++) {
|
||||
if (!IMM(args[i]))
|
||||
error_throw(in, "/: non numeric argument at position %d", i);
|
||||
if (ORD(args[i]) == 0)
|
||||
error_throw(in, "/: division by zero at position %d", i);
|
||||
result /= ORD(args[i]);
|
||||
}
|
||||
return NUM(result);
|
||||
}
|
||||
|
||||
O prim_div(In *in, O args, O env) {
|
||||
args = interp_eval_list(in, args, env);
|
||||
I result = nextarg(in, &args);
|
||||
if (result == NIL) {
|
||||
return NUM(1);
|
||||
} else {
|
||||
result = ORD(result);
|
||||
}
|
||||
for (O arg = nextarg(in, &args); arg != NIL; arg = nextarg(in, &args)) {
|
||||
if (!IMM(arg)) {
|
||||
error_throw(in, "/: non numeric argument");
|
||||
}
|
||||
if (ORD(arg) == 0) {
|
||||
error_throw(in, "/: division by zero");
|
||||
}
|
||||
result /= ORD(arg);
|
||||
}
|
||||
return NUM(result);
|
||||
}
|
||||
|
||||
O prim_equal(In *in, O args, O env) {
|
||||
args = interp_eval_list(in, args, env);
|
||||
I result = NIL;
|
||||
|
||||
O fst = nextarg(in, &args);
|
||||
for (O next = nextarg(in, &args); next != NIL; next = nextarg(in, &args)) {
|
||||
if (fst == next) {
|
||||
result = in->t;
|
||||
} else {
|
||||
O prim_equal(In *in, O *args, int argc, O env) {
|
||||
(void)env;
|
||||
if (argc < 2)
|
||||
return in->t;
|
||||
O first = args[0];
|
||||
for (int i = 1; i < argc; i++) {
|
||||
if (first != args[i])
|
||||
return NIL;
|
||||
}
|
||||
fst = next;
|
||||
}
|
||||
return result;
|
||||
return in->t;
|
||||
}
|
||||
|
||||
O prim_lt(In *in, O args, O env) {
|
||||
args = interp_eval_list(in, args, env);
|
||||
O fst = nextarg(in, &args);
|
||||
O snd = nextarg(in, &args);
|
||||
if (IMM(fst) && IMM(snd)) {
|
||||
return bool(in, ORD(fst) < ORD(snd));
|
||||
O prim_lt(In *in, O *args, int argc, O env) {
|
||||
(void)env;
|
||||
if (argc != 2)
|
||||
error_throw(in, "<: expected 2 arguments, got %d", argc);
|
||||
if (IMM(args[0]) && IMM(args[1])) {
|
||||
return BOOL(ORD(args[0]) < ORD(args[1]));
|
||||
} else {
|
||||
error_throw(in, "<: expected numeric arguments");
|
||||
return NIL;
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
O prim_gt(In *in, O args, O env) {
|
||||
args = interp_eval_list(in, args, env);
|
||||
O fst = nextarg(in, &args);
|
||||
O snd = nextarg(in, &args);
|
||||
if (IMM(fst) && IMM(snd)) {
|
||||
return bool(in, ORD(fst) > ORD(snd));
|
||||
O prim_gt(In *in, O *args, int argc, O env) {
|
||||
(void)env;
|
||||
if (argc != 2)
|
||||
error_throw(in, ">: expected 2 arguments, got %d", argc);
|
||||
if (IMM(args[0]) && IMM(args[1])) {
|
||||
return BOOL(ORD(args[0]) > ORD(args[1]));
|
||||
} else {
|
||||
error_throw(in, ">: expected numeric arguments");
|
||||
return NIL;
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
O prim_fn(In *in, O args, O env) {
|
||||
O params = nextarg(in, &args);
|
||||
O body = args;
|
||||
|
||||
I mark = gc_rootmark(&in->gc);
|
||||
gc_addroot(&in->gc, ¶ms);
|
||||
gc_addroot(&in->gc, &env);
|
||||
gc_addroot(&in->gc, &body);
|
||||
|
||||
O progn = symbol_make(in, "progn");
|
||||
O body_form = pair_make(in, progn, body);
|
||||
gc_addroot(&in->gc, &body_form);
|
||||
|
||||
Gh *hdr = gc_alloc(&in->gc, sizeof(Gh) + sizeof(Cl));
|
||||
hdr->type = TYPE_CLOS;
|
||||
Cl *cl = (Cl *)(hdr + 1);
|
||||
cl->args = params;
|
||||
cl->env = env;
|
||||
cl->body = body_form;
|
||||
|
||||
gc_rootreset(&in->gc, mark);
|
||||
return BOX(hdr);
|
||||
}
|
||||
|
||||
O prim_mac(In *in, O args, O env) {
|
||||
O params = nextarg(in, &args);
|
||||
O body = args;
|
||||
|
||||
I mark = gc_rootmark(&in->gc);
|
||||
gc_addroot(&in->gc, ¶ms);
|
||||
gc_addroot(&in->gc, &env);
|
||||
gc_addroot(&in->gc, &body);
|
||||
|
||||
O progn = symbol_make(in, "progn");
|
||||
O body_form = pair_make(in, progn, body);
|
||||
gc_addroot(&in->gc, &body_form);
|
||||
|
||||
Gh *hdr = gc_alloc(&in->gc, sizeof(Gh) + sizeof(Cl));
|
||||
hdr->type = TYPE_MAC;
|
||||
Cl *cl = (Cl *)(hdr + 1);
|
||||
cl->args = params;
|
||||
cl->env = env;
|
||||
cl->body = body_form;
|
||||
|
||||
gc_rootreset(&in->gc, mark);
|
||||
return BOX(hdr);
|
||||
}
|
||||
|
||||
O prim_gc(In *in, O args, O env) {
|
||||
(void)in;
|
||||
O prim_gc(In *in, O *args, int argc, O env) {
|
||||
(void)args;
|
||||
(void)argc;
|
||||
(void)env;
|
||||
gc_collect(&in->gc);
|
||||
return NIL;
|
||||
}
|
||||
|
||||
O prim_def(In *in, O args, O env) {
|
||||
O sym = nextarg(in, &args);
|
||||
O val_expr = nextarg(in, &args);
|
||||
|
||||
if (type(sym) != TYPE_SYM) {
|
||||
error_throw(in, "def: expected symbol");
|
||||
}
|
||||
|
||||
I mark = gc_rootmark(&in->gc);
|
||||
gc_addroot(&in->gc, &sym);
|
||||
gc_addroot(&in->gc, &env);
|
||||
|
||||
O val = interp_eval(in, val_expr, env);
|
||||
gc_addroot(&in->gc, &val);
|
||||
|
||||
O pair = pair_make(in, sym, val);
|
||||
gc_addroot(&in->gc, &pair);
|
||||
|
||||
in->env = pair_make(in, pair, in->env);
|
||||
|
||||
gc_rootreset(&in->gc, mark);
|
||||
return sym;
|
||||
}
|
||||
|
||||
O prim_defn(In *in, O args, O env) {
|
||||
O sym = nextarg(in, &args);
|
||||
O params = nextarg(in, &args);
|
||||
O body = args;
|
||||
|
||||
if (type(sym) != TYPE_SYM) {
|
||||
error_throw(in, "defn: expected symbol");
|
||||
}
|
||||
|
||||
I mark = gc_rootmark(&in->gc);
|
||||
gc_addroot(&in->gc, &sym);
|
||||
gc_addroot(&in->gc, ¶ms);
|
||||
gc_addroot(&in->gc, &body);
|
||||
gc_addroot(&in->gc, &env);
|
||||
|
||||
O progn = symbol_make(in, "progn");
|
||||
O body_form = pair_make(in, progn, body);
|
||||
gc_addroot(&in->gc, &body_form);
|
||||
|
||||
Gh *hdr = gc_alloc(&in->gc, sizeof(Gh) + sizeof(Cl));
|
||||
hdr->type = TYPE_CLOS;
|
||||
Cl *cl = (Cl *)(hdr + 1);
|
||||
cl->args = params;
|
||||
cl->env = env;
|
||||
cl->body = body_form;
|
||||
|
||||
O fn = BOX(hdr);
|
||||
gc_addroot(&in->gc, &fn);
|
||||
|
||||
O pair = pair_make(in, sym, fn);
|
||||
gc_addroot(&in->gc, &pair);
|
||||
|
||||
in->env = pair_make(in, pair, in->env);
|
||||
|
||||
gc_rootreset(&in->gc, mark);
|
||||
return sym;
|
||||
}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue