static constexpr auto apply(Id self, P p, F f) {
auto x = eval_if(p(self.value),
[=](auto _) { return _(f)(self.value); },
[=](auto _) { return self.value; }
);
return test::identity(x);
}
static char *iftag_elif (int argc, char *argv[])
{
char *new_argv[MAX_ARGS];
int c;
/* process all arguments */
for (c = 0; c < argc; c++)
new_argv[c] = process_text (argv[c]);
/* evaluate the expression */
if (eval_if (argc, new_argv)) {
/* for a true expression: if we not yet pass for any if-block */
if (token[0] == TOK_IF_NOTYET)
/* enter in this block */
token[0] = TOK_IF_INSIDE;
/* else, we must jump this block */
else
token[0] = TOK_IF_OUTSIDE;
}
else {
/* the evaluation give false: if we are inside in previous if-block */
if (token[0] == TOK_IF_INSIDE)
/* now we need to jump all to the next `fi' (end of the if-block) */
token[0] = TOK_IF_OUTSIDE;
}
/* update parser state */
update_state ();
/* free all arguments */
for (c = 0; c < argc; c++)
free (new_argv[c]);
/* nothing to add */
return NULL;
}
Value *eval(Value *form, Value *env)
{
switch (gettype(form)) {
case T_INT: return form;
case T_SYM:
{
Value *value = lookup(form, env);
if (value == NULL) {
error("Undefined symbol.");
exit(1);
}
return value;
} break;
case T_PAIR:
{
Value *verb = CAR(form);
if (verb == quote_sym) {
return CADR(form);
} else if (verb == lambda_sym) {
return eval_lambda(form, env);
} else if (verb == if_sym) {
return eval_if(form, env);
} else if (verb == define_sym) {
return eval_define(form, env);
} else {
return apply(eval(verb, env), mapeval(CDR(form), env));
}
} break;
default:
error("I don't know how to evaluate that.");
break;
}
}
static constexpr auto apply(Id self, P p, F f) {
auto x = eval_if(p(self.value),
make_lazy(compose(f, get_value{}))(self),
make_lazy(get_value{})(self)
);
return test::identity(x);
}
static void tr_if(char **args)
{
int c = eval_if(cp_next, cp_back);
if (args[0][1] == 'i' && args[0][2] == 'e') /* .ie command */
if (ie_depth < NIES)
ie_cond[ie_depth++] = c;
cp_blk(!c);
}
static constexpr auto apply(M1 const& m1, M2 const& m2) {
return eval_if(bool_<R1 == R2 && C1 == C2>,
[&](auto _) {
return all(zip_with(_(equal), cppcon::rows(m1),
cppcon::rows(m2)));
},
[] { return false_; }
);
}
// Compute the multi-step evaluation of the term t.
Term*
eval(Term* t) {
switch (t->kind) {
case if_term: return eval_if(as<If>(t));
case succ_term: return eval_succ(as<Succ>(t));
case pred_term: return eval_pred(as<Pred>(t));
case iszero_term: return eval_iszero(as<Iszero>(t));
case app_term: return eval_app(as<App>(t));
case call_term: return eval_call(as<Call>(t));
case ref_term: return eval_ref(as<Ref>(t));
case print_term: return eval_print(as<Print>(t));
case def_term: return eval_def(as<Def>(t));
case prog_term: return eval_prog(as<Prog>(t));
case comma_term: return eval_comma(as<Comma>(t));
default: break;
}
return t;
}
T eval(T form, Environment env) {
T o;
switch(gettype(form)) {
case T_INT:
case T_STR:
return form;
case T_SYM:
o = lookup(form, env);
if (NILP(o)) {
error("Undefined symbol");
exit(1);
}
return o;
case T_CELL:
o = CAR(form);
/* (quote (1 2 3 4)) */
if (o == sym_quote) {
return CADR(form);
/* (lambda () (..)) */
} else if (o == sym_lambda) {
return eval_lambda(form, env);
/* (if () (then) (else)) */
} else if (o == sym_if) {
return eval_if(form, env);
/* (defun foo () (...)) */
} else if (o == sym_defun) {
return eval_defun(form, env);
} else {
return apply(eval(o, env), mapeval(CDR(form), env));
}
default:
error("I have no idea how to eval that.");
break;
}
return NIL;
}
namespace boost { namespace hana { namespace test {
template <typename F>
auto laws<Functor, F> = [] {
static_assert(models<Functor(F)>{}, "");
auto f = injection([]{});
auto g = injection([]{});
auto v = injection([]{})();
auto pred = always(true_);
for_each(objects<F>, [=](auto xs) {
BOOST_HANA_CHECK(
equal(transform(xs, id), xs)
);
BOOST_HANA_CHECK(equal(
transform(xs, compose(f, g)),
transform(transform(xs, g), f)
));
BOOST_HANA_CHECK(equal(
adjust(xs, pred, f),
transform(xs, [=](auto x) {
return eval_if(pred(x),
[=](auto _) { return _(f)(x); },
[=](auto) { return x; }
);
})
));
BOOST_HANA_CHECK(equal(
replace(xs, pred, v),
adjust(xs, pred, always(v))
));
BOOST_HANA_CHECK(equal(
fill(xs, v),
replace(xs, always(true_), v)
));
});
};
}}} // end namespace boost::hana::test
static char *iftag_if (int argc, char *argv[])
{
char *new_argv[MAX_ARGS];
int c;
/* process all arguments */
for (c = 0; c < argc; c++)
new_argv[c] = process_text (argv[c]);
/* evaluate the expression */
if (eval_if (argc, new_argv))
/* for a true expression: we are now inside the if-block */
new_token (TOK_IF_INSIDE);
else
/* the evaluation give false: don't enter in this if-block */
new_token (TOK_IF_NOTYET);
/* update parser state */
update_state ();
/* free all arguments */
for (c = 0; c < argc; c++)
free (new_argv[c]);
/* nothing to add */
return NULL;
}
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");
}
//TODO check number of arguments given to builtins
object_t *eval(object_t *exp, object_t *env) {
char comeback = 1;
while(comeback) {
comeback = 0;
if(is_self_evaluating(exp)) {
return exp;
}
if(list_begins_with(exp, quote_symbol)) {
return cadr(exp);
}
// (define... )
if(list_begins_with(exp, define_symbol)) {
object_t *var = cadr(exp);
// (define a b)
if(issymbol(var)) {
object_t *val = caddr(exp);
return define_var(env, var, val);
}
// (define (a ...) ...) TODO use scheme macro
if(ispair(var)) {
object_t *name = car(cadr(exp)),
*formals = cdr(cadr(exp)),
*body = cddr(exp),
*lambda = cons(lambda_symbol,
cons(formals, body));
exp = cons(define_symbol,
cons(name, cons(lambda, empty_list)));
comeback = 1;
continue;
}
fprintf(stderr, "Syntax error.\n");
exit(-1);
}
// (set! a b)
if(list_begins_with(exp, set_symbol)) {
object_t *var = cadr(exp);
object_t *val = caddr(exp);
return set_var(env, var, val);
}
// (if c a b)
if(list_begins_with(exp, if_symbol)) {
exp = eval_if(env, cadr(exp), caddr(exp), cadddr(exp));
comeback = 1;
continue;
}
// (cond ...)
if(list_begins_with(exp, cond_symbol)) {
object_t *tail = cons(void_symbol, empty_list);
object_t *ifs = tail; //empty_list;
object_t *rules = reverse_list(cdr(exp));
while(!isemptylist(rules)) {
object_t *rule = car(rules),
*condition = car(rule),
*consequence = cadr(rule);
if(isemptylist(consequence)) {
consequence = cons(void_obj, empty_list);
}
ifs = cons(if_symbol,
cons(condition,
cons(consequence,
cons(ifs, empty_list))));
rules = cdr(rules);
}
exp = ifs;
comeback = 1;
continue;
}
// (begin ...)
if(list_begins_with(exp, begin_symbol)) {
object_t *result = empty_list, *exps;
for(exps = cdr(exp); ! isemptylist(exps); exps = cdr(exps)) {
result = eval(car(exps), env);
}
return result;
}
if(list_begins_with(exp, lambda_symbol)) {
object_t *fn = cons(begin_symbol,
cdr(cdr(exp)));
return make_compound_proc(empty_list, cadr(exp),
fn,
env);
}
// (let ...)
if(list_begins_with(exp, let_symbol)) {
//if(! issymbol(cadr(exp)))
object_t *bindings = cadr(exp);
object_t *body = cddr(exp);
object_t *formals = empty_list;
object_t *values = empty_list;
while(!isemptylist(bindings)) {
formals = cons(caar(bindings), formals);
values = cons(cadr(car(bindings)), values);
bindings = cdr(bindings);
}
exp = cons(cons(lambda_symbol, cons(formals, body)),
values);
comeback = 1;
continue;
}
if(issymbol(exp)) {
return var_get_value(env, exp);
}
if(ispair(exp)) {
object_t *exp_car = car(exp);
object_t *fn = eval(exp_car, env); //var_get_value(env, car);
if(!iscallable(fn)) {
fprintf(stderr, "object_t is not callable\n");
exit(-1);
}
object_t *args = cdr(exp);
object_t *evaluated_args = evaluate_list(env, args, empty_list);
if(isprimitiveproc(fn)) {
return fn->value.prim_proc.fn(evaluated_args);
} else if(iscompoundproc(fn)) {
object_t *fn_formals = fn->value.compound_proc.formals;
object_t *fn_body = fn->value.compound_proc.body;
object_t *fn_env = fn->value.compound_proc.env;
ARGS_EQ(evaluated_args, list_size(fn_formals));
exp = fn_body;
env = extend_environment(fn_formals, evaluated_args, fn_env);
comeback = 1;
continue;
}
assert(0);
}
}
fprintf(stderr, "Unable to evaluate expression: \n");
write(exp);
exit(-1);
}
static void
eval_expr(m1_expression *e) {
if (e == NULL)
return;
switch (e->type) {
case EXPR_NUMBER:
eval_number(e->expr.l->value.fval);
break;
case EXPR_INT:
eval_int(e->expr.l->value.ival);
break;
case EXPR_BINARY:
eval_binary(e->expr.b);
break;
case EXPR_UNARY:
eval_unary(e->expr.u);
break;
case EXPR_FUNCALL:
eval_funcall(e->expr.f);
break;
case EXPR_ASSIGN:
eval_assign(e->expr.a);
break;
case EXPR_IF:
eval_if(e->expr.i);
break;
case EXPR_WHILE:
eval_while(e->expr.w);
break;
case EXPR_DOWHILE:
eval_dowhile(e->expr.w);
break;
case EXPR_FOR:
eval_for(e->expr.o);
break;
case EXPR_RETURN:
eval_return(e->expr.e);
break;
case EXPR_NULL:
eval_null();
break;
case EXPR_DEREF:
eval_deref(e->expr.t);
break;
case EXPR_ADDRESS:
eval_address(e->expr.t);
break;
case EXPR_OBJECT:
eval_obj(e->expr.t);
break;
case EXPR_BREAK:
eval_break();
break;
case EXPR_CONTINUE:
eval_continue();
break;
case EXPR_CONSTDECL:
case EXPR_VARDECL:
break;
default:
fprintf(stderr, "unknown expr type");
exit(EXIT_FAILURE);
}
}
bool eval(string express) {
filter_useless_char(express);
trim(express);
if (check_string("{",express.c_str()) && INVALID_VALUE!=express.find('}')) { // inside code block ..
for (unsigned long code_block_end_index=get_matching_outside_right_brace(express.substr(1),0),
code_block_start_index=express.find('{');
INVALID_VALUE!=code_block_start_index && INVALID_VALUE!=code_block_end_index;
code_block_end_index=get_matching_outside_right_brace(express.substr(1),0),
code_block_start_index=express.find('{')) {
string code_block(express.substr(code_block_start_index+1,code_block_end_index-code_block_start_index));
while (INVALID_VALUE!=code_block.find(';')) {
if (!eval(code_block.substr(0,code_block.find(';'))))
return false;
code_block=code_block.substr(code_block.find(';')+1);
}
if (!code_block_start_index)
break;
express=express.substr(0,code_block_start_index-1)+express.substr(code_block_end_index+1);
}
return true;
}
bool base_javascript_syntax_execute_result=true;
if (check_string("for",express.c_str())) { // base JavaScript syntax ..
base_javascript_syntax_execute_result=eval_for(express);
} else if (check_string("if",express.c_str())) {
base_javascript_syntax_execute_result=eval_if(express);
}
if (check_string("function",express.c_str())) {
base_javascript_syntax_execute_result=eval_decleare_function(express);
if (base_javascript_syntax_execute_result)
return eval(express);
} else if (check_string("return",express.c_str())) {
return eval_function_return(express);
}
string next_express;
if (INVALID_VALUE!=express.find(';')) { // put data ..
next_express=express.substr(express.find(';')+1);
express=express.substr(0,express.find(';'));
}
if (eval_function(express)) {
} else if (INVALID_VALUE!=express.find('=')) { // var asd=123 or var4='asd'
char calcu_flag=express[express.find('=')-1];
if ('+'==calcu_flag) {
if (INVALID_VALUE!=express.find("+=")) { // asd+=123 -> asd=asd+123
string variant_name(express.substr(0,express.find("+=")));
trim(variant_name);
if (!eval(variant_name+"="+variant_name+"+"+express.substr(express.find("+=")+2)))
return false;
}
} else if ('-'==calcu_flag) {
if (INVALID_VALUE!=express.find("-=")) { // asd+=123 -> asd=asd+123
string variant_name(express.substr(0,express.find("-=")));
trim(variant_name);
if (!eval(variant_name+"="+variant_name+"-"+express.substr(express.find("-=")+2)))
return false;
}
} else if ('*'==calcu_flag) {
if (INVALID_VALUE!=express.find("*=")) { // asd+=123 -> asd=asd+123
string variant_name(express.substr(0,express.find("*=")));
trim(variant_name);
if (!eval(variant_name+"="+variant_name+"*"+express.substr(express.find("*=")+2)))
return false;
}
} else if ('/'==calcu_flag) {
if (INVALID_VALUE!=express.find("/=")) { // asd+=123 -> asd=asd+123
string variant_name(express.substr(0,express.find("/=")));
trim(variant_name);
if (!eval(variant_name+"="+variant_name+"/"+express.substr(express.find("/=")+2)))
return false;
}
} else {
string variant_name; // asd
string calcu_express;
if (check_string("var",express.c_str())) {
if (INVALID_VALUE!=express.find('=')) {
variant_name=express.substr(3,express.find('=')-3);
calcu_express=express.substr(express.find('=')+1);
} else {
variant_name=express.substr(3,express.find(';')-3);
}
} else {
if (INVALID_VALUE!=express.find('=')) {
variant_name=express.substr(0,express.find('='));
calcu_express=express.substr(express.find('=')+1);
} else {
variant_name=express.substr(3,express.find(';')-3);
}
}
trim(variant_name);
if (!calcu_express.empty())
if (!express_calcu(calcu_express))
return false;
if (EXPRESSION_ARRAY==get_express_type(variant_name)) {
unsigned long calcu_result=0;
support_javascript_variant_type calcu_result_type=NONE;
get_variant(JAVASCRIPT_VARIANT_KEYNAME_CALCULATION_RESULT,(void*)&calcu_result,&calcu_result_type);
string array_index_express(variant_name.substr(variant_name.find('[')+1,variant_name.find(']')-variant_name.find('[')-1));
if (!express_calcu(array_index_express))
return false;
unsigned long array_index=0;
support_javascript_variant_type array_index_type=NONE;
get_variant(JAVASCRIPT_VARIANT_KEYNAME_CALCULATION_RESULT,(void*)&array_index,&array_index_type);
variant_name=variant_name.substr(0,variant_name.find('['));
trim(variant_name);
if (INT_ARRAY==get_variant_type(variant_name) && NUMBER!=calcu_result_type)
return false;
set_variant_array(variant_name,array_index,(void*)calcu_result,calcu_result_type);
} else {
copy_variant(variant_name,JAVASCRIPT_VARIANT_KEYNAME_CALCULATION_RESULT);
}
}
}
if (!next_express.empty())
return eval(next_express);
return base_javascript_syntax_execute_result;
}
///////////////////////////////////////////////////////////////////
//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;
}