ERPL/erple.c

#include "erplb.c" // builtin functions

// TODO rethink stack pushing mechanism

// expressions evaluation:

void* (builtin_lookup) (int* name) {
   for (int a = 0; builtin_commands[a].name[0] != 0; a++) {
      if (symbols_are_equal(builtin_commands[a].name, name)) {
         return builtin_commands[a].operation;
      }
   }
   return NULL;
}

Table* atom_lookup (int* name, Table* context) {
   Table *t = table_lookup(context, name);
   if (!t) t = table_lookup(globals, name);
   return t;
}

Atom* eval (Atom* expr, Table** context) {
   if (!expr)
      return NULL;
   if (is_simple(expr)) {
      if (is_symbol(expr))
         return eval_symbol(expr->symb, NULL, context);
      return expr;
   }
   if (is_list(expr))
      return eval_application(expr->list, context);
   return expr;
}

Atom* eval_symbol (int* symb, List* args, Table** context) {
   Atom *newhead = NULL, *value = NULL;
   Atom *(*fn)(List*,Table**);

   Table *t = table_lookup(*context, symb);
   if (!t) t = table_lookup(globals, symb);
   if (t) {
      if (!t->value)
         goto error;
      switch (t->value->type) {
      case SYMB:
         fn = builtin_lookup(t->value->symb);
         if (!fn)
            goto error;
         value = fn(args, context);
      break;
      case LIST:
         newhead = eval_application(t->value->list, context);
         if (!newhead)
            goto error;
         switch (newhead->type) {
         case LAMBDA:
            value = eval_lambda(newhead->list, args, context);
         break;
         case SYMB:
            fn = builtin_lookup(newhead->symb);
            if (!fn)
               goto error;
            value = fn(args, context);
         break;
         default:
            goto error;
         }
         goto end;
      case LAMBDA:
         value = eval_lambda(t->value->list, args, context);
      break;
      default:
         goto error;
      }
      goto end;
   }
   fn = builtin_lookup(symb);
   if (!fn)
      goto error;
   value = fn(args, context);
   goto end;

   error:
      free_atom(newhead);
      return _warning("EVAL(symbol)" INVALID_ARGS);
   end:
      free_atom(newhead);
      return value;
}

Atom* eval_application (List* appl, Table** context) {
   Atom *newhead = NULL, *value = NULL;
   if (!appl || !appl->head)
      goto error;
   switch (appl->head->type) {
   case LAMBDA:
      value = eval_lambda(appl->head->list, appl->tail, context);
   break;
   case SYMB:
      value = eval_symbol(appl->head->symb, appl->tail, context);
   break;
   case LIST:
      newhead = eval_application(appl->head->list, context);
      if (!newhead)
         goto error;
      switch (newhead->type) {
      case SYMB:
         value = eval_symbol(newhead->symb, appl->tail, context);
      break;
      default:
         goto error;
      }
   default:
      goto error;
   }
   free_atom(newhead);
   return value;

   error:
      free_atom(newhead);
      return _warning("EVAL(application)" INVALID_ARGS);
}

Atom* eval_lambda (List* body, List* arguments, Table** context) {
   #warning TODO
   if (!valid_lambda(body))
      return _warning("EVAL(lambda)" INVALID_ARGS);
   if (!define_local_vars(body->head->list, arguments, context))
      return _warning("EVAL(lambda)" INSUFFICIENT_ARGS_STK);
   //
   //
   destroy_local_vars(body, context);
}

unsigned define_local_vars (List* arg_names, List* values, Table** context) {
   Table *local_vars = NULL;
   // normal application
   while (arg_names && values) {
      table_set(&local_vars, arg_names->head->symb, values->head);
      arg_names = arg_names->tail;
      values = values->tail;
   }
   // partial application
   while (arg_names) {
      if (!stack) {
         free_table(local_vars);
         return 0;
      }
      table_set(&local_vars, arg_names->head->symb, stack->head);
      arg_names = arg_names->tail;
   }
   table_union(local_vars, context);
   return 1;
}

void destroy_local_vars (List* arg_names, Table** context) {
   while (arg_names) {
      table_unset(context, arg_names->head->symb);
      arg_names = arg_names->tail;
   }
}