Add tailcalls in org_cherry_eval

org_cherry_eval uses now tailcalls for evaluating recursive processes.
Distinct between let and define for constant and value definition.

include/cherry/runtime.h

@@ -167,12 +167,13 @@ extern struct org_cherry_value*         org_cherry_true;
 extern struct org_cherry_value*         org_cherry_false;
 extern struct org_cherry_value*         org_cherry_symbol_quote;
 extern struct org_cherry_value*         org_cherry_symbol_define;
+extern struct org_cherry_value*         org_cherry_symbol_let;
 extern struct org_cherry_value*         org_cherry_symbol_lambda;
 extern struct org_cherry_value*         org_cherry_symbol_if;
 
 extern struct org_cherry_value*         org_cherry_symbol_begin;
+extern struct org_cherry_value*         org_cherry_symbol_try;
 extern struct org_cherry_value*         org_cherry_symbol_catch;
-extern struct org_cherry_value*         org_cherry_symbol_finally;
 
 
 // ----------------------------------------------------------------------------
@@ -198,6 +199,9 @@ extern struct org_cherry_value*         org_cherry_symbol_finally;
 #define IS_DEFINE(value) \
   IS_TAGGED(value, org_cherry_symbol_define)
 
+#define IS_LET(value) \
+  IS_TAGGED(value, org_cherry_symbol_let)
+
 #define IS_IF(value) \
   IS_TAGGED(value, org_cherry_symbol_if)
 
@@ -207,12 +211,12 @@ extern struct org_cherry_value*         org_cherry_symbol_finally;
 #define IS_BEGIN(value) \
   IS_TAGGED(value, org_cherry_symbol_begin)
 
+#define IS_TRY(value) \
+  IS_TAGGED(value, org_cherry_symbol_try)
+
 #define IS_CATCH(value) \
   IS_TAGGED(value, org_cherry_symbol_catch)
 
-#define IS_FINALLY(value) \
-  IS_TAGGED(value, org_cherry_symbol_finally)
-
 #define IS_APPLICATION(value) \
   IS_PAIR(value)
 

source/cherry.c

@@ -55,7 +55,6 @@ org_cherry_process_file(const char* filename, const cy_byte_t* method, struct or
 	if(!setjmp(EXCEPTION_JUMP(env))) {
 		while(exp != 0) {
 			org_cherry_eval(env, exp);
-
 			exp = org_cherry_read(context);
 		}
 

source/eval.c

@@ -20,21 +20,11 @@
 #include <stdlib.h>
 
 static struct org_cherry_value*
-org_cherry_eval_define(struct org_cherry_environment* env, struct org_cherry_value* exp)
+org_cherry_eval_let(struct org_cherry_environment* env, struct org_cherry_value* exp)
 {
-	struct org_cherry_value* symbol;
-	struct org_cherry_value* value;
+	struct org_cherry_value* symbol = HEAD(exp);
+	struct org_cherry_value* value = HEAD(TAIL(exp));
 	
-	if(IS_SYMBOL(HEAD(TAIL(exp)))) {
-		symbol = HEAD(TAIL(exp));
-		value = HEAD(TAIL(TAIL(exp)));
-	} else {
-		symbol = HEAD(HEAD(TAIL(exp)));
-
-		value = TO_VALUE(org_cherry_list_cons(org_cherry_symbol_lambda, 
-			TO_VALUE(org_cherry_list_cons(TAIL(HEAD(TAIL(exp))), TAIL(TAIL(exp))))));
-	}
-
 	if(org_cherry_env_add(env, symbol, org_cherry_eval(env, value)))
 		return org_cherry_true;
 	else
@@ -62,95 +52,17 @@ org_cherry_eval_values(struct org_cherry_environment* env, struct org_cherry_val
 }
 
 
-static struct org_cherry_value*
-org_cherry_eval_sequence(struct org_cherry_environment* env, struct org_cherry_value* body)
-{
-	struct org_cherry_value* val = org_cherry_false;
-
-	while(!IS_NULL(body)) {
-		val = org_cherry_eval(env, HEAD(body));
-		body = TAIL(body);
-	}
-
-	return val;
-}
-
-static struct org_cherry_value*
-org_cherry_apply(struct org_cherry_environment* env, struct org_cherry_value* operator, struct org_cherry_value* operands)
-{
-	if(IS_PRIMITIVE(operator)) 
-		return (operator->fun_value)(env, operands);
-	else if(IS_PROCEDURE(operator)) {
-		struct org_cherry_environment* env = TO_PROC(operator)->env;
-
-		org_cherry_env_push(env);
-
-		struct org_cherry_value* params = TO_PROC(operator)->param;
-		struct org_cherry_value* sym, val;
-
-		if(IS_VARIABLE(params))
-			org_cherry_env_add(env, params, operands);
-		else {
-			while(!IS_NULL(operands)) {
-				// check if all params are given (IS_NULL(params))
-				org_cherry_env_add(env, HEAD(params), HEAD(operands));
-
-				params = TAIL(params);
-				operands = TAIL(operands);
-			}
-		}
-
-		return org_cherry_eval_sequence(env, TO_PROC(operator)->body);
-	}
-}
-
-
-static struct org_cherry_value*
-org_cherry_eval_if(struct org_cherry_environment* env, struct org_cherry_value* value)
-{
-	if(IS_NULL(value))
-		return org_cherry_false;
-
-	if(IS_TRUE(org_cherry_eval(env, HEAD(value))))
-		return !IS_NULL(TAIL(value)) ? org_cherry_eval(env, HEAD(TAIL(value))) : org_cherry_false;
-	else if(!IS_NULL(TAIL(TAIL(value))))
-		return org_cherry_eval(env, HEAD(TAIL(TAIL(value))));
-	else
-		return org_cherry_false;
-}
-
-
 struct org_cherry_value*
-org_cherry_eval_begin(struct org_cherry_environment* env, struct org_cherry_value* value)
+org_cherry_eval(struct org_cherry_environment* env, struct org_cherry_value* value)
 {
-    struct org_cherry_value* return_val = org_cherry_false;
-
-    org_cherry_env_push_exception_point(env);
-
-    int val = setjmp(EXCEPTION_JUMP(env));
-
-	if(val == 0){  
-        return_val = org_cherry_apply(env, org_cherry_eval(env, HEAD(value)), org_cherry_emptylist);
-	} else if(!IS_NULL(HEAD(TAIL(value))) && val) {
-        return_val = org_cherry_apply(env, org_cherry_eval(env, HEAD(TAIL(value))), 
-				org_cherry_list_cons(EXCEPTION_DATA(env), org_cherry_emptylist));
-	}
-
-    if(!IS_NULL(HEAD(TAIL(TAIL(value)))))
-        org_cherry_apply(env, org_cherry_eval(env, HEAD(TAIL(TAIL(value)))), org_cherry_emptylist);
-
-    org_cherry_env_pop_exception_point(env);
+    struct org_cherry_value *proc, *args;
 
 
-	return return_val;
-}
-
-struct org_cherry_value*
-org_cherry_eval(struct org_cherry_environment* env, struct org_cherry_value* value)
-{
+tailcall:
 	if(IS_SELF_EVALUATING(value))
 		return value;
-	else if(IS_VARIABLE(value)) {
+	
+    else if(IS_VARIABLE(value)) {
 		struct org_cherry_value* v = org_cherry_env_lookup(env, value);
 
 		if(!v) {
@@ -159,18 +71,82 @@ org_cherry_eval(struct org_cherry_environment* env, struct org_cherry_value* val
 		}
 
 		return v;
-	} else if(IS_QUOTE(value)) 
+	
+    } else if(IS_QUOTE(value)) 
 		return TEXT_OF_QUOTATION(value);
-    else if(IS_DEFINE(value))
-        return org_cherry_eval_define(env, value);
-	else if(IS_BEGIN(value))
-		return org_cherry_eval_begin(env, TAIL(value));
-	else if(IS_LAMBDA(value))
+    
+    else if(IS_LET(value))
+        return org_cherry_eval_let(env, TAIL(value));
+
+    else if(IS_BEGIN(value)) {
+        value = TAIL(value);
+        while(TAIL(value) != org_cherry_emptylist) {
+            org_cherry_eval(env, HEAD(value));
+            value = TAIL(value);
+        }
+        value = HEAD(value);
+        goto tailcall;
+    }
+	
+    else if(IS_TRY(value)) {
+        org_cherry_env_push_exception_point(env);
+
+        int val = setjmp(EXCEPTION_JUMP(env));
+
+        if(val == 0){ 
+            value = org_cherry_eval(env, HEAD(TAIL(value)));
+        } else {
+            struct org_cherry_value* catch = HEAD(TAIL(TAIL(value)));
+            value = 
+                org_cherry_list_cons(catch, org_cherry_list_cons(EXCEPTION_DATA(env), org_cherry_emptylist));
+
+            org_cherry_env_pop_exception_point(env);
+            goto tailcall;
+        }
+        
+        org_cherry_env_pop_exception_point(env);
+        return value;
+	
+    } else if(IS_LAMBDA(value))
 		return org_cherry_procedure(env, HEAD(TAIL(value)), TAIL(TAIL(value)));
-	else if(IS_IF(value))
-		return org_cherry_eval_if(env, TAIL(value));
-	else if(IS_APPLICATION(value))
-		return org_cherry_apply(env, org_cherry_eval(env, HEAD(value)), org_cherry_eval_values(env, TAIL(value)));
+
+    else if(IS_IF(value)) {
+        value = IS_TRUE(org_cherry_eval(env, HEAD(TAIL(value)))) 
+                ? HEAD(TAIL(TAIL(value)))
+                : HEAD(TAIL(TAIL(TAIL(value))));
+        goto tailcall;
+
+    } else if(IS_APPLICATION(value)) {
+        proc = org_cherry_eval(env, HEAD(value));
+        args = org_cherry_eval_values(env, TAIL(value));
+
+        if(IS_PRIMITIVE(proc))
+            return (proc->fun_value)(env, args);
+        else if(IS_PROCEDURE(proc)) {
+            env = TO_PROC(proc)->env;
+            org_cherry_env_push(env);
+
+            struct org_cherry_value* params = TO_PROC(proc)->param;
+
+            if(IS_VARIABLE(params))
+                org_cherry_env_add(env, params, args);
+            else {
+                while(!IS_NULL(args)) {
+                    // check if all params are given (IS_NULL(params))
+                    org_cherry_env_add(env, HEAD(params), HEAD(args));
+
+                    params = TAIL(params);
+                    args = TAIL(args);
+                }
+            }
+
+            value = org_cherry_list_cons(org_cherry_symbol_begin, TO_PROC(proc)->body);
+            goto tailcall;
+        } else {
+			fprintf(stderr, "unknown procedure type\n");
+			exit(1);
+		}
+    }
 		
 	fprintf(stderr, "can not eval unknown expression\n");
 	exit(1);

source/read.c

@@ -688,96 +688,46 @@ org_cherry_read_pair(struct org_cherry_context* context)
 	return (struct org_cherry_value*) org_cherry_list_cons(head, tail);
 }
 
-enum BeginState {
-	CODE, EXCEPTION_VAR, EXCEPTION, FINALLY
-};
-
 static struct org_cherry_value*
-org_cherry_transform_begin(struct org_cherry_value* value)
+org_cherry_transform_try(struct org_cherry_value* value)
 {
-	struct org_cherry_value* code = 
-		org_cherry_list_cons(org_cherry_emptylist,
-				org_cherry_list_cons(org_cherry_symbol_lambda, org_cherry_emptylist));
-	
+	struct org_cherry_value* code = org_cherry_list(org_cherry_symbol_begin, 0);
 	struct org_cherry_value* handler = org_cherry_emptylist; 
-	struct org_cherry_value* finally = org_cherry_emptylist;
-
-	struct org_cherry_value* tmp = org_cherry_emptylist;
-
-	enum BeginState state = CODE;
-
-	while(!IS_NULL(value)) {
-		switch(state) {
-			case CODE:
-				if(IS_CATCH(HEAD(value))) {
-					state = EXCEPTION_VAR;
-					handler = org_cherry_list_cons(org_cherry_symbol_lambda, org_cherry_emptylist);
-					tmp = TAIL(HEAD(value));
-					continue;
-				} else if(IS_FINALLY(HEAD(value))) {
-					state = FINALLY;
-					tmp = TAIL(HEAD(value));
-					finally =  
-						org_cherry_list_cons(org_cherry_emptylist, 
-							org_cherry_list_cons(org_cherry_symbol_lambda, org_cherry_emptylist));
-					continue;
-
-				} else
-					code = org_cherry_list_cons(HEAD(value), code);
-				break;
 
-			case EXCEPTION_VAR:
-				if(IS_PAIR(HEAD(tmp))) {
-					handler = org_cherry_list_cons(HEAD(tmp), handler);
-					state = EXCEPTION;
-					tmp = TAIL(tmp);
-					continue;
-				} else {
-					handler = org_cherry_list_cons(org_cherry_list(org_cherry_symbol("e"), org_cherry_emptylist), handler);
-					state = EXCEPTION;
-					continue;
-				}
-
-			case EXCEPTION:
-				while(!IS_NULL(tmp)) {
-					handler = org_cherry_list_cons(HEAD(tmp), handler);
-					tmp = TAIL(tmp);
-				}
-
-				if(IS_FINALLY(HEAD(value))) {
-					state = FINALLY;
-					tmp = TAIL(HEAD(value));
-					finally =  
-						org_cherry_list_cons(org_cherry_emptylist, 
-							org_cherry_list_cons(org_cherry_symbol_lambda, org_cherry_emptylist));
-					continue;
-				}
-				break;
-
-			case FINALLY:
-				while(!IS_NULL(tmp)) {
-					finally = org_cherry_list_cons(HEAD(tmp), finally);
-					tmp = TAIL(tmp);
-				}
-				break;
+	while(IS_NULL(handler) && !IS_NULL(value)) {
+		if(IS_CATCH(HEAD(value)))
+			handler = org_cherry_list_cons(org_cherry_symbol_lambda, TAIL(HEAD(value)));
+		else {
+			code = org_cherry_list_cons(HEAD(value), code);
 		}
 
 		value = TAIL(value);
 	}
 
-	return 	org_cherry_list(
-			org_cherry_symbol_begin, 
-			org_cherry_list_reverse(code), 
-			org_cherry_list_reverse(handler),
-			org_cherry_list_reverse(finally));
+	return org_cherry_list(org_cherry_symbol_try, org_cherry_list_reverse(code), handler, 0);
+}
+
+
+static struct org_cherry_value*
+org_cherry_transform_define(struct org_cherry_value* value)
+{
+	struct org_cherry_value* name = HEAD(HEAD(value));
+	struct org_cherry_value* args = TAIL(HEAD(value));
+	struct org_cherry_value* body = TAIL(value);
+
+	return org_cherry_list(org_cherry_symbol_let, name,
+			org_cherry_list_cons(org_cherry_symbol_lambda,
+				org_cherry_list_cons(args, body)), 0);
 }
 
 
 static struct org_cherry_value* 
 org_cherry_transform(struct org_cherry_value* value)
 {
-	if(IS_BEGIN(value))
-		return org_cherry_transform_begin(TAIL(value));
+	if(IS_TRY(value))
+		return org_cherry_transform_try(TAIL(value));
+	else if(IS_DEFINE(value))
+		return org_cherry_transform_define(TAIL(value));
 	else
 		return value;
 }

source/value.c

@@ -33,13 +33,14 @@ struct org_cherry_value*		org_cherry_true;
 struct org_cherry_value*		org_cherry_false;
 
 struct org_cherry_value*		org_cherry_symbol_define;
+struct org_cherry_value*		org_cherry_symbol_let;
 struct org_cherry_value*		org_cherry_symbol_lambda;
 struct org_cherry_value*		org_cherry_symbol_if;
 struct org_cherry_value*		org_cherry_symbol_quote;
 
+struct org_cherry_value*		org_cherry_symbol_try;
 struct org_cherry_value*		org_cherry_symbol_begin;
 struct org_cherry_value*		org_cherry_symbol_catch;
-struct org_cherry_value*		org_cherry_symbol_finally;
 // ----------------------------------------------------------------------------
 // helper methods
 // ----------------------------------------------------------------------------
@@ -379,11 +380,12 @@ org_cherry_initialize(struct org_cherry_pair* arguments)
 
 	org_cherry_symbol_quote 	= org_cherry_symbol("quote");
 	org_cherry_symbol_define	= org_cherry_symbol("define");
+	org_cherry_symbol_let		= org_cherry_symbol("let");
 	org_cherry_symbol_lambda 	= org_cherry_symbol("lambda");
 	org_cherry_symbol_if     	= org_cherry_symbol("if");
 	org_cherry_symbol_begin   	= org_cherry_symbol("begin");
 	org_cherry_symbol_catch   	= org_cherry_symbol("catch");
-	org_cherry_symbol_finally 	= org_cherry_symbol("finally");
+	org_cherry_symbol_try 		= org_cherry_symbol("try");
 
 
 }
@@ -407,6 +409,7 @@ org_cherry_environment(void)
 	proc_to_env(env, "-", org_cherry_core_sub);
 	proc_to_env(env, "*", org_cherry_core_mul);
 	proc_to_env(env, "/", org_cherry_core_div);
+	proc_to_env(env, "exit", org_cherry_system_exit);
 
 	return env;
 }