sam/klisp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Added lambda functions. variable length arguments still todo.

Browse Source
This commit is contained in:
Sam Stevens
2014-05-26 22:37:19 +01:00
parent 41fd1756a9
commit c1987617a0
9 changed files with 172 additions and 25 deletions
Download Patch File Download Diff File Expand all files Collapse all files

47
functions.c
View File

@@ -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;
}

3
functions.h
View File

@@ -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
}

2
lang.c
View File

@@ -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;

33
lenv.c
View File

@@ -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);
}

5
lenv.h
View File

@@ -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
}

67
lval.c
View File

@@ -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;

25
lval.h
View File

@@ -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);

13
main.c
View File

@@ -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("(<lambda> ");
lval_print(func->formals);
putchar(' ');
lval_print(func->body);
putchar(')');
}
break;
case LVAL_ERR:
printf("Error: ");
switch(val->data.err.num) {

2
nbproject/Makefile-impl.mk
View File

@@ -24,7 +24,7 @@ CLEAN_SUBPROJECTS=${CLEAN_SUBPROJECTS_${SUBPROJECTS}}
# Project Name
PROJECTNAME=klisp
PROJECTNAME=KLisp
# Active Configuration
DEFAULTCONF=Debug