Commit 04936952 authored by Chris Müller's avatar Chris Müller
Browse files

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.
parent 2deac920
......@@ -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)
......
......@@ -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);
}
......
......@@ -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);
......
......@@ -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;
}
......
......@@ -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;
}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment