Added lambda functions. variable length arguments still todo.

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) {
+lval* builtin_envdef(lenv* env, lval* val, char* type){
-    LASSERT_MIN_ARG_COUNT("def", val, val, 1);
+    LASSERT_MIN_ARG_COUNT(type, val, val, 1);
-    LASSERT_TYPE("def", val, val->cell_list[0], LVAL_Q_EXPR);
+    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;
 }

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
 }

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;
     

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

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
 }

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 = calloc(1, sizeof(lval_func));
-    val->data.func.name = strdup(name);
+    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: 
+        case LVAL_FUNC:
-            new->data.func.call = current->data.func.call; 
+            new->data.func = calloc(1, sizeof(lval_func));
-            new->data.func.name = strdup(current->data.func.name);
+            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;

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 {
+     struct lval_func* func;
-         char* name;
-         lbuiltin call;
-     } 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);

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

nbproject/Makefile-impl.mk

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