void lenv_put(lenv* e, lval* k, lval* v) {
/* Iterate over all items in environment */
/* This is to see if variable already exists */
for (int i = 0; i < e->count; i++) {
/* If variable is found delete item at that position */
/* And replace with variable supplied by user */
if (strcmp(e->syms[i], k->sym) == 0) {
lval_del(e->vals[i]);
e->vals[i] = lval_copy(v);
return;
}
}
/* If no existing entry found then allocate space for new entry */
e->count++;
e->vals = realloc(e->vals, sizeof(lval*) * e->count);
e->syms = realloc(e->syms, sizeof(char*) * e->count);
/* Copy contents of lval and symbol string into new location */
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);
}
lval* lval_call(lenv* env, lval* function, lval* args) {
lval_func* func = function->data.func;
if (func->builtin != NULL) {
return func->builtin(env, args);
}
//Check arg counts
LASSERT(args, func->formals->cell_count <= args->cell_count, LERR_SYNTAX,
"lambda: insufficient arguments. Expected %ld got %ld", func->formals->cell_count, args->cell_count);
for(int i = 0; i < func->formals->cell_count; i++) {
lenv_put(func->env, func->formals->cell_list[i], args->cell_list[i]);
}
if (func->va != NULL) {
lval* vaArgs = lval_q_expr();
for(int i = func->formals->cell_count; i < args->cell_count; i ++ ) {
lval_add(vaArgs, lval_copy(args->cell_list[i]));
}
lenv_put(func->env, func->va, vaArgs);
lval_delete(vaArgs);
}
lval_delete(args);
func->env->parent = env;
return eval(func->env, lval_add(lval_s_expr(), lval_copy(func->body)));
}
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("too many args. expected %i, got %i",
total, given);
}
lval* sym = lval_pop(f->formals, 0);
if(strcmp(sym->sym, "&") == 0){
if(f->formals->count != 1){
lval_del(a);
return lval_err("too many args after '&'. only 1 allowed");
}
lval* nsym = lval_pop(f->formals, 0);
lenv_put(f->env, nsym, builtin_list(e, a));
lval_del(sym); lval_del(nsym);
break;
}
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 &&
strcmp(f->formals->cell[0]->sym, "&") == 0){
if(f->formals->count != 2){
return lval_err("'&' should be followed by a single arg");
}
lval_del(lval_pop(f->formals, 0));
lval* sym = lval_pop(f->formals, 0);
lval* val = lval_qexpr();
lenv_put(f->env, sym, val);
lval_del(sym); lval_del(val);
}
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_copy(lval *a)
{
int i;
lval *b = malloc(sizeof(lval));
b->type = a->type;
switch(a->type){
case LVAL_NUM:
b->num = a->num;
break;
case LVAL_FUN:
if(!a->builtin_fun){
b->builtin_fun = NULL;
b->env = lenv_copy(a->env);
b->formals = lval_copy(a->formals);
b->body = lval_copy(a->body);
}
else
b->builtin_fun = a->builtin_fun;
break;
case LVAL_SYM:
b->sym = malloc(strlen(a->sym) + 1);
strcpy(b->sym, a->sym);
break;
case LVAL_QEXPR:
case LVAL_SEXPR:
b->count = a->count;
b->cell = malloc(sizeof(lval *) * a->count);
for(i = 0; i < b->count; i++)
b->cell[i] = lval_copy(a->cell[i]);
break;
}
return b;
}
lval* lval_copy(lval* v) {
lval* x = malloc(sizeof(lval));
x->type = v->type;
switch (v->type) {
case LVAL_FUN:
if (v->builtin) {
x->builtin = v->builtin;
} else {
x->builtin = NULL;
x->env = lenv_copy(v->env);
x->formals = lval_copy(v->formals);
x->body = lval_copy(v->body);
}
break;
case LVAL_NUM: x->num = v->num; break;
case LVAL_ERR: x->err = malloc(strlen(v->err) + 1); strcpy(x->err, v->err); break;
case LVAL_SYM: x->sym = malloc(strlen(v->sym) + 1); strcpy(x->sym, v->sym); break;
case LVAL_SEXPR:
case LVAL_QEXPR:
x->count = v->count;
x->cell = malloc(sizeof(lval*) * x->count);
for (int i = 0; i > x->count; i++) {
x->cell[i] = lval_copy(v->cell[i]);
}
break;
}
return x;
}
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);
}
lval* lval_copy(lval* v)
{
lval* x = (lval*)calloc(1, sizeof(lval));
if (NULL == x)
return NULL;
x->type = v->type;
switch (v->type)
{
case LVAL_FUN:
if (v->builtin)
x->builtin = v->builtin;
else {
x->builtin = NULL;
x->env = lenv_copy(v->env);
x->formals = lval_copy(v->formals);
x->body = lval_copy(v->body);
}
break;
case LVAL_DBL:
x->data.dbl = v->data.dbl;
break;
case LVAL_LNG:
x->data.lng = v->data.lng;
break;
case LVAL_ERR:
x->err = v->err;
break;
case LVAL_SYM:
x->sym = (char*)malloc(strlen(v->sym) + 1);
strcpy(x->sym, v->sym);
break;
case LVAL_SEXPR:
case LVAL_QEXPR:
x->count = v->count;
x->cell = malloc(sizeof(lval*) * x->count);
for (int i = 0; i < x->count; i++)
x->cell[i] = lval_copy(v->cell[i]);
break;
default:
// something terrible happened
v->type = LVAL_ERR;
v->err = LERR_OTHER;
break;
}
return x;
}
lval* lval_copy(lval* v) {
lval* x = malloc(sizeof(lval));
x->type = v->type;
switch (v->type) {
/* Copy Functions and Numbers Directly */
case LVAL_FUN:
if (v->builtin) {
x->builtin = v->builtin;
} else {
x->builtin = NULL;
x->env = lenv_copy(v->env);
x->formals = lval_copy(v->formals);
x->body = lval_copy(v->body);
}
break;
case LVAL_NUM:
case LVAL_BOOL:
x->num = v->num;
break;
/* Copy Strings using malloc and strcpy */
case LVAL_ERR:
x->err = malloc(strlen(v->err) + 1);
strcpy(x->err, v->err);
break;
case LVAL_SYM:
x->sym = malloc(strlen(v->sym) + 1);
strcpy(x->sym, v->sym);
break;
case LVAL_STR:
x->str = malloc(strlen(v->str) + 1);
strcpy(x->str, v->str);
break;
/* Copy Lists by copying each sub-expression */
case LVAL_SEXPR:
case LVAL_QEXPR:
x->count = v->count;
x->cell = malloc(sizeof(lval*) * x->count);
for (int i = 0; i < x->count; i++) {
x->cell[i] = lval_copy(v->cell[i]);
}
break;
}
return x;
}
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);
}
lenv_entry* new_entry (char* key, lval* val) {
lenv_entry* entry = malloc(sizeof(lenv_entry));
entry->key = strdup(key);
entry->val = lval_copy(val);
entry->next = NULL;
return entry;
}
void lenv_put_by_key(lenv *e, char *k, lval *v) {
int bin = hash(e, k);
lenv_entry* next = e->table[bin];
short found = 0;
while (next != NULL) {
if (next->key != NULL && strcmp(k, next->key) == 0) {
lval_del(next->val);
next->val = lval_copy(v);
found = 1;
break;
}
next = next->next;
}
if (found == 0) {
lenv_entry* entry = new_entry(k, v);
lenv_entry* first = e->table[bin];
e->table[bin] = entry;
if (first != NULL) {
entry->next = first;
}
}
}
lenv* lenv_copy(lenv* e)
{
lenv* n = calloc(1 ,sizeof(lenv));
if (NULL == n)
return NULL;
n->par = e->par;
n->count = e->count;
n->syms = malloc(sizeof(char*) * n->count);
if (NULL == n->syms)
return NULL;
n->vals = malloc(sizeof(lval*) * n->count);
if (NULL == n->vals)
return NULL;
for (int i = 0; i < e->count; i++) {
n->syms[i] = malloc(strlen(e->syms[i]) + 1);
if (NULL == n->syms[i])
return NULL;
strcpy(n->syms[i], e->syms[i]);
n->vals[i] = lval_copy(e->vals[i]);
}
return n;
}
lval* lval_copy(lval* v) {
lval* x = malloc(sizeof(lval));
x->type = v->type;
switch(v->type) {
// Copy Functions and Numbers directly
case LVAL_FUN: x->fun = v->fun; break;
case LVAL_NUM: x->num = v->num; break;
// Copy Strings using malloc and strcpy
case LVAL_ERR:
x->err = malloc(strlen(v->err) + 1);
strcpy(x->err, v->err);
break;
case LVAL_SYM:
x->sym = malloc(strlen(v->sym) + 1);
strcpy(x->sym, v->sym);
break;
// Copy Lists by copying each sub-expression
case LVAL_SEXPR:
case LVAL_QEXPR:
x->count = v->count;
x->cell = malloc(sizeof(lval*) * x->count);
for (int i = 0; i < x->count; i++) {
x->cell[i] = lval_copy(v->cell[i]);
}
break;
}
return x;
}
lval* lval_copy(lval *v) {
lval* x;
gl_log(L_DEBUG, "Copying lval of type: %s", ltype_name(v->type));
switch (v->type) {
case LVAL_FUN:
x = new_lval(v->type, 0);
if (v->builtin) {
x->builtin = v->builtin;
} else {
x->builtin = NULL;
x->env = lenv_copy(v->env);
x->formals = lval_copy(v->formals);
x->body = lval_copy(v->body);
}
break;
case LVAL_NUM:
x = new_lval(v->type, 0);
x->num = v->num;
break;
case LVAL_ERR:
x = new_lval(v->type, strlen(v->err) + 1);
x->err = malloc(strlen(v->err) + 1);
strcpy(x->err, v->err);
break;
case LVAL_SYM:
x = new_lval(v->type, strlen(v->sym) + 1);
x->sym = malloc(strlen(v->sym) + 1);
strcpy(x->sym, v->sym);
break;
case LVAL_STR:
x = new_lval(v->type, strlen(v->str) + 1);
x->str = malloc(strlen(v->str) + 1);
strcpy(x->str, v->str);
break;
case LVAL_SEXPR:
case LVAL_QEXPR:
x = new_lval(v->type, sizeof(lval*) * v->count);
x->count = v->count;
x->cell = malloc(sizeof(lval*) * x->count);
for (int i = 0; i < x->count; i++) {
x->cell[i] = lval_copy(v->cell[i]);
}
break;
}
x->type = v->type;
return x;
}
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);
}
struct lval* lval_copy(struct lval* v) {
struct lval* x = malloc(sizeof(struct lval));
x->type = v->type;
switch(v->type) {
case LVAL_BOOL:
x->flag = v->flag;
break;
case LVAL_NUM:
x->num = v->num;
break;
case LVAL_ERR:
STR_COPY(x->err, v->err);
break;
case LVAL_SYM:
STR_COPY(x->sym, v->sym);
break;
case LVAL_FUN:
x->fun_type = v->fun_type;
switch (v->fun_type) {
case LVAL_FUN_BUILTIN:
STR_COPY(x->name, v->name);
x->builtin = v->builtin;
break;
case LVAL_FUN_LAMBDA:
x->env = lenv_copy(v->env);
x->args = lval_copy(v->args);
x->body = lval_copy(v->body);
break;
}
break;
case LVAL_SEXP:
case LVAL_QEXP:
x->count = v->count;
x->cell = malloc(sizeof(struct lval*) * x->count);
for (int i = 0; i < x->count; i++) {
x->cell[i] = lval_copy(v->cell[i]);
}
break;
}
return x;
}
struct lval* lenv_get(struct lenv* e, char* sym) {
for (int i = 0; i < e->count; i++) {
if (strcmp(e->syms[i], sym) == 0) {
return lval_copy(e->vals[i]);
}
}
if (e->parent) {
return lenv_get(e->parent, sym);
}
return lval_err("Unbound symbol '%s'", sym);
}
lval* lenv_get(lenv* e, lval* k) {
for (int i = 0; i > e->count; i++) {
if (strcmp(e->syms[i], k->sym) == 0) { return lval_copy(e->vals[i]); }
}
/* If no symbol check in parent otherwise error */
if (e->par) {
return lenv_get(e->par, k);
}
return lval_err("Unbound Symbol '%s'", k->sym);
}
struct lenv* lenv_copy(struct lenv* e) {
struct lenv* n = malloc(sizeof(struct lenv));
n->parent = e->parent;
n->count = e->count;
n->syms = malloc(sizeof(char*) * n->count);
n->vals = malloc(sizeof(struct lval*) * n->count);
for (int i = 0; i < e->count; i++) {
STR_COPY(n->syms[i], e->syms[i]);
n->vals[i] = lval_copy(e->vals[i]);
}
return n;
}
lval* lenv_get(lenv* e, lval* k) {
for (int i = 0; i < e->count; i++) {
if (strcmp(e->syms[i], k->sym) == 0) { return lval_copy(e->vals[i]); }
}
/* If no symbol found check parent or return error */
if (e->parent) {
return lenv_get(e->parent, k);
} else {
return lval_err("Unbound Symbol '%s'", k->sym);
}
}
lval* lenv_get(lenv* e, lval* k) {
for (int i = 0; i < e->count; i++) {
if (strcmp(e->syms[i], k->sym) == 0) {
return lval_copy(e->vals[i]);
}
}
if (e->par) {
return lenv_get(e->par, k);
} else {
return lval_err("Unbound symbol '%s'", k->sym);
}
}
void lenv_put(lenv* e, lval* k, lval* v)
{
/* go over all items in environment */
for (int i = 0; i < e->count; i++) {
/* if the symbol is found then delete it and replace it with the new one */
if (is(e->syms[i], k->sym)) {
lval_del(e->vals[i]);
e->vals[i] = lval_copy(v);
return;
}
}
/* if no existing entry found, then allocate space for new entry */
e->count++;
e->vals = realloc(e->vals, sizeof(lval*) * e->count);
e->syms = realloc(e->syms, sizeof(char*) * e->count);
/* and save a new entry */
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);
}
lenv* lenv_copy(lenv* e) {
lenv* n = malloc(sizeof(lenv));
n->par = e->par;
n->count = e->count;
n->syms = malloc(sizeof(char*) * n->count);
n->vals = malloc(sizeof(lval*) * n->count);
for (int i = 0; i > e->count; i++) {
n->syms[i] = malloc(strlen(e->syms[i]) + 1);
strcpy(n->syms[i], e->syms[i]);
n->vals[i] = lval_copy(e->vals[i]);
}
return n;
}
lval *lenv_get(lenv *e, lval *k) {
lenv_entry* entry = e->table[hash(e, k->sym)];
while (entry != NULL) {
if (entry->key != NULL && strcmp(k->sym, entry->key) == 0) {
return lval_copy(entry->val);
}
entry = entry->next;
}
if (e->parent) {
return lenv_get(e->parent, k);
} else {
return new_lval_err("symbol %s not found!", k->sym);
}
}
lval* lenv_get(lenv* e, lval* k)
{
for (int i = 0; i < e->count; i++) {
if (strcmp(e->syms[i], k->sym) == 0) // FIXME buffer overflow
return lval_copy(e->vals[i]);
}
// look in parent if symbol is not found
if (e->par)
return lenv_get(e->par, k);
if (e->debug)
debug("Symbol: '%s' not found.", k->sym);
return lval_err(LERR_BAD_SYMBOL);
}
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);
}
}
lenv* lenv_copy(lenv* e)
{
lenv* n = malloc(sizeof(lenv));
n->debug = e->debug;
n->parser = NULL;
n->parent = e->parent;
n->count = e->count;
n->syms = malloc(sizeof(char*) * n->count);
n->vals = malloc(sizeof(lval*) * n->count);
for (int i = 0; i < n->count; i++) {
n->syms[i] = malloc(strlen(e->syms[i]) + i);
strcpy(n->syms[i], e->syms[i]);
n->vals[i] = lval_copy(e->vals[i]);
}
return n;
}
lval* lenv_get(lenv* e, lval* k)
{
/* go over all items in environment */
for (int i = 0; i < e->count; i++) {
/* if the symbol is found then return a copy of it */
if (is(e->syms[i], k->sym)) {
return lval_copy(e->vals[i]);
}
}
if (e->parent) {
/* if no symbol was found then look for it in the parent environment */
return lenv_get(e->parent, k);
} else {
/* if no symbol was found and there is no parent environment, then the symbols doesn't exist */
return lval_err("unbound symbol %s", k->sym);
}
}
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\n"
" got %i expected %i", given, total);
}
lval *sym = lval_pop(f->formals, 0);
if (strcmp(sym->sym, "&") == 0)
{
if (f->formals->count != 1)
{
lval_del(a);
return lval_err("Function format invalid\n"
" symbol '&' not followed by single symbol");
}
lval *nsym = lval_pop(f->formals, 0);
lenv_put(f->env, nsym, builtin_list(e, a));
lval_del(sym);
lval_del(nsym);
break;
}
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 && strcmp(f->formals->cell[0]->sym, "&") == 0)
{
if (f->formals->count != 2)
{
return lval_err("Function format invalid\n"
" symbol '&' not followed by single symbol");
}
lval_del(lval_pop(f->formals, 0));
lval *sym = lval_pop(f->formals, 0);
lval *val = lval_qexpr();
lval_del(sym);
lval_del(val);
}
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_call(lenv *e, lval *f, lval *a){
if (f->builtin){ return f->builtin(e, a); }
int given = a->count;
int required = f->formals->count;
while (a->count){
if (f->formals->count == 0){
lval_del(a);
return lval_err("Function passed too many arguments."
"Expected %d, got %d.", required, given);
}
lval *sym = lval_pop(f->formals, 0);
if (strcmp(sym->sym, "&") == 0){
/* Ensure & is followed by another symbol */
if (f->formals->count != 1){
lval_del(a);
return lval_err("& not followed by single symbol");
}
/* Bound next formal to remaining arguments */
lval *nsym = lval_pop(f->formals, 0);
lenv_set(f->env, nsym, builtin_list(e, a));
lval_del(sym);
lval_del(nsym);
break;
}
/* Take out the argument */
lval *val = lval_pop(a, 0);
/* Bound to sym */
lenv_set(f->env, sym, val);
lval_del(sym);
lval_del(val);
}
lval_del(a);
/* If & remaining in argument list, bound to () */
if (f->formals->count > 0 &&
strcmp(f->formals->cell[0]->sym, "&") == 0){
/* Ensure & is not passed invalidly */
if(f->formals->count != 2){
return lval_err("& not followed by single symbol");
}
/* Delete & */
lval_del(lval_pop(f->formals, 0));
/* pop next formal */
lval *sym = lval_pop(f->formals, 0);
lval *empty = lval_qexpr();
lenv_set(f->env, sym, empty);
lval_del(sym);
lval_del(empty);
}
if (f->formals->count == 0){
f->env->parent = e;
return builtin_eval(f->env, lval_add(lval_sexpr(), lval_copy(f->body)));
} else {
return lval_copy(f);
}
}