/*
   l_eval.c - Evaluation procedures for L.
   Samuel A. Rebelsky
   Version 0.1 of 3 March 2007
 */

#include <stdio.h>
#include "l.h"

/* Predeclare the primary proc. */
pair _l_eval(pair,pair);

/* The standard environment - An association list. */
pair _env;

void
init_env()
{
  _env = L_NIL;
} /* init_env() */

/* Look up a symbol in the environment. */
static pair
lookup(pair sym, pair env)
{
  if (is_nil(env)) {
    fprintf(stderr, "Error: Unknown symbol %s.\n", CDR(sym));
    return L_ERROR;
  }
  else if (l_eq(sym, CAR(CAR(env)))) {
    return CDR(CAR(env));
  }
  else {
    return lookup(sym, CDR(env));
  }
} /* lookup(pair, pair) */

/* Determine if two pairs are the same. */
int
l_eq(pair left, pair right)
{
  /* Ideally, this should be
       return ((CAR(left) == CAR(right)) && (CDR(left) == CDR(right)));
     or even
       left == right
     Unfortunately, the code to allocate symbols doesn't ensure that
     every symbol gets the same pair.  So we have to use the much less
     efficient strcmp.
   */
   if ((CAR(left) == CAR(right)) && (CDR(left) == CDR(right))) {
     return 1;
   }
   return (CAR(left) == L_SYMBOL)
           && (CAR(right) == L_SYMBOL)
           && !strcmp(CDR(left),CDR(right));
} /* l_eq(pair,pair) */

pair
l_evlis(pair lst, pair env)
{
  if (is_nil(lst)) {
    return lst;
  }
  else {
    return allocate_pair(_l_eval(CAR(lst), env),
                         l_evlis(CDR(lst), env));
  }
} /* l_evlis(pair) */

pair
l_makepairs(pair lst1, pair lst2)
{
  if (is_nil(lst1)) {
    if (is_nil(lst2)) {
      return L_NIL;
    }
    else {
      fprintf(stderr, "Too many actual parameters in proc call.\n");
      return L_ERROR;
    }
  }
  else {
    if (!is_nil(lst2)) {
      return allocate_pair(allocate_pair(CAR(lst1), CAR(lst2)),
                           l_makepairs(CDR(lst1), CDR(lst2)));
    }
    else {
      fprintf(stderr, "Too few actual parameters in proc call.\n");
      return L_ERROR;
    }
  }
}

pair
l_append(pair lst1, pair lst2)
{
  if (is_nil(lst1)) {
    return lst2;
  }
  else {
    allocate_pair(CAR(lst1), l_append(CDR(lst1), lst2));
  }
} /* l_append(pair, pair) */

pair
_l_eval_lambda(pair lambda, pair actuals, pair env)
{
  /* Error checking left until later, just to upset the Java gurus */
  pair formals = CAR(CDR(lambda));
  pair body = CAR(CDR(CDR(lambda)));
  /* 1. Evaluate all of the actuals, creating a list of evaluated 
     actuals */
  pair evaluated = l_evlis(actuals, env);
  /* 2. Make a list of formal/actual pairs to represent intended bindings
        in the body (_l_makepairs) */
  pair bindings = l_makepairs(formals, evaluated);
  /* 3. Append that to the front of the environment (_l_append) */
  pair newenv = l_append(bindings, env);
  /* 4. Evaluate the body in the new environment */
  return _l_eval(body, newenv);
}


pair
_l_eval_cond(pair cases, pair env)
{
  if (is_nil(cases)) {
    fprintf(stderr, "No cases held in cond.\n");
    return L_ERROR;
  }
  pair guard = CAR(CAR(cases));
  pair guard_result = _l_eval(guard, env);
  if (l_eq(guard_result,L_TRUE)) {
    return _l_eval(CAR(CDR(CAR(cases))), env);
  }
  return _l_eval_cond(CDR(cases), env);
} // __eval_cond

pair
_l_eval(pair exp, pair env)
{
  pair tmp;

  /* Integers and strings don't get evaluated. */
  if (is_int(exp)) {
    return exp;
   }
   else if (is_string(exp)) {
     return exp;
   }
   
   /* Symbols get looked up in the symbol table. */
   else if (is_symbol(exp)) {
     return lookup(exp, env);
   }

   /* Pairs represent function applications. */
   else if (is_pair(exp)) {
     /* Get the operation to apply. */
     pair op = CAR(exp);
     if (is_symbol(op)) {
       /* Lambdas and lets are not supposed to be evaluated. */
       if (l_eq(op, L_LAMBDA) || l_eq(op, L_LABEL)) {
         return exp;
       }
       /* Quote returns its parameter, unevaluated. */
       else if (l_eq(op, L_QUOTE)) {
         return CAR(CDR(exp));
       }
       /* Define updates the global symbol table. */
       else if (l_eq(op, L_DEFINE)) {
         tmp = _l_eval(CAR(CDR(CDR(exp))), env);
         _env = allocate_pair(allocate_pair(CAR(CDR(exp)), tmp), _env);
         return tmp;
       }
       /* Conds require special handling. */
       else if (l_eq(op, L_COND)) {
         return _l_eval_cond(CDR(exp), env);
       }
       /* Finally!  The basic operations. */
       else if (l_eq(op, L_CAR)) {
         tmp = _l_eval(CAR(CDR(exp)), env);
         return CAR(tmp);      
       }
       else if (l_eq(op, L_CDR)) {
         tmp = _l_eval(CAR(CDR(exp)), env);
         return CDR(tmp);      
       }
       else if (l_eq(op, L_CONS)) {
         return allocate_pair(_l_eval(CAR(CDR(exp)), env), 
                              _l_eval(CAR(CDR(CDR(exp))), env));
       }
       else if (l_eq(op, L_EQ)) {
         if (l_eq(_l_eval(CAR(CDR(exp)),env), _l_eval(CAR(CDR(CDR(exp))),env))) {
           return L_TRUE;
         }
         else {
           return L_FALSE;
         }
       }
       /* User-defined symbols get looked up */
       else {
         return _l_eval(allocate_pair(lookup(op, env), CDR(exp)), env);
       }
     } // if the operator is a symbol
     else if (is_pair(op)) {
       if (l_eq(CAR(op), L_LABEL)) {
         fprintf(stderr, "Label operations not supported.\n");
         return L_ERROR;
       }
       else if (l_eq(CAR(op), L_LAMBDA)) {
         return _l_eval_lambda(op, CDR(exp), env);
       }
       /* Hmmm ... If the car is a pair and does not start with
          label or lambda, it must be an expression that is supposed
          to return a procedure. */
       else {
         pair newop = _l_eval(op, env);
         return _l_eval(allocate_pair(newop, CDR(exp)), env);
       }
     } // if the operator is a pair
     else {
       fprintf(stderr, "Invalid operation: ");
       l_print(stderr, op);
       fprintf(stderr, "\n");
       return L_ERROR;
     } // if the operator is neither pair nor symbol
   } // if the expression to evaluate is a pair
   else {
     fprintf(stderr, "Encountered unknown expression type");
     return L_ERROR;
   }
} /* _l_eval(pair, pair) */

/* Evaluate an expression, using the current environment. */
pair
l_eval(pair exp)
{
  return _l_eval(exp, _env);
} /* l_eval(pair) */