data_t *eval(const data_t *exp, data_t *env) {
if(eval_plz_die) {
eval_plz_die = 0;
ExitThread(0);
}
if(is_self_evaluating(exp))
return (data_t*)exp;
if(is_variable(exp))
return lookup_variable_value(exp, env);
if(is_quoted_expression(exp))
return get_text_of_quotation(exp);
if(is_assignment(exp))
return eval_assignment(exp, env);
if(is_definition(exp))
return eval_definition(exp, env);
if(is_if(exp))
return eval_if(exp, env);
if(is_lambda(exp))
return make_procedure(get_lambda_parameters(exp), get_lambda_body(exp), env);
if(is_begin(exp))
return eval_sequence(get_begin_actions(exp), env);
if(is_cond(exp))
return eval(cond_to_if(exp), env);
if(is_letrec(exp))
return eval(letrec_to_let(exp), env);
if(is_let_star(exp))
return eval(let_star_to_nested_lets(exp), env);
if(is_let(exp))
return eval(let_to_combination(exp), env);
if(is_application(exp))
return apply(
eval(get_operator(exp), env),
get_list_of_values(get_operands(exp), env));
printf("Unknown expression type -- EVAL '");
return make_symbol("error");
}
static value_t *
eppic_exeop(oper *o)
{
value_t *v=0, *v1=0, *v2=0, *v3=0, *v4=0;
int top;
srcpos_t p;
eppic_curpos(&o->pos, &p);
/* if ME (op on myself) operator, translate to normal operator
we will re-assign onto self when done */
top=getop(o->op);
if(top == ASSIGN) {
goto doop;
} else if(top == IN) {
/* the val in array[] test is valid for anything but struct/union */
v=eppic_makebtype((ull)eppic_lookuparray(P1,P2));
}
else if(is_cond(top)) {
/* the operands are eithr BASE (integer) or REF (pointer) */
/* all conditional operators accept a mixture of pointers and integer */
/* set the return as a basetype even if bool */
switch(top) {
case CEXPR: { /* conditional expression expr ? : stmt : stmt */
if(eppic_bool(V1)) {
v=eppic_cloneval(V2);
} else {
v=eppic_cloneval(V3);
}
}
break;
case BOR: { /* a || b */
v=eppic_makebtype((ull)(eppic_bool(V1) || eppic_bool(V2)));
}
break;
case BAND: { /* a && b */
v=eppic_makebtype((ull)(eppic_bool(V1) && eppic_bool(V2)));
}
break;
case NOT: { /* ! expr */
v=eppic_makebtype((ull)(! eppic_bool(V1)));
}
break;
default: {
v=eppic_docomp(top, V1, V2);
}
}
} else if(anyop(V_STRING)) {
if(top == ADD)
{
char *buf;
if(V1->type.type != V_STRING || V2->type.type != V_STRING) {
eppic_rerror(&P1->pos, "String concatenation needs two strings!");
}
buf=eppic_alloc(strlen(S1)+strlen(S2)+1);
strcpy(buf, S1);
strcat(buf, S2);
v=eppic_makestr(buf);
eppic_free(buf);
}
else {
eppic_rerror(&P1->pos, "Invalid string operator");
}
}
/* arithmetic operator */
else if(anyop(V_REF)) {
int size;
value_t *vt;
/* make sure we have the base type second */
if(V1->type.type != V_REF) { vt=V1; v1=V2; v2=vt; }
if(V1->type.type == V_BASE) {
inval:
eppic_error("Invalid operand on pointer operation");
}
/* get the size of whas we reference */
size=V1->type.size;
switch(top) {
case ADD: { /* expr + expr */
/* adding two pointers ? */
if(V2->type.type == V_REF) goto inval;
V1;
eppic_transfer(v=eppic_newval(), v1,
unival(v1) + L2 * size);
}
break;
case SUB: { /* expr - expr */
/* different results if mixed types.
if both are pointers then result is a V_BASE */
if(V2->type.type == V_REF)
v=eppic_makebtype(L1 - L2);
else {
V1;
eppic_transfer(v=eppic_newval(), v1,
unival(v1) - L2 * size);
}
}
break;
case PREDECR: { /* pre is easy */
V1;
eppic_transfer(v=eppic_newval(), v1,
unival(v1) - size);
eppic_setval(v1, v);
}
break;
case PREINCR: {
V1;
eppic_transfer(v=eppic_newval(), v1,
unival(v1) + size);
eppic_setval(v1, v);
}
break;
case POSTINCR: {
V1;
eppic_transfer(v=eppic_newval(), v1,
unival(v1) + size);
eppic_setval(v1, v);
eppic_transfer(v, v1, unival(v1));
}
break;
case POSTDECR: {
V1;
eppic_transfer(v=eppic_newval(), v1,
unival(v1) - size);
eppic_setval(v1, v);
eppic_transfer(v, v1, unival(v1));
}
break;
default:
eppic_error("Invalid operation on pointer [%d]",top);
}
}
else {
/* both operands are V_BASE */
switch(top) {
/* for mod and div, we check for divide by zero */
case MOD: case DIV:
if(!L2) {
eppic_rerror(&P1->pos, "Mod by zero");
}
case ADD: case SUB: case MUL: case XOR:
case OR: case AND: case SHL: case SHR:
{
eppic_baseop(top, V1, V2, v=eppic_newval());
}
break;
case UMINUS: {
value_t *v0=eppic_newval();
eppic_defbtype(v0, (ull)0);
/* keep original type of v1 */
v=eppic_newval();
eppic_duptype(&v0->type, &V1->type);
eppic_duptype(&v->type, &V1->type);
eppic_baseop(SUB, v0, V1, v);
eppic_freeval(v0);
/* must make result signed */
eppic_mkvsigned(v);
}
break;
case FLIP: {
value_t *v0=eppic_newval();
eppic_defbtype(v0, (ull)0xffffffffffffffffll);
/* keep original type of v1 */
eppic_duptype(&v0->type, &V1->type);
eppic_baseop(XOR, v0, V1, v=eppic_newval());
eppic_freeval(v0);
}
break;
case PREDECR: { /* pre is easy */
V1;
eppic_transfer(v=eppic_newval(), v1,
unival(v1) - 1);
eppic_setval(v1, v);
}
break;
case PREINCR: {
V1;
eppic_transfer(v=eppic_newval(), v1,
unival(v1) + 1);
eppic_setval(v1, v);
}
break;
case POSTINCR: {
V1;
eppic_transfer(v=eppic_newval(), v1,
unival(v1) + 1);
eppic_setval(v1, v);
eppic_transfer(v, v1, unival(v1));
}
break;
case POSTDECR: {
V1;
eppic_transfer(v=eppic_newval(), v1,
unival(v1) - 1);
eppic_setval(v1, v);
eppic_transfer(v, v1, unival(v1));
}
break;
default: eppic_rerror(&P1->pos, "Oops ops ! [%d]", top);
}
}
doop:
/* need to assign the value_t back to P1 */
if(top != o->op || top==ASSIGN) {
/* in the case the Lvalue_t is a variable , bypass execution and set ini */
if(P1->exe == eppic_exevar) {
char *name=NODE_NAME(P1);
var_t*va=eppic_getvarbyname(name, 0, 0);
value_t *vp;
eppic_free(name);
if(top != o->op) vp=v;
else vp=V2;
eppic_chkandconvert(va->v, vp);
eppic_freeval(v);
v=eppic_cloneval(va->v);
va->ini=1;
} else {
if(!(V1->set)) {
eppic_rerror(&P1->pos, "Not Lvalue_t on assignment");
}
else {
/* if it's a Me-op then v is already set */
V1;
if(top != o->op) {
eppic_setval(v1, v);
} else {
eppic_setval(v1, V2);
v=eppic_cloneval(V2);
}
}
}
/* the result of a assignment if not an Lvalue_t */
v->set=0;
}
eppic_freeval(v1);
eppic_freeval(v2);
eppic_freeval(v3);
eppic_freeval(v4);
eppic_setpos(&p);
return v;
}
object *eval(object *exp, object *env) {
object *procedure;
object *arguments;
object *result;
bool tailcall = false;
do {
if (is_self_evaluating(exp))
return exp;
if (is_variable(exp))
return lookup_variable_value(exp, env);
if (is_quoted(exp))
return text_of_quotation(exp);
if (is_assignment(exp))
return eval_assignment(exp, env);
if (is_definition(exp))
return eval_definition(exp, env);
if (is_if(exp)) {
exp = is_true(eval(if_predicate(exp), env)) ? if_consequent(exp) : if_alternative(exp);
tailcall = true;
continue;
}
if (is_lambda(exp))
return make_compound_proc(lambda_parameters(exp), lambda_body(exp), env);
if (is_begin(exp)) {
exp = begin_actions(exp);
while (!is_last_exp(exp)) {
eval(first_exp(exp), env);
exp = rest_exps(exp);
}
exp = first_exp(exp);
tailcall = true;
continue;
}
if (is_cond(exp)) {
exp = cond_to_if(exp);
tailcall = true;
continue;
}
if (is_let(exp)) {
exp = let_to_application(exp);
tailcall = true;
continue;
}
if (is_and(exp)) {
exp = and_tests(exp);
if (is_empty(exp))
return make_boolean(true);
while (!is_last_exp(exp)) {
result = eval(first_exp(exp), env);
if (is_false(result))
return result;
exp = rest_exps(exp);
}
exp = first_exp(exp);
tailcall = true;
continue;
}
if (is_or(exp)) {
exp = or_tests(exp);
if (is_empty(exp)) {
return make_boolean(false);
}
while (!is_last_exp(exp)) {
result = eval(first_exp(exp), env);
if (is_true(result))
return result;
exp = rest_exps(exp);
}
exp = first_exp(exp);
tailcall = true;
continue;
}
if (is_application(exp)) {
procedure = eval(operator(exp), env);
arguments = list_of_values(operands(exp), env);
if (is_primitive_proc(procedure) && procedure->data.primitive_proc.fn == eval_proc) {
exp = eval_expression(arguments);
env = eval_environment(arguments);
tailcall = true;
continue;
}
if (is_primitive_proc(procedure) && procedure->data.primitive_proc.fn == apply_proc) {
procedure = apply_operator(arguments);
arguments = apply_operands(arguments);
}
if (is_primitive_proc(procedure))
return (procedure->data.primitive_proc.fn)(arguments);
if (is_compound_proc(procedure)) {
env = extend_environment(procedure->data.compound_proc.parameters, arguments, procedure->data.compound_proc.env);
exp = make_begin(procedure->data.compound_proc.body);
tailcall = true;
continue;
}
return make_error(342, "unknown procedure type");
} // is_application()
} while (tailcall);
fprintf(stderr, "cannot eval unknown expression type\n");
exit(EXIT_FAILURE);
}
object *bs_eval(object *exp, object *env)
{
tailcall:
if (is_empty_list(exp)) {
error("unable to evaluate empty list");
} else if (is_self_evaluating(exp)) {
return exp;
} else if (is_variable(exp)) {
return lookup_variable_value(exp, env);
} else if (is_quoted(exp)) {
return quoted_expression(exp);
} else if (is_assignment(exp)) {
return eval_assignment(exp, env);
} else if (is_definition(exp)) {
return eval_definition(exp, env);
} else if (is_if(exp)) {
if (is_true(bs_eval(if_predicate(exp), env))) {
exp = if_consequent(exp);
} else {
exp = if_alternate(exp);
}
goto tailcall;
} else if (is_lambda(exp)) {
return make_compound_proc(lambda_parameters(exp),
lambda_body(exp),
env);
} else if (is_begin(exp)) {
exp = begin_actions(exp);
if (is_empty_list(exp)) {
error("empty begin block");
}
while (!is_empty_list(cdr(exp))) {
bs_eval(car(exp), env);
exp = cdr(exp);
}
exp = car(exp);
goto tailcall;
} else if (is_cond(exp)) {
exp = cond_to_if(exp);
goto tailcall;
} else if (is_let(exp)) {
exp = let_to_application(exp);
goto tailcall;
} else if (is_and(exp)) {
exp = and_tests(exp);
if (is_empty_list(exp)) {
return get_boolean(1);
}
object *result;
while (!is_empty_list(cdr(exp))) {
result = bs_eval(car(exp), env);
if (is_false(result)) {
return result;
}
exp = cdr(exp);
}
exp = car(exp);
goto tailcall;
} else if (is_or(exp)) {
exp = or_tests(exp);
if (is_empty_list(exp)) {
return get_boolean(0);
}
object *result;
while (!is_empty_list(cdr(exp))) {
result = bs_eval(car(exp), env);
if (is_true(result)) {
return result;
}
exp = cdr(exp);
}
exp = car(exp);
goto tailcall;
} else if (is_application(exp)) {
object *procedure = bs_eval(application_operator(exp), env);
object *parameters = eval_parameters(application_operands(exp), env);
// handle eval specially for tailcall requirement.
if (is_primitive_proc(procedure) &&
procedure->value.primitive_proc == eval_proc) {
exp = eval_expression(parameters);
env = eval_environment(parameters);
goto tailcall;
}
// handle apply specially for tailcall requirement.
if (is_primitive_proc(procedure) &&
procedure->value.primitive_proc == apply_proc) {
procedure = apply_operator(parameters);
parameters = apply_operands(parameters);
}
if (is_primitive_proc(procedure)) {
return (procedure->value.primitive_proc)(parameters);
} else if (is_compound_proc(procedure)) {
env = extend_environment(
procedure->value.compound_proc.parameters,
parameters,
procedure->value.compound_proc.env);
exp = make_begin(procedure->value.compound_proc.body);
goto tailcall;
} else {
error("unable to apply unknown procedure type");
}
} else {
error("unable to evaluate expression");
}
}
static pSlipObject slip_eval(pSlip gd, pSlipObject exp, pSlipEnvironment env)
{
pSlipObject proc;
pSlipObject args;
tailcall:
if (is_self_evaluating(exp) == S_TRUE)
{
return exp;
}
else if (is_variable(exp) == S_TRUE)
{
return lookup_variable_value(gd, exp, env);
}
else if (is_quoted(gd, exp) == S_TRUE)
{
return text_of_quotation(exp);
}
else if (is_assignment(gd, exp) == S_TRUE)
{
return eval_assignment(gd, exp, env);
}
else if (is_definition(gd, exp) == S_TRUE)
{
return eval_definition(gd, exp, env);
}
else if (is_if(gd, exp) == S_TRUE)
{
exp = is_true(gd, slip_eval(gd, if_predicate(exp), env)) == S_TRUE ? if_consequent(exp) : if_alternative(gd, exp);
goto tailcall;
}
else if (is_lambda(gd, exp) == S_TRUE)
{
return s_NewCompoundProc(gd, lambda_parameters(exp), lambda_body(exp), env);
}
else if (is_begin(gd, exp) == S_TRUE)
{
exp = begin_actions(exp);
while (!is_last_exp(gd, exp))
{
slip_eval(gd, first_exp(exp), env);
exp = rest_exps(exp);
}
exp = first_exp(exp);
goto tailcall;
}
else if (is_cond(gd, exp) == S_TRUE)
{
exp = cond_to_if(gd, exp);
goto tailcall;
}
else if (is_let(gd, exp) == S_TRUE)
{
exp = let_to_application(gd, exp);
goto tailcall;
}
else if (is_application(exp) == S_TRUE)
{
proc = slip_eval(gd, slip_operator(exp), env);
if (proc == NULL)
return gd->singleton_False;
if (proc->type == eType_PRIMITIVE_PROC || proc->type == eType_COMPOUND_PROC)
{
args = list_of_values(gd, operands(exp), env);
if (args == NULL)
return gd->singleton_False;
if (sIsObject_PrimitiveProc(proc) == S_TRUE)
{
return proc->data.prim_proc.func(gd, args);
}
else if (sIsObject_CompoundProc(proc) == S_TRUE)
{
env = setup_environment(gd, proc->data.comp_proc.env, proc->data.comp_proc.params, args);
exp = make_begin(gd, proc->data.comp_proc.code);
goto tailcall;
}
else
{
throw_error(gd, "unknown procedure type\n");
return gd->singleton_False;
}
}
else
return proc;
}
else
{
throw_error(gd, "cannot eval unknown expression type\n");
return NULL;
}
throw_error(gd, "what??\n");
return NULL;
}
///////////////////////////////////////////////////////////////////
//eval
//requires two arguments:exp & tail_context
///////////////////////////////////////////////////////////////////
cellpoint eval(void)
{
if (is_true(is_self_evaluating(args_ref(1)))){
reg = args_ref(1);
}else if (is_true(is_variable(args_ref(1)))){
reg = args_ref(1);
args_push(current_env);
args_push(reg);
reg = lookup_var_val();
}else if (is_true(is_quoted(args_ref(1)))){
args_push(args_ref(1));
reg = quotation_text();
}else if (is_true(is_assignment(args_ref(1)))){
args_push(args_ref(1));
reg = eval_assignment();
}else if (is_true(is_definition(args_ref(1)))){
args_push(args_ref(1));
reg = eval_definition();
}else if (is_true(is_if(args_ref(1)))){
//eval if expression with the second argument (tail_context)
reg = args_ref(1);
args_push(args_ref(2));
args_push(reg);
reg = eval_if();
}else if (is_true(is_lambda(args_ref(1)))){
args_push(args_ref(1));
reg = eval_lambda();
}else if (is_true(is_begin(args_ref(1)))){
args_push(args_ref(1));
reg = begin_actions();
//eval the actions of begin exp with the second argument (tail_context)
args_push(args_ref(2));
args_push(reg);
reg = eval_sequence();
}else if (is_true(is_cond(args_ref(1)))){
args_push(args_ref(1));
reg = cond_2_if();
//eval the exp with the second argument (tail_context)
args_push(args_ref(2));
args_push(reg);
reg = eval();
}else if (is_true(is_and(args_ref(1)))){
reg = args_ref(1);
args_push(args_ref(2));
args_push(reg);
reg = eval_and();
}else if (is_true(is_or(args_ref(1)))){
reg = args_ref(1);
args_push(args_ref(2));
args_push(reg);
reg = eval_or();
}else if (is_true(is_let(args_ref(1)))){
//convert let to combination
args_push(args_ref(1));
reg = let_2_combination();
//evals the combination
args_push(args_ref(2));
args_push(reg);
reg = eval();
}else if (is_true(is_letstar(args_ref(1)))){
//convert let* to nested lets
args_push(args_ref(1));
reg = letstar_2_nested_lets();
//evals the nested lets
args_push(args_ref(2));
args_push(reg);
reg = eval();
}else if (is_true(is_application(args_ref(1)))){
//computes operator
args_push(args_ref(1));
reg = operator();
args_push(a_false);
args_push(reg);
reg = eval();
stack_push(&vars_stack, reg);
//computes operands
args_push(args_ref(1));
reg = operands();
args_push(reg);
reg = list_of_values();
//calls apply with the second argument (tail_context)
args_push(args_ref(2));
args_push(reg);
args_push(stack_pop(&vars_stack));
reg = apply();
}else {
printf("Unknown expression type -- EVAL\n");
error_handler();
}
args_pop(2);
return reg;
}
