Ejemplo n.º 1
0
int test_environment()
{
   symbol *sa = new_symbol("a");
   symbol *sb = new_symbol("b");
   symbol *sc = new_symbol("c");

   symbol *sx = new_symbol("x");
   symbol *sy = new_symbol("y");
   symbol *sz = new_symbol("z");

   symbol *sn = new_symbol("n");

   integer *i10 = new_integer(10);
   integer *i20 = new_integer(20);
   integer *i30 = new_integer(30);

   integer *i40 = new_integer(40);
   integer *i50 = new_integer(50);
   integer *i60 = new_integer(60);

   list *vara = cons(sa, cons(sb, cons(sc, NULL)));
   list *varx = cons(sx, cons(sy, cons(sz, NULL)));
   list *val10 = cons(i10, cons(i20, cons(i30, NULL)));
   list *val40 = cons(i40, cons(i50, cons(i60, NULL)));

   environment *env = NULL;

   env = extend_env(vara, val10, env);

   assert(generic_equal(lookup_var_val(sa, env), cons(sa, i10)));
   assert(generic_equal(lookup_var_val(sb, env), cons(sb, i20)));
   assert(generic_equal(lookup_var_val(sc, env), cons(sc, i30)));

   env = define_var_val(sx, i40, env);

   assert(generic_equal(lookup_var_val(sa, env), cons(sa, i10)));
   assert(generic_equal(lookup_var_val(sb, env), cons(sb, i20)));
   assert(generic_equal(lookup_var_val(sc, env), cons(sc, i30)));
   assert(generic_equal(lookup_var_val(sx, env), cons(sx, i40)));
   assert(generic_equal(lookup_var_val(sy, env), NULL));

   env = set_var_val(sx, i50, env);

   assert(generic_equal(lookup_var_val(sa, env), cons(sa, i10)));
   assert(generic_equal(lookup_var_val(sb, env), cons(sb, i20)));
   assert(generic_equal(lookup_var_val(sc, env), cons(sc, i30)));
   assert(generic_equal(lookup_var_val(sx, env), cons(sx, i50)));
   assert(generic_equal(lookup_var_val(sy, env), NULL));

   env = extend_env(varx, val40, env);
   assert(generic_equal(lookup_var_val(sa, env), cons(sa, i10)));
   assert(generic_equal(lookup_var_val(sb, env), cons(sb, i20)));
   assert(generic_equal(lookup_var_val(sc, env), cons(sc, i30)));
   assert(generic_equal(lookup_var_val(sx, env), cons(sx, i40)));
   assert(generic_equal(lookup_var_val(sy, env), cons(sy, i50)));
   assert(generic_equal(lookup_var_val(sz, env), cons(sz, i60)));
   assert(generic_equal(lookup_var_val(sn, env), NULL));

   return 1;
}
Ejemplo n.º 2
0
///////////////////////////////////////////////////////////////////
//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;
}