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

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

/* 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_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)) {
         fprintf(stderr, "Error: cond expressions not supported\n");
         return L_ERROR;
       }
       /* 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)) {
         fprintf(stderr, "Lambda operations not supported.\n");
         return L_ERROR;
       }
       /* 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) */