/* evaluators */
sexp eval_begin(sexp actions, sexp env) {
if (is_null(actions)) return EOL;
while (!is_null(pair_cdr(actions))) {
eval_object(pair_car(actions), env);
actions = pair_cdr(actions);
}
return eval_object(pair_car(actions), env);
}
sexp eval_arguments(sexp arguments, sexp env) {
if (is_null(arguments)) return EOL;
else {
sexp first = pair_car(arguments);
return make_pair(eval_object(first, env),
eval_arguments(pair_cdr(arguments), env));
}
}
int
main(int argc, char **argv)
{
krb5_error_code ret;
int optidx = 0;
setprogname(argv[0]);
ret = krb5_init_context(&kdc_context);
if (ret == KRB5_CONFIG_BADFORMAT)
errx (1, "krb5_init_context failed to parse configuration file");
else if (ret)
errx (1, "krb5_init_context failed: %d", ret);
ret = krb5_kt_register(kdc_context, &hdb_kt_ops);
if (ret)
errx (1, "krb5_kt_register(HDB) failed: %d", ret);
kdc_config = configure(kdc_context, argc, argv, &optidx);
argc -= optidx;
argv += optidx;
if (argc == 0)
errx(1, "missing operations");
krb5_plugin_register(kdc_context, PLUGIN_TYPE_DATA,
KRB5_PLUGIN_SEND_TO_KDC, &send_to_kdc);
{
void *buf;
size_t size;
heim_object_t o;
if (rk_undumpdata(argv[0], &buf, &size))
errx(1, "undumpdata: %s", argv[0]);
o = heim_json_create_with_bytes(buf, size, 10, 0, NULL);
free(buf);
if (o == NULL)
errx(1, "heim_json");
/*
* do the work here
*/
eval_object(o);
heim_release(o);
}
krb5_free_context(kdc_context);
return 0;
}
int main(int argc, char *argv[])
{
char *cases[] = {
/* "(+. 1.1 1.2)", */
/* "(integer->float 123)", */
/* "(& 5 7)", */
/* "'hello", */
/* "-", */
/* "(define a (string->in-port \"abc\"))", */
/* "(read-string-in-port-char a)", */
/* "(+i 1 2)", */
/* "(*i 3 4)", */
/* "(quotient 10 3)", */
/* "(remainder 10 3)", */
/* "(= 1 2)", */
/* "(> 4 5)", */
/* "(& 5 7)", */
/* "(| 5 7)", */
/* "(~ 5)", */
/* "(eq? 'hello 'hello)", */
/* "(eq? 1 1)", */
/* "(eq? (string->symbol \"hello\") 'hello)", */
/* "(type-of 'hello)", */
/* "type-of", */
/* "#\\a", */
/* "(type-of #\\a)", */
/* "(define a #(1 2 3))", */
/* "#\\汉", */
/* "(set! a 123)", */
"(string-ref \"汉字\" 0)",
};
init_impl();
/* printf("Address of `-': %p\n", &primitive_procs[1]); */
for (int i = 0; i < sizeof(cases) / sizeof(char *); i++) {
FILE *stream = fmemopen(cases[i], strlen(cases[i]), "r");
sexp in_port = make_file_in_port(stream);
/* inc_ref_count(in_port); */
printf(">> %s\n=> ", cases[i]);
sexp value = read_object(in_port);
if (is_eof(value))
break;
/* inc_ref_count(input); */
value = eval_object(value, repl_environment);
/* if (!is_self_eval(input)) */
/* inc_ref_count(value); */
write_object(value, scm_out_port);
putchar('\n');
}
/* write_object(make_wstring("汉"), scm_out_port); */
/* trigger_gc(); */
return 0;
}
sexp eval_application(sexp operator, sexp operands) {
if (is_primitive(operator))
return (primitive_C_proc(operator))(operands);
if (is_compound(operator)) {
sexp body = compound_proc_body(operator);
sexp vars = compound_proc_parameters(operator);
sexp def_env = compound_proc_environment(operator);
sexp object = make_pair(S("begin"), body);
sexp env = extend_environment(vars, operands, def_env);
return eval_object(object, env);
}
fprintf(stderr, "Unknown operator type %d\n", operator->type);
exit(1);
}
static void
eval_repeat(heim_dict_t o)
{
heim_object_t or = heim_dict_get_value(o, HSTR("value"));
heim_number_t n = heim_dict_get_value(o, HSTR("num"));
int i, num;
struct perf perf;
perf_start(&perf);
heim_assert(or != NULL, "value missing");
heim_assert(n != NULL, "num missing");
num = heim_number_get_int(n);
heim_assert(num >= 0, "num >= 0");
for (i = 0; i < num; i++)
eval_object(or);
perf_stop(&perf);
}
static void
eval_array_element(heim_object_t o, void *ptr, int *stop)
{
eval_object(o);
}
sexp eval_object(sexp object, sexp environment) {
tail_loop:
if (is_quote_form(object)) return quotation_text(object);
if (is_variable_form(object))
return get_variable_value(object, environment);
if (is_define_form(object)) {
/* sexp value = eval_object(definition_value(object), environment); */
/* add_binding(definition_variable(object), value, environment); */
/* return value; */
return eval_object(define2set(object), environment);
}
if (is_assignment_form(object)) {
sexp value = eval_object(assignment_value(object), environment);
set_binding(assignment_variable(object), value, environment);
return value;
}
if (is_if_form(object)) {
sexp test_part = if_test_part(object);
sexp then_part = if_then_part(object);
sexp else_part = if_else_part(object);
if (!is_false(eval_object(test_part, environment))) {
object = then_part;
} else {
object = else_part;
}
goto tail_loop;
}
if (is_lambda_form(object)) {
sexp parameters = lambda_parameters(object);
sexp body = lambda_body(object);
return make_lambda_procedure(parameters, body, environment);
}
if (is_begin_form(object)) {
return eval_begin(object, environment);
}
if (is_cond_form(object)) {
object = cond2if(object);
goto tail_loop;
}
if (is_let_form(object)) {
object = let2lambda(object);
goto tail_loop;
}
if (is_and_form(object)) {
sexp tests = and_tests(object);
if (is_null(tests))
return make_true();
while (is_pair(pair_cdr(tests))) {
sexp result = eval_object(pair_car(tests), environment);
if (is_false(result))
return make_false();
tests = pair_cdr(tests);
}
return eval_object(pair_car(tests), environment);
}
if (is_or_form(object)) {
sexp tests = or_tests(object);
if (is_null(tests))
return make_false();
while (is_pair(pair_cdr(tests))) {
sexp result = eval_object(pair_car(tests), environment);
if (!is_false(result))
return result;
tests = pair_cdr(tests);
}
return eval_object(pair_car(tests), environment);
}
if (is_macro_form(object)) {
sexp pars = macro_parameters(object);
sexp body = macro_body(object);
return make_macro_procedure(pars, body, environment);
}
if (is_application_form(object)) {
sexp operator = application_operator(object);
sexp operands = application_operands(object);
operator = eval_object(operator, environment);
if (!is_function(operator) && !is_macro(operator)) {
fprintf(stderr, "Illegal functional object ");
write_object(operator, make_file_out_port(stderr));
fprintf(stderr, " from ");
write_object(pair_car(object), make_file_out_port(stderr));
fputc('\n', stderr);
exit(1);
}
/* Expand the macro before evaluating arguments */
if (is_macro(operator)) {
sexp body = macro_proc_body(operator);
sexp vars = macro_proc_pars(operator);
sexp def_env = macro_proc_env(operator);
sexp object = make_pair(S("begin"), body);
sexp env = extend_environment(vars, operands, def_env);
sexp exp = eval_object(object, env);
return eval_object(exp, environment);
}
operands = eval_arguments(operands, environment);
/* if (is_apply(operator)) { */
/* operator = pair_car(operands); */
/* operands = apply_operands_conc(pair_cdr(operands)); */
/* } */
if (is_eval(operator)) {
environment = pair_cadr(operands);
object = pair_car(operands);
goto tail_loop;
}
return eval_application(operator, operands);
} else return object;
}
