#include #include #include "lang.h" #include "util.h" lval* lval_new(int type) { lval* val = calloc(1,sizeof(lval)); val->type = type; return val; } lval* lval_num(double_t x) { lval* val = lval_new(LVAL_NUM); val->data.num = x; return val; } lval* lval_sym(char* x) { lval* val = lval_new(LVAL_SYM); val->data.sym = strdup(x); return val; } lval* lval_s_expr() { lval* val = lval_new(LVAL_S_EXPR); val->cell_count = 0; val->cell_list = NULL; return val; } lval* lval_q_expr() { lval* val = lval_new(LVAL_Q_EXPR); val->cell_count = 0; val->cell_list = NULL; return val; } lval* lval_builtin(lbuiltin func, char* name) { lval* val = lval_new(LVAL_FUNC); val->data.func = calloc(1, sizeof(lval_func)); val->data.func->builtin = func; val->data.func->name = strdup(name); return val; } lval* lval_lambda(lval* formals, lval* body) { lval* val = lval_new(LVAL_FUNC); val->data.func = calloc(1, sizeof(lval_func)); val->data.func->builtin = NULL; val->data.func->name = NULL; val->data.func->env = lenv_new(); val->data.func->formals = formals; val->data.func->body = body; return val; } lval* lval_exit() { lval* val = lval_new(LVAL_EXIT); return val; } lval* lval_add(lval* val, lval* x) { val->cell_count++; val->cell_list = realloc(val->cell_list, sizeof(lval*)*val->cell_count); val->cell_list[val->cell_count-1] = x; return val; } lval* lval_pop(lval* val, int index) { //Get the item lval* x = val->cell_list[index]; //Re-create the list ignoring the index we are extracting lval** newList = NULL; if (val->cell_count-1 > 0) { newList = calloc(val->cell_count-1, sizeof(lval*)); int k = 0; for(int i=0; i < val->cell_count; i++) { if (i == index) { continue; } newList[k++] = val->cell_list[i]; } } val->cell_count--; free(val->cell_list); val->cell_list = newList; return x; } lval* lval_take(lval* val, int i) { lval* x = lval_pop(val, i); lval_delete(val); return x; } lval* lval_join(lval* a, lval* b) { while(b->cell_count > 0) { lval_add(a, lval_pop(b,0)); } lval_delete(b); return a; } 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))); } BOOL lval_equal(lval* a, lval* b) { if (a->type != b->type) { return FALSE; } switch(a->type) { case LVAL_ERR: return a->data.err.num == b->data.err.num; case LVAL_EXIT: return TRUE; case LVAL_NUM: return fabs(a->data.num - b->data.num) <= DBL_EPSILON; case LVAL_SYM: return strcmp(a->data.sym, b->data.sym) == 0; case LVAL_FUNC: if (a->data.func->builtin != NULL) { if (b->data.func->builtin != NULL) { return a->data.func->builtin == a->data.func->builtin; } else { return FALSE; } } else { if (b->data.func->builtin == NULL) { return FALSE; } else { return lval_equal(b->data.func->formals, b->data.func->formals) && lval_equal(b->data.func->body, b->data.func->body); } } case LVAL_Q_EXPR: case LVAL_S_EXPR: if (a->cell_count != b->cell_count) { return 0; } for (int i = 0; i < a->cell_count; i++) { if (!lval_equal(a->cell_list[i], b->cell_list[i])) { return FALSE; } } return TRUE; default: return FALSE; } } void lval_delete(lval* val) { switch(val->type) { case LVAL_NUM: break; case LVAL_EXIT: break; case LVAL_FUNC: if (val->data.func != NULL) { if (val->data.func->builtin == NULL) { lenv_delete(val->data.func->env); lval_delete(val->data.func->formals); lval_delete(val->data.func->body); } else { free(val->data.func->name); } } break; case LVAL_SYM: free(val->data.sym); break; case LVAL_ERR: if (val->data.err.detail != NULL) { free(val->data.err.detail); } break; case LVAL_Q_EXPR: case LVAL_S_EXPR: for (int i = 0; i < val->cell_count; i++) { lval_delete(val->cell_list[i]); } if (val->cell_count > 0) { free(val->cell_list); } break; } free(val); } lval* lval_copy(lval* current) { lval* new = lval_new(current->type); switch(current->type) { case LVAL_FUNC: new->data.func = calloc(1, sizeof(lval_func)); lval_func* funcNew = new->data.func; lval_func* funcCurrent = current->data.func; if (funcCurrent->builtin == NULL) { funcNew->env = lenv_copy(funcCurrent->env); funcNew->body = lval_copy(funcCurrent->body); funcNew->formals = lval_copy(funcCurrent->formals); } else { funcNew->builtin = funcCurrent->builtin; funcNew->name = strdup(funcCurrent->name); } break; case LVAL_NUM: new->data.num = current->data.num; break; case LVAL_EXIT: break; case LVAL_SYM: new->data.sym = strdup(current->data.sym); break; case LVAL_ERR: new->data.err.num = current->data.err.num; new->data.err.detail = current->data.err.detail == NULL ? NULL : strdup(current->data.err.detail); break; case LVAL_Q_EXPR: case LVAL_S_EXPR: new->cell_count = current->cell_count; if (new->cell_count == 0) { new->cell_list = NULL; } else { new->cell_list = calloc(new->cell_count, sizeof(lval*)); for(int i=0; i < new->cell_count; i++) { new->cell_list[i] = lval_copy(current->cell_list[i]); } } break; } return new; } lval* lval_err(VAL_ERROR err){ return lval_err_detail(err, NULL); } lval* lval_err_detail(VAL_ERROR err, char* format, ...){ lval* val = lval_new(LVAL_ERR); val->data.err.num = err; va_list va; va_start(va, format); val->data.err.detail = calloc(512, sizeof(char)); vsnprintf(val->data.err.detail, 511, format, va); if (strlen(val->data.err.detail) == 0) { free(val->data.err.detail); val->data.err.detail = NULL; } else { val->data.err.detail = realloc(val->data.err.detail, strlen(val->data.err.detail)+1); } va_end(va); return val; } char* lval_str_name(VAL_TYPE type) { switch(type) { case LVAL_ERR: return "Error"; case LVAL_FUNC: return "Function"; case LVAL_NUM: return "Numeric"; case LVAL_Q_EXPR: return "Q-Expression"; case LVAL_SYM: return "Symbol"; case LVAL_S_EXPR: return "S-Expression"; default: return "UNKNOWN"; } }