object *is_eq_proc(object *arguments) {
object *obj1;
object *obj2;
obj1 = car(arguments);
obj2 = cadr(arguments);
if (obj1->type != obj2->type)
return make_boolean(false);
//TODO: Should eq? recurse so that, for example, (eq? (cons 3 4) (cons 3 4)) returns true? Use eval? eval + write?
switch (obj1->type) {
case FIXNUM:
return make_boolean(obj1->data.fixnum.value == obj2->data.fixnum.value);
break;
case CHARACTER:
return make_boolean(obj1->data.character.value == obj2->data.character.value);
break;
case STRING:
return make_boolean(strcmp(obj1->data.string.value, obj2->data.string.value) == 0);
break;
default:
return make_boolean(obj1 == obj2);
}
}
object *is_number_equal_proc(object *arguments) {
long value;
value = (car(arguments))->data.fixnum.value;
while (!is_empty(arguments = cdr(arguments)))
if (value != ((car(arguments))->data.fixnum.value))
return make_boolean(false);
return make_boolean(true);
}
/*
* Initialise the parser.
*/
extern void parse_init(void)
{
name_t entry;
entry = name_lookup("false");
entry->val = term_boolean(make_boolean(false));
entry = name_lookup("inf");
entry->val = term_num(make_num(1.0/0.0));
entry = name_lookup("nil");
entry->val = term_nil(make_nil());
entry = name_lookup("true");
entry->val = term_boolean(make_boolean(true));
}
object *is_greater_than_proc(object *arguments) {
long previous;
long next;
previous = (car(arguments))->data.fixnum.value;
while (!is_empty(arguments = cdr(arguments))) {
next = (car(arguments))->data.fixnum.value;
if (previous > next) {
previous = next;
} else {
return make_boolean(false);
}
}
return make_boolean(true);
}
static void do_state_sharp(char *ibuf, char **pscan)
{
if (**pscan == 'd'){
//only deal with decimal
current_state = STATE_NUM;
++*pscan;
} else if (**pscan == '\\'){
current_state = STATE_CHAR;
++*pscan;
} else if (**pscan == '('){
parse_vector(ibuf, pscan);
} else if (**pscan == 't' || **pscan == 'f'){
boolean b = (**pscan == 't') ? true : false;
++*pscan;
if (is_delimiter(**pscan) || **pscan == '\0'){
stack_push(&parser_stack, make_boolean(b));
current_state = stack_pop(&state_stack);
}else {
printf("Error: illegally uses '#' -- READ\n");
do_input_error(pscan);
}
} else{
printf("Error: illegally uses '#' -- READ\n");
do_input_error(pscan);
}
}
END_TEST
START_TEST (test_pair_ops)
{
make_singletons();
object *o1 = cons (make_string ("testing"), make_boolean (true));
object *o2 = cons (make_character ('a'), make_fixnum (5));
object *o3 = cons (o1, o2);
ck_assert (o3->type == PAIR);
ck_assert (car(o3)->type == PAIR);
ck_assert_str_eq (caar(o3)->data.string.value, "testing");
ck_assert ((cdar(o3))->type == BOOLEAN);
}
static obj_t *expand(obj_t *expr, env_t *env)
{
PUSH_ROOT(expr);
PUSH_ROOT(env);
AUTO_ROOT(proc, expander());
AUTO_ROOT(args, make_pair(env, NIL));
args = make_pair(expr, args);
//printf_unchecked("proc = %O\n", proc);
//printf_unchecked("args = %O\n", args);
FRAME = NIL;
FRAME = MAKE_CALL(b_eval, make_boolean(false), env);
apply_procedure(proc, args);
POP_FUNCTION_ROOTS();
return eval_frame(FRAME);
}
object *is_integer_proc(object *arguments) {
return make_boolean(is_fixnum(car(arguments)));
}
object *is_symbol_proc(object *arguments) {
return make_boolean(is_symbol(car(arguments)));
}
object *is_null_proc(object *arguments) {
return make_boolean(is_empty(car(arguments)));
}
object *is_pair_proc(object *arguments) {
return make_boolean(is_pair(car(arguments)));
}
object *is_procedure_proc(object *arguments) {
object *obj;
obj = car(arguments);
return make_boolean((is_primitive_proc(obj) || is_compound_proc(obj)));
}
object *is_string_proc(object *arguments) {
return make_boolean(is_string(car(arguments)));
}
object *is_char_proc(object *arguments) {
return make_boolean(is_character(car(arguments)));
}
object *is_output_port_proc(object *arguments) {
return make_boolean(is_output_port(car(arguments)));
}
object *if_alternative(object *exp) {
return is_empty(cdddr(exp)) ? make_boolean(false) : cadddr(exp);
}
object *is_eof_object_proc(object *arguments) {
return make_boolean(is_eof_object(car(arguments)));
}
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 *is_real_proc(object *arguments) {
return make_boolean(is_floatnum(car(arguments)));
}
