lambda tested and if added

8 files changed, 189 insertions, 88 deletions

diff --git a/README.md b/README.md
index c017622..80b2834 100644
--- a/README.md
+++ b/README.md
@@ -4,5 +4,6 @@ A simple lisp/scheme interpreter
 
 #### TODO
 
+* improve errors
 * macros
 * FFI
diff --git a/files/test1.l b/files/test-cons.l
index b7e4749..7a4de7d 100644
--- a/files/test1.l
+++ b/files/test-cons.l
@@ -1,3 +1,4 @@
+(define a 3)
 '(sn ,(+ a 1))
 
 '(1 2 (lol . test) 3 4 ,(+ 1 2) test)
diff --git a/files/test-lambda.l b/files/test-lambda.l
new file mode 100644
index 0000000..e088ad6
--- /dev/null
+++ b/files/test-lambda.l
@@ -0,0 +1,23 @@
+(define make-add (lambda (a) (lambda (b) (+ a b))))
+(define add4 (make-add 4))
+(add4 5)
+
+'(a b ,((lambda (a) '(test . ,a)) 69) c d)
+
+(define fib (lambda (c) (fib-rec 0 1 0 c)))
+(define fib-rec (lambda (a b n c)
+                  (if (= n c)
+                      b
+                      (fib-rec b (+ a b) (+ n 1) c))))
+
+(define do (lambda (c f) (do-rec f 0 0 c)))
+
+(define do-rec (lambda (f r n c)
+                 (if (= n c) r
+                     (do-rec f (f n) (+ n 1) c))))
+
+;; comment
+;; another comment
+;; fib(13)
+(do 10 (lambda (n) (display (fib n)))) ; comment
+
diff --git a/files/test.l b/files/test.l
deleted file mode 100644
index d9e9acc..0000000
--- a/files/test.l
+++ /dev/null
@@ -1,5 +0,0 @@
-(define make-add (lambda (a) (lambda (b) (+ a b))))
-(define add4 (make-add 4))
-(add4 5)
-
-'(a b ,((lambda (a) '(test . ,a)) 69) c d)
diff --git a/src/builtin.h b/src/builtin.h
index 144ed4c..43d7ee2 100644
--- a/src/builtin.h
+++ b/src/builtin.h
@@ -3,10 +3,12 @@
 #define PROCEDURES(X)             \
 /*  X(symbol, name, argc) */      \
     X(plus,   "+",  2)            \
+    X(equal,  "=",  2)            \
     X(minus,  "-",  2)            \
     X(cons,   "cons", 2)          \
-    X(car,    "car", 1)           \
-    X(cdr,    "cdr", 1)           \
+    X(car,    "car",  1)          \
+    X(cdr,    "cdr",  1)          \
+    X(display,"display", 1)  \
 
 // Number of builtin procedures
 #define PLUS_ONE(_symbol, _name, _argc) 1 +
@@ -69,6 +71,27 @@ DECLARE_PROCEDURE(P)
 }
 #undef P
 
+#define P equal
+DECLARE_PROCEDURE(P)
+{
+    int f = 0;
+    int t = 1;
+
+    if(args[0]->type != args[1]->type) goto l_false;
+
+    switch(args[0]->type) {
+    case VALUE_INT:
+        if(args[0]->value.num == args[1]->value.num) goto l_true;
+    default: break;
+    }
+
+l_false:
+    return value_create(VALUE_INT, &f);
+l_true:
+    return value_create(VALUE_INT, &t);
+}
+#undef P
+
 #define P cons
 DECLARE_PROCEDURE(P)
 {
@@ -96,3 +119,19 @@ DECLARE_PROCEDURE(P)
     return right;
 }
 #undef P
+
+#define P display
+DECLARE_PROCEDURE(P)
+{
+    char buf[256];
+    value_string(args[0], (sizeof(buf)/sizeof(*buf)), buf);
+
+    #ifdef DEBUG
+    info("%s", buf);
+    #else
+    printf("%s\n", buf);
+    #endif
+
+    return value_copy(args[0]);
+}
+#undef P
diff --git a/src/lexer.c b/src/lexer.c
index 77407a9..b546fda 100644
--- a/src/lexer.c
+++ b/src/lexer.c
@@ -7,6 +7,7 @@
 
 #define CH(lexer) (lexer)->str[(lexer)->str_idx]
 #define TOKEN_SEPARATOR_TABLE(X, l)                    \
+    X((';' == CH(l)), CH(l) = '\0')                    \
     X(('(' == CH(l)), on_separator(l, TOKEN_LP))       \
     X((')' == CH(l)), on_separator(l, TOKEN_RP))       \
     X(('\''== CH(l)), on_separator(l, TOKEN_QUOTE))    \
@@ -29,7 +30,8 @@
     X(TOKEN_DOT,        ".")         \
     X(TOKEN_LAMBDA,     "lambda")    \
     X(TOKEN_DEFINE,     "define")    \
-    X(TOKEN_QUOTE_FORM, "quote")
+    X(TOKEN_QUOTE_FORM, "quote")     \
+    X(TOKEN_IF,          "if")
 
 #define TOKEN_VALUE_STRING_TABLE(X, tvalue)  \
     X(TOKEN_LP,      "(")                    \
diff --git a/src/lexer.h b/src/lexer.h
index c2e4637..b47f800 100644
--- a/src/lexer.h
+++ b/src/lexer.h
@@ -15,6 +15,7 @@
     X(TOKEN_LAMBDA)           \
     X(TOKEN_DEFINE)           \
     X(TOKEN_QUOTE_FORM)       \
+    X(TOKEN_IF)               \
     X(TOKEN_NONE)
 
 #define TO_ENUM(type) type,
diff --git a/src/main.c b/src/main.c
index f4d1c29..a63a392 100644
--- a/src/main.c
+++ b/src/main.c
@@ -29,19 +29,19 @@
 #define TOKEN_NEXT(tctx)                                 \
     ERR_Z(next_token(tctx), die("Can't get next token"))
 
-#define TOKEN_ASSERT(token, ttype, fail)        \
-    if(token->type != ttype) {                  \
-        err("Expected token '%s', not '%s'",    \
-            token_type_string[ttype],           \
-            token_type_string[token->type]);    \
-        fail;                                   \
+#define TOKEN_ASSERT(token, ttype, fail)          \
+    if(token->type != ttype) {                    \
+        err("Expected token '%s', not '%s'",      \
+            token_type_string[ttype],             \
+            token_type_string[token->type]);      \
+        fail;                                     \
     }
 
-#define TOKEN_SKIP(tctx, ttype, fail) do {       \
-        TOKEN_ASSERT(TOKEN(tctx), ttype, fail)   \
-        else {                                   \
-            TOKEN_NEXT(tctx);                    \
-        }                                        \
+#define TOKEN_SKIP(tctx, ttype, fail) do {        \
+        TOKEN_ASSERT(TOKEN(tctx), ttype, fail)    \
+        else {                                    \
+            TOKEN_NEXT(tctx);                     \
+        }                                         \
     } while(0)
 
 #define TOKEN_MATCH(tctx, ttype, fail) do {       \
@@ -67,7 +67,6 @@ static void print_value(value_t value)
          value_type_string[value->type] : "VALUE", buf);
 }
 
-// token context
 struct tctx {
     enum tctx_type {
         TCTX_LEXER,
@@ -81,7 +80,7 @@ struct tctx {
             lexer_t lexer;
             struct token token;
         } lex_ctx;
-        
+
         struct tok_ctx {
             struct token *list;
             size_t len;
@@ -122,7 +121,7 @@ static struct token *next_token(struct tctx *tctx)
     }
 
     #ifdef DEBUG
-    print_token(tctx->token);
+    // print_token(tctx->token);
     #endif
 
     return tctx->token;
@@ -140,6 +139,7 @@ value_t evaluate_sexp(env_t env, struct tctx *tctx);
 value_t evaluate_id    (env_t env, struct tctx *tctx);
 value_t evaluate_lambda(env_t env, struct tctx *tctx);
 value_t evaluate_define(env_t env, struct tctx *tctx);
+value_t evaluate_if    (env_t env, struct tctx *tctx);
 
 value_t quote_expr(env_t env, struct tctx *tctx);
 value_t quote_sexp(env_t env, struct tctx *tctx);
@@ -162,9 +162,20 @@ static void destroy_global_env(char *key, value_t value)
 
 int main(void)
 {
+
+    char *filename = "files/test-lambda.l";
+
+    FILE *fp = fopen(filename, "r");
+    if(!fp) {
+        die("fopen: %s", strerror(errno));
+    }
+
+    lexer_t lexer = lexer_create(fp);
+
     env_t builtin_env = env_create(ENV_EMPTY, destroy_env);
     global_env = env_create(builtin_env, destroy_global_env);
 
+    // add builtins
     for(size_t i = 0; i < BUILTIN_PROCEDURES; i++) {
         value_t proc_value = value_create(
             VALUE_PROC_BUILTIN,
@@ -173,15 +184,6 @@ int main(void)
                          (void *)builtin_proc_name_list[i],
                          (void *)proc_value, NULL, NULL);
     }
-    
-    char *filename = "files/test.l";
-        
-    FILE *fp = fopen(filename, "r");
-    if(!fp) {
-        die("fopen: %s", strerror(errno));
-    }
-    
-    lexer_t lexer = lexer_create(fp);
 
     struct tctx tctx = {0};
     tctx_init_lexer(&tctx, lexer);
@@ -197,15 +199,14 @@ int main(void)
         char buf[256] = {0};
         value_string(val, LEN(buf), buf);
         printf("%s:%zu:   %s\n", filename, lexer->line, buf);
-        #endif    
-        
+        #endif
+
         value_destroy(val);
     }
 
     lexer_destroy(lexer);
     fclose(fp);
 
-
     env_destroy(global_env);
     return 0;
 }
@@ -222,7 +223,7 @@ static value_t apply_lambda(struct proc *proc, value_t *args)
     value_t ret = VALUE_EMPTY;
     env_t env = ENV_EMPTY;
     struct tctx tctx = {0};
-    
+
     ERR_Z(env = env_create(env_copy(proc->parent_env), destroy_env), goto exit);
     tctx_init_toklist(&tctx, proc->body, proc->body_len);
 
@@ -231,10 +232,10 @@ static value_t apply_lambda(struct proc *proc, value_t *args)
                                 (void*)proc->arg_keys[i]->value.atom,
                                 (void*)value_copy(args[i]), NULL, NULL), _r, goto exit);
     }
-    
+
     TOKEN_NEXT(&tctx);
     ret = evaluate_expr(env, &tctx);
-    
+
 exit:
     env_destroy(env);
     return ret;
@@ -244,7 +245,7 @@ value_t apply(value_t proc, size_t argc, value_t *argv)
 {
     // TODO: make a global nil and copy it
     if(proc == VALUE_EMPTY) return value_create(VALUE_NIL, NULL);
-    
+
     switch(proc->type) {
     case VALUE_PROC:
         HAS_ENOUGH_ARGS(proc, proc, argc, return VALUE_EMPTY);
@@ -261,7 +262,7 @@ value_t apply(value_t proc, size_t argc, value_t *argv)
 value_t evaluate_expr(env_t env, struct tctx *tctx)
 {
     value_t ret = VALUE_EMPTY;
-        
+
     switch(TOKEN(tctx)->type) {
     case TOKEN_LP:
         ERR_Z(ret = evaluate_sexp(env, tctx), goto exit);
@@ -303,14 +304,14 @@ value_t evaluate_sexp(env_t env, struct tctx *tctx)
     size_t argc = 0;
 
     TOKEN_SKIP(tctx, TOKEN_LP, goto exit);
-    
+
     for(argc = 0; TOKEN(tctx)->type != TOKEN_RP; argc++)
     {
         if(argc >= LEN(body)) {
             err("Too many arguments");
             goto exit;
         }
-        
+
         switch(TOKEN(tctx)->type) {
         case TOKEN_LAMBDA:
             SPECIAL_FORM(ret, argc, evaluate_lambda(env, tctx), goto exit);
@@ -326,6 +327,9 @@ value_t evaluate_sexp(env_t env, struct tctx *tctx)
                         ret = VALUE_EMPTY;
                         goto exit);
             goto exit;
+        case TOKEN_IF:
+            SPECIAL_FORM(ret, argc, evaluate_if(env, tctx), goto exit);
+            goto exit;
         default:
             ERR_Z(body[argc] = evaluate_expr(env, tctx), goto exit);
             break;
@@ -335,20 +339,20 @@ value_t evaluate_sexp(env_t env, struct tctx *tctx)
     }
 
 #ifdef DEBUG
-    info("------------------");
-    info("Applying procedure");
-    print_value(body[0]);
-    info("With Arguemnts");
-    if(argc > 0)
-        for(size_t i = 0; i < argc-1; i++) print_value(body[i+1]);
+    // info("------------------");
+    // info("Applying procedure");
+    // print_value(body[0]);
+    // info("With Arguemnts");
+    // if(argc > 0)
+    //     for(size_t i = 0; i < argc-1; i++) print_value(body[i+1]);
 #endif
-    
+
     ret = apply(body[0], argc-1, &body[1]);
 
 #ifdef DEBUG
-    info("Returns");
-    print_value(ret);
-    info("-----------------");
+    // info("Returns");
+    // print_value(ret);
+    // info("-----------------");
 #endif
 
 exit:
@@ -362,14 +366,14 @@ value_t evaluate_id(env_t env, struct tctx *tctx)
     if(env == ENV_EMPTY) {
         return evaluate_id(global_env, tctx);
     }
-    
+
     value_t ret = VALUE_EMPTY;
     ERR_NZ(hashtable_query(env->table, (void *)TOKEN(tctx)->value.id, (void **)&ret), _r, goto fail);
 
     return value_copy(ret);
 
 fail:
-    if(env == global_env->parent) {        
+    if(env == global_env->parent) {
         err("Symbol %s is unbound", TOKEN(tctx)->value.id);
         return VALUE_EMPTY;
     }
@@ -379,14 +383,14 @@ fail:
 value_t evaluate_lambda(env_t env, struct tctx *tctx)
 {
     value_t ret = VALUE_EMPTY;
-    
+
     value_t args[32] = {VALUE_EMPTY};
     size_t argc = 0;
     value_t *arg_keys = NULL;
-    
+
     struct token *body = NULL;
     size_t body_len = 0;
-    
+
     TOKEN_SKIP(tctx, TOKEN_LAMBDA, goto fail);
     TOKEN_SKIP(tctx, TOKEN_LP, goto fail);
 
@@ -396,21 +400,21 @@ value_t evaluate_lambda(env_t env, struct tctx *tctx)
             err("Too many arguments");
             goto fail;
         }
-        
+
         if(TOKEN(tctx)->type != TOKEN_ID) {
             err("Token '%s' not expected in lambda args", token_type_string[TOKEN(tctx)->type]);
             goto fail;
         }
 
         ERR_Z(args[argc++] = value_from_token(TOKEN(tctx)), goto fail);
-              
+
         TOKEN_NEXT(tctx);
     }
-    
+
     ERR_Z(body_len = toklist_expr(tctx, &body), goto fail);
-            
+
     TOKEN_MATCH(tctx, TOKEN_RP, goto fail);
-    
+
     arg_keys = calloc(argc, sizeof(*arg_keys));
     memcpy(arg_keys, args, argc * sizeof(*arg_keys));
 
@@ -418,9 +422,9 @@ value_t evaluate_lambda(env_t env, struct tctx *tctx)
     ERR_Z(ret = value_create(VALUE_PROC, &proc),
           env_destroy(env); // remove the copy
           goto fail);
-    
+
     return ret;
-    
+
 fail:
     err("Procedure creation failed");
     for(size_t i = 0; i < argc; i++) value_destroy(args[i]);
@@ -441,14 +445,14 @@ fail:
 value_t evaluate_define(env_t env, struct tctx *tctx)
 {
     // TODO: don't alloc when the key is the same
-    char *key = NULL;    
+    char *key = NULL;
 
     // only in the outside environement
     if(env != ENV_EMPTY) {
         err("define can only be called in the outermost environement");
         goto fail;
     }
-    
+
     TOKEN_SKIP(tctx, TOKEN_DEFINE, goto fail);
 
     switch(TOKEN(tctx)->type)
@@ -462,17 +466,17 @@ value_t evaluate_define(env_t env, struct tctx *tctx)
     }
 
     TOKEN_NEXT(tctx);
-    
+
     value_t val = VALUE_EMPTY;
     ERR_Z(val = evaluate_expr(env, tctx), goto fail);
-    
+
     TOKEN_MATCH(tctx, TOKEN_RP,
                 value_destroy(val);
                 goto fail);
 
     value_t prevval = VALUE_EMPTY;
     char *prevkey = NULL;
-    
+
     ERR_NZ(
         hashtable_insert(global_env->table, (void *)key, (void *)val,
                          (void**)&prevkey, (void **)&prevval),
@@ -485,12 +489,44 @@ value_t evaluate_define(env_t env, struct tctx *tctx)
     if(prevkey) free(prevkey);
     value_destroy(prevval);
     return VALUE_EMPTY;
-    
+
 fail:
     if(key) free(key);
     return VALUE_EMPTY;
 }
 
+value_t evaluate_if(env_t env, struct tctx *tctx)
+{
+    value_t ret = VALUE_EMPTY;
+    value_t cond = VALUE_EMPTY;
+
+    TOKEN_SKIP(tctx, TOKEN_IF, goto exit);
+
+    ERR_Z(cond = evaluate_expr(env, tctx), goto exit);
+
+    ERR_Z(cond->type == VALUE_INT,
+          err("expected condition to evaluate to VALUE_INT");
+          goto exit);
+
+    if(cond->value.num) {
+        TOKEN_NEXT(tctx);
+        ret = evaluate_expr(env, tctx);
+
+        toklist_expr(tctx, NULL); // skip one expression
+    } else {
+        toklist_expr(tctx, NULL); // skip one expression
+
+        TOKEN_NEXT(tctx);
+        ret = evaluate_expr(env, tctx);
+    }
+
+    TOKEN_MATCH(tctx, TOKEN_RP, goto exit);
+
+exit:
+    value_destroy(cond);
+    return ret;
+}
+
 value_t quote_expr(env_t env, struct tctx *tctx)
 {
     value_t ret = VALUE_EMPTY;
@@ -504,7 +540,8 @@ value_t quote_expr(env_t env, struct tctx *tctx)
     case TOKEN_QUOTE:
     case TOKEN_LAMBDA:
     case TOKEN_DEFINE:
-    case TOKEN_QUOTE_FORM: ;
+    case TOKEN_QUOTE_FORM:
+    case TOKEN_IF: ;
         char name[64] = {0};
         ERR_Z(token_value_string(TOKEN(tctx), LEN(name), name), goto exit);
         struct token temp = {0}; temp.type = TOKEN_ID; temp.value.id = name;
@@ -534,7 +571,7 @@ value_t quote_sexp(env_t env, struct tctx *tctx)
 
     // TODO: make global nil and copy it
     ERR_Z(nil = value_create(VALUE_NIL, NULL), goto exit);
-    
+
     TOKEN_SKIP(tctx, TOKEN_LP, goto exit);
 
     // Parse NIL
@@ -542,7 +579,7 @@ value_t quote_sexp(env_t env, struct tctx *tctx)
         ret = value_copy(nil);
         goto exit;
     }
-        
+
     ERR_Z(left = quote_expr(env, tctx), goto exit);
 
     TOKEN_NEXT(tctx);
@@ -552,36 +589,36 @@ value_t quote_sexp(env_t env, struct tctx *tctx)
         TOKEN_NEXT(tctx);
         ERR_Z(right = quote_expr(env, tctx), return VALUE_EMPTY);
         TOKEN_MATCH(tctx, TOKEN_RP, return VALUE_EMPTY);
-        
+
         struct cons cons = {value_copy(left), value_copy(right)};
         ret = value_create(VALUE_CONS, &cons);
         goto exit;
     }
-    
+
     // Parse list
     right = value_copy(nil);
     value_t *rightmost = &right; // the final nil
     while(TOKEN(tctx)->type != TOKEN_RP)
     {
         value_t new = VALUE_EMPTY;
-        
+
         if(TOKEN(tctx)->type == TOKEN_DOT) {
             TOKEN_NEXT(tctx);
-            
+
             ERR_Z(new = quote_expr(env, tctx), goto exit);
 
             TOKEN_MATCH(tctx, TOKEN_RP,
                         value_destroy(new);
                         goto exit);
-            
-            value_destroy(*rightmost);
+
+            value_destroy(*rightmost); // destroy the copied nil
             *rightmost = new;
             break;
-        }            
-            
+        }
+
         ERR_Z(new = quote_expr(env, tctx),
               goto exit);
-        
+
         value_t new_cons = VALUE_EMPTY;
         struct cons cons = {new, *rightmost};
         ERR_Z(new_cons = value_create(VALUE_CONS, &cons),
@@ -590,7 +627,7 @@ value_t quote_sexp(env_t env, struct tctx *tctx)
 
         *rightmost = new_cons;
         rightmost = &new_cons->value.cons.right;
-        
+
         TOKEN_NEXT(tctx);
     }
 
@@ -609,28 +646,30 @@ size_t toklist_expr(struct tctx *tctx, struct token **toklist)
 {
     struct token tokens[256];
     size_t tokens_len = 0;
-    
+
     size_t depth = 0;
     do {
         TOKEN_NEXT(tctx);
-        
+
         if(tokens_len >= LEN(tokens)) {
             err("Too many tokens in expr");
             goto fail;
-        }        
-            
+        }
+
         if(TOKEN(tctx)->type == TOKEN_LP) depth++;
         else if(TOKEN(tctx)->type == TOKEN_RP) depth--;
 
         token_clone(&tokens[tokens_len++], TOKEN(tctx));
-        
+
     } while(depth > 0 || IS_OP(TOKEN(tctx)));
 
+    if(!toklist) goto fail;
+
     *toklist = calloc(tokens_len, sizeof(*tokens));
     memcpy(*toklist, tokens, tokens_len * sizeof(*tokens));
 
     return tokens_len;
-    
+
 fail:
     for(size_t i = 0; i < tokens_len; i++) token_dealloc(&tokens[i]);
     return 0;