From c1987617a0fb4fede4d0040726a3571f7e0af60b Mon Sep 17 00:00:00 2001 From: Sam Stevens Date: Mon, 26 May 2014 22:37:19 +0100 Subject: [PATCH] Added lambda functions. variable length arguments still todo. --- functions.c | 47 ++++++++++++++++++++++---- functions.h | 3 ++ lang.c | 2 +- lenv.c | 33 ++++++++++++++++++- lenv.h | 5 +++ lval.c | 67 ++++++++++++++++++++++++++++++++++---- lval.h | 25 ++++++++++---- main.c | 13 +++++++- nbproject/Makefile-impl.mk | 2 +- 9 files changed, 172 insertions(+), 25 deletions(-) diff --git a/functions.c b/functions.c index ba8b0c5..3a109e0 100644 --- a/functions.c +++ b/functions.c @@ -6,7 +6,7 @@ void lenv_add_builtin(lenv* env, char* sym, lbuiltin func) { lval* symval = lval_sym(sym); - lval* funcval = lval_func(func, sym); + lval* funcval = lval_builtin(func, sym); lenv_put(env, symval, funcval); @@ -31,8 +31,11 @@ void lenv_add_builtin_funcs(lenv* env) { //ENV Functions lenv_add_builtin(env, "def", builtin_def); + lenv_add_builtin(env, "var", builtin_var); lenv_add_builtin(env, "listenv", builtin_listenv); lenv_add_builtin(env, "exit", builtin_exit); + lenv_add_builtin(env, "lambda", builtin_lambda); + lenv_add_builtin(env, "\\", builtin_lambda); } lval* builtin_add(lenv* env, lval* val) { @@ -139,26 +142,36 @@ lval* builtin_tail(lenv* env, lval* val){ return x; } -lval* builtin_def(lenv* env, lval* val) { - LASSERT_MIN_ARG_COUNT("def", val, val, 1); - LASSERT_TYPE("def", val, val->cell_list[0], LVAL_Q_EXPR); +lval* builtin_envdef(lenv* env, lval* val, char* type){ + LASSERT_MIN_ARG_COUNT(type, val, val, 1); + LASSERT_TYPE(type, val, val->cell_list[0], LVAL_Q_EXPR); lval* symbols = val->cell_list[0]; for(int i = 0; i < symbols->cell_count; i++) { - LASSERT_TYPE("def", val, symbols->cell_list[i], LVAL_SYM); + LASSERT_TYPE(type, val, symbols->cell_list[i], LVAL_SYM); } LASSERT(val, symbols->cell_count == val->cell_count -1, - LERR_OTHER, "def: incorrect number of definitions for symbols"); + LERR_OTHER, "%s: incorrect number of definitions for symbols", type); for(int i = 0; i < symbols->cell_count; i++) { - lenv_put(env, symbols->cell_list[i], val->cell_list[i+1]); + if (strcmp(type, "def") == 0) { + lenv_def(env, symbols->cell_list[i], val->cell_list[i+1]); + } else if (strcmp(type, "var") == 0) { + lenv_put(env, symbols->cell_list[i], val->cell_list[i+1]); + } } lval_delete(val); return lval_s_expr(); } +lval* builtin_var(lenv* env, lval* val) { + return builtin_envdef(env, val, "var"); +} +lval* builtin_def(lenv* env, lval* val) { + return builtin_envdef(env, val, "def"); +} lval* builtin_listenv(lenv* env, lval* val) { for(int i=0; i< env->count; i++) { @@ -181,4 +194,24 @@ lval* builtin_exit(lenv* env, lval* val) { lval_delete(val); return lval_exit(); +} + +lval* builtin_lambda(lenv* env, lval* val) { + LASSERT_ARG_COUNT("lambda", val, val, 2); + LASSERT_TYPE("lambda", val, val->cell_list[0], LVAL_Q_EXPR); + LASSERT_TYPE("lambda", val, val->cell_list[1], LVAL_Q_EXPR); + + lval* symbols = val->cell_list[0]; + + for(int i = 0; i < symbols->cell_count; i++) { + LASSERT_TYPE("lambda args", val, symbols->cell_list[i], LVAL_SYM); + } + + lval* formals = lval_pop(val,0); + lval* body = lval_pop(val, 0); + body->type = LVAL_S_EXPR; + + lval* lambda = lval_lambda(formals, body); + lval_delete(val); + return lambda; } \ No newline at end of file diff --git a/functions.h b/functions.h index fab3d91..61e53c4 100644 --- a/functions.h +++ b/functions.h @@ -34,9 +34,12 @@ extern "C" { lval* builtin_tail(lenv* env, lval* val); //ENV Functions + lval* builtin_envdef(lenv* env, lval* val, char* type); lval* builtin_def(lenv* env, lval* val); + lval* builtin_var(lenv* env, lval* val); lval* builtin_listenv(lenv* env, lval* val); lval* builtin_exit(lenv* env, lval* val); + lval* builtin_lambda(lenv* env, lval* val); #ifdef __cplusplus } diff --git a/lang.c b/lang.c index b321928..0bfb42d 100644 --- a/lang.c +++ b/lang.c @@ -103,7 +103,7 @@ lval* eval_s_expr(lenv* env, lval* val) { } //Call builtin - lval* result = func->data.func.call(env, val); + lval* result = lval_call(env, func, val); lval_delete(func); return result; diff --git a/lenv.c b/lenv.c index c1140b1..e84e243 100644 --- a/lenv.c +++ b/lenv.c @@ -7,6 +7,7 @@ lenv* lenv_new() { lenv* env = calloc(1, sizeof(lenv)); env->count = 0; + env->parent = NULL; env->syms = NULL; return env; } @@ -19,6 +20,15 @@ void lenv_delete(lenv* env) { free(env->syms); free(env); } +lenv* lenv_copy(lenv* env) { + lenv* new = lenv_new(); + new->parent = env; + new->syms = calloc(env->count, sizeof(symtab*)); + for(int i = 0; i < env->count; i++) { + new->syms[i] = symtab_copy(env->syms[i]); + } + return new; +} int lenv_compare_symtabs(const void *lhs, const void *rhs) { const struct symtab* l = *(const struct symtab**)lhs; @@ -55,7 +65,16 @@ lval* lenv_get(lenv* env, lval* sym) { LASSERT(sym, sym->type == LVAL_SYM, LERR_BAD_OP, "Expected symbol"); symtab* result = lenv_search(env, sym->data.sym); - return result != NULL ? lval_copy(result->lval) : lval_err(LERR_BAD_SYM); + + if (result != NULL) { + return lval_copy(result->lval); + } else { + if (env->parent != NULL) { + return lenv_get(env->parent, sym); + } else { + return lval_err_detail(LERR_BAD_SYM, "Unbound Symbol '%s'", sym->data.sym); + } + } } void lenv_put(lenv* env, lval* key, lval* val) { @@ -76,6 +95,12 @@ void lenv_put(lenv* env, lval* key, lval* val) { lenv_sort(env); } +void lenv_def(lenv* env, lval* key, lval* val) { + while(env->parent != NULL) { + env = env->parent; + } + lenv_put(env, key, val); +} symtab* symtab_new(char* sym, lval* lval) { symtab* new = calloc(1, sizeof(symtab)); @@ -89,4 +114,10 @@ void symtab_delete(symtab* symtab) { } free(symtab->sym); free(symtab); +} +symtab* symtab_copy(symtab* symtab) { + if (symtab == NULL) { + return NULL; + } + return symtab_new(symtab->sym, symtab->lval); } \ No newline at end of file diff --git a/lenv.h b/lenv.h index 3b1eb53..2b91cc5 100644 --- a/lenv.h +++ b/lenv.h @@ -25,11 +25,13 @@ extern "C" { struct lenv { size_t count; + struct lenv* parent; struct symtab** syms; }; lenv* lenv_new(); void lenv_delete(lenv* env); + lenv* lenv_copy(lenv* env); int lenv_compare_symtabs(const void *a, const void *b); void lenv_sort(lenv* env); @@ -37,9 +39,12 @@ extern "C" { lval* lenv_get(lenv* env, lval* sym); void lenv_put(lenv* env, lval* key, lval* val); + void lenv_def(lenv* env, lval* key, lval* val); + void lenv_var(lenv* env, lval* key, lval* val); symtab* symtab_new(char* sym, lval* lval); void symtab_delete(symtab* symtab); + symtab* symtab_copy(symtab* symtab); #ifdef __cplusplus } diff --git a/lval.c b/lval.c index a800e6b..7997b63 100644 --- a/lval.c +++ b/lval.c @@ -35,10 +35,21 @@ lval* lval_q_expr() { return val; } -lval* lval_func(lbuiltin func, char* name) { +lval* lval_builtin(lbuiltin func, char* name) { lval* val = lval_new(LVAL_FUNC); - val->data.func.call = func; - val->data.func.name = strdup(name); + 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() { @@ -91,11 +102,43 @@ lval* lval_join(lval* a, lval* 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 < args->cell_count; i++) { + lenv_put(func->env, func->formals->cell_list[i], args->cell_list[i]); + } + + lval_delete(args); + + func->env->parent = env; + + return eval(func->env, lval_add(lval_s_expr(), lval_copy(func->body))); +} + void lval_delete(lval* val) { switch(val->type) { case LVAL_NUM: break; case LVAL_EXIT: break; - case LVAL_FUNC: free(val->data.func.name); 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: @@ -120,9 +163,19 @@ lval* lval_copy(lval* current) { lval* new = lval_new(current->type); switch(current->type) { - case LVAL_FUNC: - new->data.func.call = current->data.func.call; - new->data.func.name = strdup(current->data.func.name); + 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; diff --git a/lval.h b/lval.h index 61442c4..d6cff86 100644 --- a/lval.h +++ b/lval.h @@ -12,9 +12,13 @@ extern "C" { #endif +//Forward declarations (if thats what they are called) struct lval; typedef struct lval lval; +struct lval_func; +typedef struct lval_func lval_func; + #include "lenv.h" enum VAL_TYPE { LVAL_ERR, LVAL_NUM, LVAL_SYM, LVAL_FUNC, LVAL_S_EXPR, LVAL_Q_EXPR, LVAL_EXIT }; @@ -24,7 +28,15 @@ typedef enum VAL_ERROR VAL_ERROR; typedef lval*(*lbuiltin)(lenv*, lval*); -typedef struct lval { +struct lval_func { + char* name; + lbuiltin builtin; + lenv* env; + lval* formals; + lval* body; +}; + +struct lval { enum VAL_TYPE type; union { double_t num; @@ -33,29 +45,28 @@ typedef struct lval { enum VAL_ERROR num; char* detail; } err; - struct { - char* name; - lbuiltin call; - } func; + struct lval_func* func; } data; int cell_count; struct lval** cell_list; -} lval; +}; lval* lval_new(int type); lval* lval_num(double_t x); lval* lval_sym(char* x); lval* lval_s_expr(); lval* lval_q_expr(); -lval* lval_func(lbuiltin func, char* name); +lval* lval_builtin(lbuiltin func, char* name); +lval* lval_lambda(lval* formals, lval* body); lval* lval_exit(); lval* lval_add(lval* val, lval* x); lval* lval_pop(lval* val, int i); lval* lval_take(lval* val, int i); lval* lval_join(lval* a, lval* b); +lval* lval_call(lenv* env, lval* function, lval* args); void lval_delete(lval* val); lval* lval_copy(lval* current); diff --git a/main.c b/main.c index ad2a20a..38dcbc1 100644 --- a/main.c +++ b/main.c @@ -99,8 +99,19 @@ void lval_print(lval* val) { case LVAL_SYM: printf("%s", val->data.sym); break; case LVAL_S_EXPR: lval_expr_print(val, "(", ")"); break; case LVAL_Q_EXPR: lval_expr_print(val, "{", "}"); break; - case LVAL_FUNC: printf("<%s>", val->data.func.name); break; case LVAL_EXIT: printf("exit"); break; + case LVAL_FUNC: ; + lval_func* func = val->data.func; + if (func->builtin != NULL) { + printf("<%s>", func->name); + } else { + printf("( "); + lval_print(func->formals); + putchar(' '); + lval_print(func->body); + putchar(')'); + } + break; case LVAL_ERR: printf("Error: "); switch(val->data.err.num) { diff --git a/nbproject/Makefile-impl.mk b/nbproject/Makefile-impl.mk index f2cf699..5b25bd3 100644 --- a/nbproject/Makefile-impl.mk +++ b/nbproject/Makefile-impl.mk @@ -24,7 +24,7 @@ CLEAN_SUBPROJECTS=${CLEAN_SUBPROJECTS_${SUBPROJECTS}} # Project Name -PROJECTNAME=klisp +PROJECTNAME=KLisp # Active Configuration DEFAULTCONF=Debug