lambda tested and if added

1 files changed, 119 insertions, 80 deletions

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;