List arr2list(int *arr, int len)
{
List ls = make_nil();
for (int i = 0; i < len; i++)
ls = list_append(ls, arr[i]);
return ls;
}
list map(int (*pf)(int), const list p)
{
list ls = make_nil();
for (node *q = p; q != NULL; q = q->next) {
list_append(&ls, (*pf)(q->val));
}
return ls;
}
ExprPtr Cell::cdr()
{
if (is_nil()) {
return make_nil();
}
return m_cdr;
}
list filter(bool (*pf)(int), const list p)
{
list ls = make_nil();
for (node *q = p; q != NULL; q = q->next) {
if ((*pf)(q->val))
list_append(&ls, q->val);
}
return ls;
}
list list_copy(const list p)
{
list ls = make_nil();
for (node *q = p; q != NULL; q = q->next) {
node *pnew = copy_node(q);
append_node(&ls, pnew);
}
return ls;
}
/*
* 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));
}
list make_list(int len, ...)
{
list ls = make_nil();
va_list ip;
int ival;
va_start(ip, len);
for (int i = 0; i < len; i++) {
ival = va_arg(ip, int);
list_append(&ls, ival);
}
va_end(ip);
return ls;
}
list srange(int a, int b, int step)
{
list ls = make_nil();
if (a >= b)
return ls;
ls->length = b - a;
ls->body = make_node(a);
node *q = ls->body;
for (int i = a + step; i < b; i++) {
node *pnew = make_node(i);
q->next = pnew;
q = q->next;
}
return ls;
}
list arr2list(int *arr, int len)
{
if (len < 0) {
fprintf(stderr, "arr2list: negative index.\n");
exit(EXIT_WRONG_ARG);
}
list ls = make_nil();
ls->length = len;
if (len == 0)
return ls;
ls->body = make_node(arr[0]);
node *q = ls->body;
for (int i = 1; i < len; i++) {
node *pnew = make_node(arr[i]);
q->next = pnew;
q = q->next;
}
return ls;
}
Value * evaluate(Environment *env, Value *expr) {
EvaluationContext *ctx;
Value *temp, *result;
Value *operator;
Value *operand_val, *operand_cons;
Value *operands, *operands_end, *nil_value;
int num_operands;
/* Set up a new evaluation context and record our local variables, so that
* the garbage-collector can see any temporary values we use.
*/
ctx = push_new_evalctx(env, expr);
evalctx_register(&temp);
evalctx_register(&result);
evalctx_register(&operator);
evalctx_register(&operand_val);
evalctx_register(&operand_cons);
evalctx_register(&operands);
evalctx_register(&operands_end);
evalctx_register(&nil_value);
#ifdef VERBOSE_EVAL
printf("\nEvaluating expression: ");
print_value(stdout, expr);
printf("\n");
#endif
/* If this is a special form, evaluate it. Otherwise, this function will
* simply pass the input through to the result.
*/
result = eval_special_form(env, expr);
if (result != expr)
goto Done; /* It was a special form. */
/*
* If the input is an atom, we need to resolve it to a value, using the
* current environment.
*/
if (is_atom(expr)) {
/* Treat the atom as a name - resolve it to a value. */
result = resolve_binding(env, expr->string_val);
if (result == NULL) {
result = make_error("couldn't resolve name \"%s\" to a value!",
expr->string_val);
}
goto Done;
}
/*
* If the input isn't an atom and isn't a cons-pair, then assume it's a
* value that doesn't need evaluating, and just return it.
*/
if (!is_cons_pair(expr)) {
result = expr;
goto Done;
}
/*
* Evaluate operator into a lambda expression.
*/
temp = get_car(expr);
operator = evaluate(env, temp);
if (is_error(operator)) {
result = operator;
goto Done;
}
if (!is_lambda(operator)) {
result = make_error("operator is not a valid lambda expression");
goto Done;
}
#ifdef VERBOSE_EVAL
printf("Operator: ");
print_value(stdout, operator);
printf("\n");
#endif
/*
* Evaluate each operand into a value, and build a list up of the values.
*/
#ifdef VERBOSE_EVAL
printf("Starting evaluation of operands.\n");
#endif
num_operands = 0;
operands_end = NULL;
operands = nil_value = make_nil();
temp = get_cdr(expr);
while (is_cons_pair(temp)) {
Value *raw_operand;
num_operands++;
/* This is the raw unevaluated value. */
raw_operand = get_car(temp);
/* Evaluate the raw input into a value. */
operand_val = evaluate(env, raw_operand);
if (is_error(operand_val)) {
result = operand_val;
goto Done;
}
operand_cons = make_cons(operand_val, nil_value);
if (operands_end != NULL)
set_cdr(operands_end, operand_cons);
else
operands = operand_cons;
operands_end = operand_cons;
temp = get_cdr(temp);
}
/*
* Apply the operator to the operands, to generate a result.
*/
if (operator->lambda_val->native_impl) {
/* Native lambdas don't need an environment created for them. Rather,
* we just pass the list of arguments to the native function, and it
* processes the arguments as needed.
*/
result = operator->lambda_val->func(num_operands, operands);
}
else {
/* These don't need registered on the explicit stack. (I hope.) */
Environment *child_env;
Value *body_iter;
/* It's an interpreted lambda. Create a child environment, then
* populate it with values based on the lambda's argument-specification
* and the input operands.
*/
child_env = make_environment(operator->lambda_val->parent_env);
temp = bind_arguments(child_env, operator->lambda_val, operands);
if (is_error(temp)) {
result = temp;
goto Done;
}
/* Evaluate each expression in the lambda, using the child environment.
* The result of the last expression is the result of the lambda.
*/
body_iter = operator->lambda_val->body;
do {
result = evaluate(child_env, get_car(body_iter));
body_iter = get_cdr(body_iter);
}
while (!is_nil(body_iter));
}
Done:
#ifdef VERBOSE_EVAL
printf("Result: ");
print_value(stdout, result);
printf("\n\n");
#endif
/* Record the result and then perform garbage-collection. */
pop_evalctx(result);
collect_garbage();
return result;
}