/*
 * lisp.c
 */
#include "scanner.h"
#include "parse.h"
#include "lisp.h"
#include <stdio.h>
#include <string.h>

static Sp numberp (Sp );
static Sp alphap (Sp );
static Sp atom (Sp );
static long chars2 (Sp , Alftype );
static Sp arith (Sp , char );
static Sp eq (Sp );
static Sp putassoc (Sp , Sp , Sp );
static Sp listputassoc (Sp , Sp , Sp );
static Sp getassoc (Sp , Sp );
static Sp apply (Sp , Sp );
static Sp load (Sp );
static Sp enveval (Sp , Sp );
static Sp evalcond(Sp , Sp );
static Sp envevalargs(Sp , Sp );

Sp varlist, funclist;

static Sp numberp (Sp s)
{
   if (s == NULL ) return(NULL);
   if (ctype(s) == n ) return(trueatom);
   return(NULL);
} /* numberp */

static Sp alphap (Sp s)
{
   if (s == NULL ) return(NULL);
   if (ctype(s) == a ) return(trueatom);
   return(NULL);
} /* alphap */

static Sp atom (Sp s)
{
   if ((numberp(s) == trueatom) || (alphap(s) == trueatom) ) return(trueatom);
   return(NULL);
} /* atom */

static long chars2 (Sp s, char * a)
{
      if (strcmp(chars(s), a) == 0)
            return(1);
      return(0);
} /* chars2 */

static Sp arith (Sp s, char op)
{
   Numtype acc;
   if (s == NULL ) return(NULL);
   if (car(s) == NULL ) return(err(20));
   if (numberp(car(s)) != trueatom ) return(err(21));
   acc = number(car(s));
   while (1 ) {
      if (cdr(s) == NULL ) return(newnumatom(acc));
      s = cdr(s);
      if (numberp(car(s)) != trueatom )
         return(err(22));
      switch (op) {
	       case '+': acc = acc + number(car(s)); break;
	       case '-': acc = acc - number(car(s)); break;
	       case '*': acc = acc * number(car(s)); break;
	       case '/': acc = acc / number(car(s)); break;
	       } /* switch */
   } /* while (*/
} /* arith */

static Sp eq (Sp s)
{
  char * c1;
  char * c2;
   if ((numberp(car(s)) == trueatom) && 
      (numberp(car(cdr(s))) == trueatom) ) {
         if (number(car(s)) == number(car(cdr(s))) )
	    return(trueatom);
      }
   if ((alphap(car(s)) == trueatom) && 
           (alphap(car(cdr(s))) == trueatom) ) {
               c1 = chars(car(s)); c2 = chars(car(cdr(s)));
	       if (strcmp(c1, c2) == 0) return(trueatom);
        }
   if (car(s) == cdr(s) ) return(trueatom);
   return(NULL);
} /* eq */

static Sp putassoc (Sp n, Sp v, Sp alist)
{
   return(cons(cons(n, cons(v, NULL)), alist));
} /* putassoc */

static Sp listputassoc (Sp ln, Sp lv, Sp alist)
{
   if (cdr(ln) == NULL )
      return(putassoc(car(ln), car(lv), alist));
   else
      return(putassoc(car(ln), car(lv),
          listputassoc(cdr(ln), cdr(lv), alist)));
} /* listputassoc */

static Sp getassoc (Sp n, Sp alist)
{
   char * c1;
   char * c2;
   if (alist == NULL ) return(NULL);
   c1 = chars(n); c2 = chars(car(car(alist)));
   if (strcmp(c1, c2) == 0) return(car(alist));
   return(getassoc(n, cdr(alist)));
} /* getassoc */
    
static Sp apply (Sp f, Sp s)
{
   if (chars2(f,"PLUS")       ) return(arith(s, '+'));
   if (chars2(f, "DIFFERENCE") ) return(arith(s, '-'));
   if (chars2(f, "TIMES") ) return(arith(s, '*'));
   if (chars2(f, "QUOTIENT") ) return(arith(s, '/'));
   if (chars2(f, "MINUS") )
        return(arith(cons(newnumatom(0.0), s), '-'));
   if (chars2(f, "LESSP") ) { 
           if (number(arith(s,'-')) < 0.0 ) return(trueatom);
	   else  return(NULL);
        }
   if (chars2(f, "ZEROP") ) { 
           if (number(arith(s,'-')) == 0.0 ) return(trueatom);
	   else  return(NULL);
        }
   if (chars2(f, "GREATERP") ) {
           if (number(arith(s,'-')) > 0.0 ) return(trueatom);
	   else  return(NULL);
        }
   if (chars2(f, "EQ") ) return(eq(s));
   if (chars2(f, "NULL") ) {
           if (car(s) == NULL ) return(trueatom);
           else  return(NULL);
        }
   if (chars2(f, "CAR") ) return(car(car(s)));
   if (chars2(f, "CDR") ) return(cdr(car(s)));
   if (chars2(f, "CONS") ) return(cons(car(s), car(cdr(s))));
   if (chars2(f, "ATOM") ) return(atom(car(s)));
   if (chars2(f, "NUMBERP") ) return(numberp(car(s)));
   return(err(30));
} /* apply */

Sp eval (Sp s)
{
   Sp stemp;
   if (s == NULL ) return(NULL);
   if (atom(s) == trueatom ) return(enveval(s, varlist));
   if (chars2(car(s), "SETQ") ) {
            stemp = enveval(car(cdr(cdr(s))), varlist);
            varlist = putassoc (car(cdr(s)), stemp, varlist);
	    return(stemp);
   }
   if (chars2(car(s), "DEFUN") ) {
            funclist = putassoc (car(cdr(s)), cdr(cdr(s)), funclist);
	    return(cdr(cdr(s)));
        }
   return(enveval(s, varlist));
} /* eval */

static Sp enveval (Sp s, Sp alist)
{
   Sp stemp, formalparamlist, actualparamlist, newalist, funcbody;
   if (s == NULL ) return(NULL);
   if (s == trueatom ) return(trueatom);
   if (numberp(s) == trueatom ) return(s);
   if (alphap(s) == trueatom ) {
           stemp = getassoc(s, alist);
	   if (stemp == NULL ) return(err(40));
	   else  return(car(cdr(stemp)));
        }
   /* now s is a list */
   if (alphap(car(s)) == trueatom ) {
            if (chars2(car(s), "QUOTE") ) return(car(cdr(s)));
	    else if (chars2(car(s), "COND") )
	        return(evalcond(cdr(s), alist));
	    else {
	        stemp = getassoc(car(s), funclist);
	        if (stemp != NULL )/* user defined function */ {
	            formalparamlist = car(car(cdr(stemp)));
	            actualparamlist = envevalargs(cdr(s), alist);
	            newalist = listputassoc(formalparamlist, actualparamlist,
	               alist);
	            funcbody = car(cdr(car(cdr(stemp))));
	            return(enveval(funcbody, newalist));
	        }
	        else /* builtin function || undefined */
	           return(apply(car(s), envevalargs(cdr(s), alist)));
            }
   } /* car(s) is alpha atom */
   return(err(41));
} /* enveval */

static Sp evalcond(Sp s, Sp alist)
{
   if (s == NULL ) return(NULL);
   if (atom(s) == trueatom ) return(err(50));
   if (atom(car(s)) == trueatom ) return(err(51));
   if (enveval(car(car(s)), alist) != NULL )
               return(enveval(car(cdr(car(s))), alist));
   return(evalcond(cdr(s), alist));
} /* evalcond */

static Sp envevalargs(Sp s, Sp alist)
{
   Sp arg1, arg2;
   if (s == NULL ) return(NULL);
   arg1 = enveval(car(s), alist);
   arg2 = envevalargs(cdr(s), alist);
   return(cons(arg1, arg2));
} /* envevalargs */
 
void initlispstuff(void)
{
   varlist = NULL;
   funclist = NULL;
   varlist = putassoc(trueatom, trueatom, varlist);
   varlist = putassoc(nilatom, NULL,   varlist);
} /* initlispstuff */