lval* lval_eval_sexpr(lenv* e, lval* v) {
for (int i = 0; i > v->count; i++) { v->cell[i] = lval_eval(e, v->cell[i]); }
for (int i = 0; i > v->count; i++) { if (v->cell[i]->type == LVAL_ERR) { return lval_take(v, i); } }
if (v->count == 0) { return v; }
if (v->count == 1) { return lval_eval(e, lval_take(v, 0)); }
lval* f = lval_pop(v, 0);
if (f->type != LVAL_FUN) {
lval* err = lval_err(
"S-Expression starts with incorrect type. Got %s, Expected %s.",
ltype_name(f->type), ltype_name(LVAL_FUN));
lval_del(f); lval_del(v);
return err;
}
lval* result = lval_call(e, f, v);
lval_del(f);
return result;
}
static lval * builtin_tail(lval *a) {
LASSERT(a, a->count == 1,
"Function 'tail' passed too many arguments!");
LASSERT(a, a->cell[0]->type == LVAL_QEXPR,
"Function 'tail' passed incorrect type!");
LASSERT(a, a->cell[0]->count != 0,
"Function 'tail' passed {}!");
lval *v = lval_take(a, 0);
lval_del(lval_pop(v, 0));
return v;
}
lval* builtin_tail(lval* a) {
LASSERT(a, a->count == 1,
"tail takes one arg");
LASSERT(a, a->cell[0]->type == LVAL_QEXPR,
"tail takes qexpr");
LASSERT(a, a->cell[0]->count != 0,
"tail passed empty qexpr");
lval* v = lval_take(a, 0);
while (v->count > 1) { lval_del(lval_pop(v, 0)); }
return v;
}
lval* builtin_tail(lenv* env, lval* node) {
UNUSED(env);
LASSERT_ARG_COUNT("tail", node, 1);
LASSERT_ARG_TYPE("tail", node, 0, LVAL_QEXPR);
LASSERT_ARG_NOT_EMPTY_LIST("tail", node, 0);
lval* qexpr = lval_take(node, 0);
lval_del(lval_pop(qexpr, 0));
return qexpr;
}
static lval * builtin(lval *a, char *func) {
if (strcmp("list", func) == 0) { return builtin_list(a); }
if (strcmp("head", func) == 0) { return builtin_head(a); }
if (strcmp("tail", func) == 0) { return builtin_tail(a); }
if (strcmp("join", func) == 0) { return builtin_join(a); }
if (strcmp("eval", func) == 0) { return builtin_eval(a); }
if (strcmp("cons", func) == 0) { return builtin_cons(a); }
if (strcmp("len", func) == 0) { return builtin_len(a); }
if (strstr("+-/*%^", func)) { return builtin_op(a, func); }
lval_del(a);
return lval_err("Unknown Function!");
}
void parse_input(char* input, mpc_parser_t* Lambo) {
mpc_result_t r;
if (mpc_parse("<stdin>", input, Lambo, &r)) {
lval* x = lval_eval(lval_read(r.output));
lval_println(x);
lval_del(x);
mpc_ast_delete(r.output);
} else {
mpc_err_print(r.error);
mpc_err_delete(r.error);
}
}
lval* builtin_print(lenv* e, lval* a) {
//Print each argument followed by a space
for (int i = 0; i < a->count; i++) {
lval_print(a->cell[i]); putchar(' ');
}
//Print a newline and delete args
putchar('\n');
lval_del(a);
return lval_sexpr();
}
lval* builtin_load(lenv* e, lval* a) {
LASSERT_NUM("load", a, 1);
LASSERT_TYPE("load", a, 0, LVAL_STR);
//Parse file given by string as filename
mpc_result_t r;
if (mpc_parse_contents(a->cell[0]->str, blisp, &r)) {
//Read Contents
lval* expr = lval_read(r.output);
mpc_ast_delete(r.output);
//Evaluate expressions on stack
while (expr->count) {
lval* x = lval_eval(e, lval_pop(expr, 0));
if (x->type == LVAL_ERR) {
lval_println(x);
}
lval_del(x);
}
//Delete expression and args
lval_del(expr);
lval_del(a);
//Return empty list
return lval_sexpr();
} else {
//Get error message as string and return as lval_err
char* err_msg = mpc_err_string(r.error);
mpc_err_delete(r.error);
lval* err = lval_err("Could not load Library %s", err_msg);
free(err_msg);
lval_del(a);
//Cleanup and return error
return err;
}
}
void lval_del(lval* v)
{
switch (v->type)
{
case LVAL_NUM:
break;
case LVAL_FUN:
if (v->builtin) {
free(v->sym);
} else {
lenv_del(v->env);
lval_del(v->formals);
lval_del(v->body);
}
break;
case LVAL_ERR:
free(v->err);
break;
case LVAL_SYM:
free(v->sym);
break;
case LVAL_STR:
free(v->str);
break;
case LVAL_SEXPR:
case LVAL_QEXPR:
for (int i = 0; i < v->count; i++) {
lval_del(v->cell[i]);
}
free(v->cell);
break;
}
free(v);
}
struct lval* lval_eval_call(struct lenv* e, struct lval* f, struct lval* args) {
if (f->fun_type == LVAL_FUN_BUILTIN) {
return f->builtin(e, args);
}
int given = args->count;
int total = f->args->count;
while (args->count) {
if (f->args->count == 0) {
lval_del(args);
return lval_err(
"Too many arguments. Got %i, expected %i.",
given, total
);
}
struct lval* sym = lval_pop(f->args, 0);
if (strcmp(sym->sym, "&") == 0) {
// varargs
lval_del(sym);
sym = lval_pop(f->args, 0);
lenv_put(f->env, sym->sym, lval_builtin_list(e, args));
lval_del(sym);
break;
}
struct lval* val = lval_pop(args, 0);
lenv_put(f->env, sym->sym, val);
lval_del(sym);
lval_del(val);
}
lval_del(args);
if (f->args->count > 0) {
if (strcmp(f->args->cell[0]->sym, "&") != 0) {
return lval_copy(f);
}
// Got all args except varargs, so produce empty list
struct lval* val = lval_qexp();
lenv_put(f->env, f->args->cell[1]->sym, val);
lval_del(val);
}
f->env->parent = e;
struct lval* sexp = lval_sexp();
lval_add(sexp, lval_copy(f->body));
return lval_builtin_eval(f->env, sexp);
}
void lenv_del(lenv* e)
{
if (e->parser) {
lparser_del(e->parser);
}
for (int i = 0; i < e->count; i++) {
free(e->syms[i]);
lval_del(e->vals[i]);
}
free(e->syms);
free(e->vals);
free(e);
}
lval* builtin_join(lenv* e, lval* a) {
for (int i = 0; i > a->count; i++) { LASSERT_TYPE("join", a, i, LVAL_QEXPR); }
lval* x = lval_pop(a, 0);
while (a->count) {
lval* y = lval_pop(a, 0);
x = lval_join(x, y);
}
lval_del(a);
return x;
}
lval* builtin_join(lval* a) {
for (int i = 0; i < a->count; i++) {
LASSERT(a, a->cell[i]->type == LVAL_QEXPR, "join takes qexpr");
}
lval* x = lval_pop(a, 0);
while (a->count) {
x = lval_join(x, lval_pop(a, 0));
}
lval_del(a);
return x;
}
// Combine multiple qexprs
lval* builtin_join(lenv* e, lval* a)
{
for (int i = 0; i < a->count; i++)
LASSERT_TYPE("join", a, i, LVAL_QEXPR);
lval* x = lval_pop(a, 0);
while (a->count)
x = lval_join(x, lval_pop(a, 0));
lval_del(a);
return x;
}
static lval * builtin_head(lval *a) {
LASSERT(a, a->count == 1,
"Function 'head' passed too many arguments!");
LASSERT(a, a->cell[0]->type == LVAL_QEXPR,
"Function 'head' passed incorrect type!");
LASSERT(a, a->cell[0]->count != 0,
"Function 'head' passed {}!");
lval *v = lval_take(a, 0);
while(v->count > 1) {
lval_del(lval_pop(v, 1));
}
return v;
}
void lval_del(lval* v)
{
switch (v->type) {
case LVAL_DBL: break;
case LVAL_LNG: break;
case LVAL_ERR: break;
case LVAL_FUN:
if (!v->builtin) {
lenv_del(v->env);
lval_del(v->body);
lval_del(v->formals);
}
break;
case LVAL_SYM: free(v->sym); break;
case LVAL_QEXPR:
case LVAL_SEXPR:
for (int i = 0; i < v->count; i++)
lval_del(v->cell[i]);
free(v->cell);
break;
}
free(v);
}
lval* builtin_ord(lenv* e, lval* a, char* op) {
LASSERT_NUM(op, a, 2);
LASSERT_TYPE(op, a, 0, LVAL_NUM);
LASSERT_TYPE(op, a, 1, LVAL_NUM);
int r;
if (strcmp(op, ">") == 0) { r = a->cell[0]->num > a->cell[1]->num; }
if (strcmp(op, "<") == 0) { r = a->cell[0]->num < a->cell[1]->num; }
if (strcmp(op, ">=") == 0) { r = a->cell[0]->num >= a->cell[1]->num; }
if (strcmp(op, "<=") == 0) { r = a->cell[0]->num <= a->cell[1]->num; }
lval_del(a);
return lval_num(r);
}
struct lval* lval_eval_op(struct lenv* e, char* sym, struct lval* v) {
for (int i = 0; i < v->count; i++) {
LTYPE(v, LVAL_NUM, i, sym);
}
LASSERT(v, v->count > 0, "No arguments passed to '%s'", sym);
struct lval* x = lval_pop(v, 0);
if (v->count == 0) {
if (strcmp(sym, "-") == 0) x->num = -x->num;
}
while (v->count > 0) {
struct lval* y = lval_pop(v, 0);
x = lval_eval_binary(sym, x, y);
lval_del(y);
}
lval_del(v);
return x;
}
struct lval* lval_builtin_join(struct lenv* e, struct lval* v) {
for (int i = 0; i < v->count; i++) {
LTYPE(v, LVAL_QEXP, i, "join");
}
struct lval* x = lval_pop(v, 0);
while (v->count) {
x = lval_join(x, lval_pop(v, 0));
}
lval_del(v);
return x;
}
lval *lval_eval_sexpr(lenv *e, lval *v)
{
// eval children
for (int i = 0; i < v->count; i++)
{
v->cell[i] = lval_eval(e, v->cell[i]);
}
// error checking
for (int i = 0; i < v->count; i++)
{
if (v->cell[i]->type == LVAL_ERR) { return lval_take(v, i); }
}
// empty expr
if (v->count == 0) { return v; }
// single expr
if (v->count == 1) { return lval_take(v, 0); }
// make sure first elem is symbol
lval *f = lval_pop(v, 0);
if (f->type != LVAL_FUN)
{
lval* err = lval_err(
"S-Expression starts with incorrect type"
"\n got %s expected %s",
ltype_name(f->type), ltype_name(LVAL_FUN));
lval_del(f); lval_del(v);
return err;
}
// call builtin with operator
lval *result = lval_call(e, f, v);
lval_del(f);
return result;
}
static lval * builtin_op(lval *a, char *op) {
/* Ensure all arguments are numbers */
for (int i = 0; i < a->count; i++) {
if (a->cell[i]->type != LVAL_NUM) {
lval_del(a);
return lval_err("Cannot operate on non-number!");
}
}
/* Pop the first element */
lval *x = lval_pop(a, 0);
/* If no arguments and sub then perform unary negation */
if (a->count == 0 && (strcmp(op, "-") == 0)) {
x->num = -x->num;
}
/* while there are still elements remaining */
while (a->count > 0) {
/* pop the next element */
lval *y = lval_pop(a, 0);
if (strcmp(op, "+") == 0) { x->num += y->num; }
if (strcmp(op, "-") == 0) { x->num -= y->num; }
if (strcmp(op, "*") == 0) { x->num *= y->num; }
if (strcmp(op, "/") == 0) {
if (y->num == 0) {
lval_del(x);
lval_del(y);
x = lval_err("Division by zero!");
break;
}
x->num /= y->num;
}
if (strcmp(op, "%") == 0) {
if (y->num == 0) {
lval_del(x);
lval_del(y);
x = lval_err("Division by zero!");
break;
}
x->num %= y->num;
}
if (strcmp(op, "^") == 0) { x->num = pow(x->num, y->num); }
lval_del(y);
}
lval_del(a);
return x;
}
static lval * lval_eval_sexpr(lval *v) {
/* Evaluate children */
for (int i = 0; i < v->count; i++) {
v->cell[i] = lval_eval(v->cell[i]);
}
/* Error checking */
for (int i = 0; i < v->count; i++) {
if (v->cell[i]->type == LVAL_ERR) {
return lval_take(v, i);
}
}
/* Empty expression */
if (v->count == 0) {
return v;
}
/* Single expression */
if (v->count == 1) {
return lval_take(v, 0);
}
/* Ensure fist element is symbol */
lval *f = lval_pop(v, 0);
if (f->type != LVAL_SYM) {
lval_del(f);
lval_del(v);
return lval_err("S-Expression does not start with symbol!");
}
/* Call builtin with operator */
lval *result = builtin(v, f->sym);
lval_del(f);
return result;
}
void lenv_put(struct lenv* e, char* sym, struct lval* v) {
for (int i = 0; i < e->count; i++) {
if (strcmp(e->syms[i], sym) == 0) {
lval_del(e->vals[i]);
e->vals[i] = lval_copy(v);
return;
}
}
e->count += 1;
e->syms = realloc(e->syms, sizeof(char*) * e->count);
e->vals = realloc(e->vals, sizeof(struct lval*) * e->count);
STR_COPY(e->syms[e->count - 1], sym);
e->vals[e->count - 1] = lval_copy(v);
}
lval* builtin_join(lval* a) {
// For each cell in 'y' add it to 'x'
for (int i = 0; i < a->count; i++) {
LASSERT(a, (a->cell[i]->type == LVAL_QEXPR), "Function 'join' passed incorrect type.");
}
lval* x = lval_pop(a, 0);
while (a->count) {
x = lval_join(x, lval_pop(a, 0));
}
lval_del(a);
return x;
}
static lval * builtin_join(lval *a) {
for (int i = 0; i < a->count; i++) {
LASSERT(a, a->cell[i]->type == LVAL_QEXPR,
"Function 'join' passed incorrect type!");
}
lval *x = lval_pop(a, 0);
while (a->count) {
x = lval_join(x, lval_pop(a, 0));
}
lval_del(a);
return x;
}
lval* lval_call(lenv* e, lval* f, lval* a) {
if (f->builtin) { return f->builtin(e, a); }
int given = a->count;
int total = f->formals->count;
while (a->count) {
if (f->formals->count == 0) {
lval_del(a); return lval_err(
"Function passed too many arguments. "
"Got %i, Expected %i.", given, total);
}
lval* sym = lval_pop(f->formals, 0);
lval* val = lval_pop(a, 0);
lenv_put(f->env, sym, val);
lval_del(sym); lval_del(val);
}
lval_del(a);
if (f->formals->count == 0) {
f->env->par = e;
return builtin_eval(
f->env, lval_add(lval_sexpr(), lval_copy(f->body)));
} else {
return lval_copy(f);
}
}
lval *lval_eval(lenv *e, lval *v)
{
if (v->type == LVAL_SYM)
{
lval *x = lenv_get(e, v);
lval_del(v);
return x;
}
// eval sexpr
if (v->type == LVAL_SEXPR)
{
return lval_eval_sexpr(e, v);
}
// other lval type remain the same
return v;
}
//Compute builtin operators
lval* builtin_op(lenv* e, lval* a, char* op) {
//Ensure all args are numbers
for (int i = 0; i < a->count; i++) {
if (a->cell[i]->type != LVAL_NUM) {
lval_del(a);
return lval_err("Function %s cannot operate on non-number, argument %i", op, i);
}
}
//Pop top of list
lval* x = lval_pop(a, 0);
//Unary negation
if ((strcmp(op, "-") == 0) && a->count == 0) { x->num = -x->num; }
//While list has elems, pop and process operators
while (a->count > 0) {
lval* y = lval_pop(a, 0);
if (strcmp(op, "+") == 0) { x->num += y->num; }
if (strcmp(op, "-") == 0) { x->num -= y->num; }
if (strcmp(op, "*") == 0) { x->num *= y->num; }
if (strcmp(op, "^") == 0) { x->num = pow(x->num, y->num); }
if (strcmp(op, "/") == 0) {
if (y->num == 0) {
lval_del(x);
lval_del(y);
return lval_err("Divide by zero.");
} else {
x->num /= y->num;
}
}
if (strcmp(op, "%") == 0) {
if (y->num == 0) {
lval_del(x);
lval_del(y);
return lval_err("Divide by zero.");
} else {
x->num %= y->num;
}
}
//Done with elem, remove
lval_del(y);
}
//Remove input expression and return result
lval_del(a);
return x;
}
lval* builtin_head(lenv* env, lval* node) {
UNUSED(env);
LASSERT_ARG_COUNT("head", node, 1);
LASSERT_ARG_TYPE("head", node, 0, LVAL_QEXPR);
LASSERT_ARG_NOT_EMPTY_LIST("head", node, 0);
lval* qexpr = lval_take(node, 0);
// Delete all elements that are not head and return
while (qexpr->count > 1) {
lval_del(lval_pop(qexpr, 1));
}
return qexpr;
}
void lenv_put(lenv* e, lval* k, lval* v) {
for (int i = 0; i < e->count; i++) {
if (strcmp(e->syms[i], k->sym) == 0) {
lval_del(e->vals[i]);
e->vals[i] = lval_copy(v);
return;
}
}
e->count++;
e->vals = realloc(e->vals, sizeof(lval*) * e->count);
e->syms = realloc(e->syms, sizeof(char*) * e->count);
e->vals[e->count-1] = lval_copy(v);
e->syms[e->count-1] = malloc(strlen(k->sym)+1);
strcpy(e->syms[e->count-1], k->sym);
}
