sdkhjfdsv
This commit is contained in:
parent
1aec6085d9
commit
537aa6e404
16 changed files with 683 additions and 71 deletions
269
src/prim.c
269
src/prim.c
|
|
@ -2,43 +2,58 @@
|
|||
#include <stdlib.h>
|
||||
#include <wolflisp.h>
|
||||
|
||||
static O nextarg(O *list) {
|
||||
if (*list == NIL)
|
||||
return NIL;
|
||||
O arg = pair_unwrap(*list)->head;
|
||||
*list = pair_unwrap(*list)->tail;
|
||||
return arg;
|
||||
}
|
||||
|
||||
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)) {
|
||||
Pr *pr = malloc(sizeof(Pr));
|
||||
pr->name = name;
|
||||
pr->fn = fn;
|
||||
O sym = BOX(TAG(intern(&in->symtab, name, 0), TAG_SYM));
|
||||
O prim = BOX(TAG(pr, TAG_PRIM));
|
||||
return pair_make(&in->gc, sym, 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 = pair_unwrap(args)->head;
|
||||
args = pair_unwrap(args)->tail;
|
||||
O tail = pair_unwrap(args)->head;
|
||||
return pair_make(&in->gc, head, tail);
|
||||
O head = nextarg(&args);
|
||||
O tail = nextarg(&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(pair_unwrap(args)->head)->head;
|
||||
return pair_unwrap(nextarg(&args))->head;
|
||||
}
|
||||
|
||||
O prim_tail(In *in, O args, O env) {
|
||||
args = interp_eval_list(in, args, env);
|
||||
return pair_unwrap(pair_unwrap(args)->head)->tail;
|
||||
return pair_unwrap(nextarg(&args))->tail;
|
||||
}
|
||||
|
||||
O prim_print(In *in, O args, O env) {
|
||||
args = interp_eval_list(in, args, env);
|
||||
O arg = pair_unwrap(args)->head;
|
||||
print(arg);
|
||||
print(nextarg(&args));
|
||||
return NIL;
|
||||
}
|
||||
|
||||
O prim_println(In *in, O args, O env) {
|
||||
args = interp_eval_list(in, args, env);
|
||||
O arg = pair_unwrap(args)->head;
|
||||
O arg = nextarg(&args);
|
||||
println(arg);
|
||||
return NIL;
|
||||
}
|
||||
|
|
@ -46,8 +61,234 @@ O prim_println(In *in, O args, O env) {
|
|||
O prim_quote(In *in, O args, O env) {
|
||||
(void)in;
|
||||
(void)env;
|
||||
|
||||
if (args == NIL)
|
||||
return NIL;
|
||||
return pair_unwrap(args)->head;
|
||||
return nextarg(&args);
|
||||
}
|
||||
|
||||
O prim_if(In *in, O args, O env) {
|
||||
O cond_expr = nextarg(&args);
|
||||
O then_expr = nextarg(&args);
|
||||
O else_expr = nextarg(&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 result = NIL;
|
||||
for (O expr = nextarg(&args); expr != NIL; expr = nextarg(&args))
|
||||
result = interp_eval(in, expr, env);
|
||||
return result;
|
||||
}
|
||||
|
||||
O prim_add(In *in, O args, O env) {
|
||||
args = interp_eval_list(in, args, env);
|
||||
I result = nextarg(&args);
|
||||
if (result == NIL) {
|
||||
return NUM(0);
|
||||
} else {
|
||||
result = ORD(result);
|
||||
}
|
||||
for (O arg = nextarg(&args); arg != NIL; arg = nextarg(&args)) {
|
||||
if (!IMM(arg)) {
|
||||
error_throw(in, "+: non numeric argument");
|
||||
}
|
||||
result += ORD(arg);
|
||||
}
|
||||
return NUM(result);
|
||||
}
|
||||
|
||||
O prim_sub(In *in, O args, O env) {
|
||||
args = interp_eval_list(in, args, env);
|
||||
I result = nextarg(&args);
|
||||
if (result == NIL) {
|
||||
return NUM(0);
|
||||
} else {
|
||||
result = ORD(result);
|
||||
}
|
||||
for (O arg = nextarg(&args); arg != NIL; arg = nextarg(&args)) {
|
||||
if (!IMM(arg)) {
|
||||
error_throw(in, "-: non numeric argument");
|
||||
}
|
||||
result -= ORD(arg);
|
||||
}
|
||||
return NUM(result);
|
||||
}
|
||||
|
||||
O prim_mul(In *in, O args, O env) {
|
||||
args = interp_eval_list(in, args, env);
|
||||
I result = nextarg(&args);
|
||||
if (result == NIL) {
|
||||
return NUM(1);
|
||||
} else {
|
||||
result = ORD(result);
|
||||
}
|
||||
for (O arg = nextarg(&args); arg != NIL; arg = nextarg(&args)) {
|
||||
if (!IMM(arg)) {
|
||||
error_throw(in, "*: non numeric argument");
|
||||
}
|
||||
result *= ORD(arg);
|
||||
}
|
||||
return NUM(result);
|
||||
}
|
||||
|
||||
O prim_div(In *in, O args, O env) {
|
||||
args = interp_eval_list(in, args, env);
|
||||
I result = nextarg(&args);
|
||||
if (result == NIL) {
|
||||
return NUM(1);
|
||||
} else {
|
||||
result = ORD(result);
|
||||
}
|
||||
for (O arg = nextarg(&args); arg != NIL; arg = nextarg(&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(&args);
|
||||
for (O next = nextarg(&args); next != NIL; next = nextarg(&args)) {
|
||||
if (fst == next) {
|
||||
result = in->t;
|
||||
} else {
|
||||
return NIL;
|
||||
}
|
||||
fst = next;
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
O prim_lt(In *in, O args, O env) {
|
||||
args = interp_eval_list(in, args, env);
|
||||
O fst = nextarg(&args);
|
||||
O snd = nextarg(&args);
|
||||
if (IMM(fst) && IMM(snd)) {
|
||||
return bool(in, ORD(fst) < ORD(snd));
|
||||
} 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(&args);
|
||||
O snd = nextarg(&args);
|
||||
if (IMM(fst) && IMM(snd)) {
|
||||
return bool(in, ORD(fst) > ORD(snd));
|
||||
} else {
|
||||
error_throw(in, ">: expected numeric arguments");
|
||||
return NIL;
|
||||
};
|
||||
}
|
||||
|
||||
O prim_fn(In *in, O args, O env) {
|
||||
O params = nextarg(&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_gc(In *in, O args, O env) {
|
||||
(void)in;
|
||||
(void)args;
|
||||
(void)env;
|
||||
gc_collect(&in->gc);
|
||||
return NIL;
|
||||
}
|
||||
|
||||
O prim_def(In *in, O args, O env) {
|
||||
O sym = nextarg(&args);
|
||||
O val_expr = nextarg(&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(&args);
|
||||
O params = nextarg(&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