/* 
 * Lisp evaluator
 * Don Hopkins
 */

#include "lisp.h"

/*
 * Check to see if there are the right number of arguments. Returns 1 if
 * count = -1 (any number of args) or if args is a count element list. 
 * Returns 0 otherwise.
 */

int check_args(args, count)
     object args;
     int count;
{
  while (count-- &&
	 Object_Type(args) == cons_object)
    args = Cons_Cdr(args);

  return(count < -1 || args == Nil);
}

/*
 * Returns the lambda, special, or macro form with the arguments and
 * body, of the one argument, whose type must be user_function_object,
 * user_special_object, or macro_object.
 */

object body(args)
     object args;
{
  object obj;

  switch (Object_Type(ARG1)) {

  case user_function_object:
    obj = Lambda;
    break;

  case user_special_object:
    obj = Special;
    break;

  case macro_object:
    obj = Macro;
    break;

  default:
    bad_args("body");
  }

  return(make_cons(obj, make_cons(Cons_Car(Cons_Car(args)),
				  Cons_Cdr(Cons_Car(args)))));
}

/*
 * Bind the parameters to the values in the current frame.  Returns 1
 * if there were the right number of values, or 0 if the parms and
 * values don't match. If parms is an atom, or a chain of conses with
 * the last cdr a non-nil atom, the remaining arguments are bound that
 * atom. 
 */

int bind_args(parms, values)
     object parms, values;
{
  while (Object_Type(parms) == cons_object &&
	 Object_Type(values) == cons_object) {

    Ob_Bind(Cons_Car(parms), Cons_Car(values));

    parms = Cons_Cdr(parms);
    values = Cons_Cdr(values);
  }

  if (parms != Nil &&
      Object_Type(parms) == atom_object) {

    Ob_Bind(parms, values);
    return(1);
  }

  return (parms == Nil && values == Nil);
}

/*
 * Evaluate the members of a list and return a list of the results.
 */

object evlis(obj)
     object obj;
{
  object result;

  if (obj == Nil)
    return(Nil);

  if (Object_Type(obj) != cons_object)
    return(bad_args("evlis"));

  Ob_Push();
  Ob_Save(result = eval(Cons_Car(obj)));
  result = make_cons(result,
		     evlis(Cons_Cdr(obj)));
  Ob_Pop();
  return(result);
}

/*
 * Lisp interface to evlis.
 */

object levlis(args)
     object args;
{
  return(evlis(ARG1));
}

/*
 * Apply the function fun to the arguments args, and return the
 * result.  Create a new stack frame. Evaluate fun while it's an atom
 * or a cons. If fun is user defined, then bind the arguments and
 * evaluate the function body with dolist. If fun is built-in, then
 * call the C code to do it. If fun is a macro, then bind the
 * arguments, evaluate the macro body, unbind the arguments, and
 * evaluate the result. If fun is a funarg, then set the environment,
 * apply the function, and restore the environment.
 */

object apply(fun, args)
     object fun, args;
{
  int loop = 0;
  object result = undefined_object;

  Ob_Push();

/*
 * Save fun and args on Back_Trace stack.
 */

  O_Push(Back_Trace, make_cons(fun, args)); 

  while ((loop++ < LOOP_MAX) &&
	 (Object_Type(fun) == atom_object ||
	  Object_Type(fun) == cons_object))
    Ob_Save(fun = eval(fun));

  switch (Object_Type(fun)) {
      
/*
 * If fun is user defined, then bind the arguments and evaluate the
 * body with dolist.
 */

  case user_function_object:
  case user_special_object:
    if (bind_args(Cons_Car(fun), args))
      result = dolist(Cons_Cdr(fun));
    else
      result = bad_args("user function in apply");
    break;

/*
 * If fun is built-in, then call the C code to do it with args as an
 * argument. 
 */

  case built_in_function_object:
  case built_in_special_object:
    if (check_args(args, Built_In_Args(fun)))
      result = Apply_Built_In(fun, args);
    else
      result = bad_args("built in function in apply");
    break;

/*
 * If fun is a macro, then bind the arguments, evaluate the body with
 * dolist, unbind the arguments, and evaluate the result.
 */

  case macro_object:
    Ob_Push();
    if (bind_args(Cons_Car(fun), args)) {
      result = dolist(Cons_Cdr(fun));
      Ob_Pop();
      Ob_Save(result);
      result = eval(result);
    }
    else {
      result = bad_args("macro in apply");
      Ob_Pop();
    }
    break;

/*
 * If fun is a funarg, then set the environment, apply the function,
 * and restore the environment. 
 */

  case funarg_object:
    Env_Push(Cons_Cdr(fun));
    result = apply(Cons_Car(fun), args);
    Env_Pop();
    break;

  default:
    result = bad_args("apply");
    break;
  }
  
  if (result == undefined_object)
    result = error("undefined object");
	   
  Ob_Pop();

/* 
 * Pop back_trace stack.
 */

  O_Pop(Back_Trace);

  return(result);
}

/*
 * Lisp interface to apply.
 */

object lapply(args)
     object args;
{
  return(apply(ARG1, ARG2));
}

/*
 * Call a function by applying fun to args. 
 */

object funcall(fun, args)
     object fun, args;
{
  object result;

  Ob_Push();
  Ob_Save(args);
  Ob_Save(args = evlis(args));
   result = apply(fun, args);  
  Ob_Pop();
  return(result);
}

/*
 * Lisp interface to funcall.
 */

object lfuncall(args)
     object args;
{
  if (Object_Type(args) == cons_object)
    return(funcall(ARG1, Cons_Cdr(args)));
  return(bad_args("funcall"));
}

/*
 * Evaluate a lisp form and return the result. If obj is a number,
 * return it. If obj is an atom, return its binding. If obj is a cons,
 * then do the appropriate things to apply its car, the fuction, to
 * its cdr, the arguments, which are evaluated if necessary.
 */

object eval(obj)
     object obj;
{
  int loop = 0;

  switch (Object_Type(obj)) {

/*
 * Return a number.
 */

  case number_object:
    break;

/*
 * Look up an atom binding.
 */

  case atom_object:
    obj = *find_variable(obj);
    break;

/*
 * Apply a function to its args. If the function is an atom or list,
 * then evaluate it. If the function is function object, apply the
 * function to the evaluated arguments. If it's a special object or
 * macro, apply the function to the unevaluated arguments. If it's a
 * funarg, apply the funarg function, to the arguments in the funarg
 * environment. 
 */

  case cons_object:
    {
      object fun = Cons_Car(obj), args = Cons_Cdr(obj), type, funarg, env;

      Ob_Push();

/*
 * Evaluate fun while it's an atom or a list.
 */

      while ((loop++ < LOOP_MAX) &&
	     ((type = Object_Type(fun)) == atom_object ||
	      type == cons_object))
        Ob_Save(fun = eval(fun));

      switch (type) {

/*
 * For function objects, evaluate the arguments.
 */

      case user_function_object:
      case built_in_function_object:
	Ob_Save(args = evlis(args));

/*
 * For function, special, and macro objects, apply the function to the
 * arguments.
 */

      case user_special_object:
      case built_in_special_object:
      case macro_object:
	obj = apply(fun, args);
	break;

/*
 * For funargs, if the funarg function is an atom or a cons,
 * then evaluate it in the funarg environment, and make a new funarg
 * object to represent the function. If the funarg function is a
 * function object, then evaluate the arguments. Apply the funarg to
 * the arguments.
 */

      case funarg_object:
	funarg = fun;
	env = Cons_Cdr(fun);
	fun = Cons_Car(fun);

	if ((type = Object_Type(fun)) == atom_object ||
	    type == cons_object) {

	  Env_Push(env);
	  Ob_Push();

	  while ((loop++ < LOOP_MAX) &&
		 ((type = Object_Type(fun)) == atom_object ||
		  type == cons_object))
	    Ob_Save(fun = eval(fun));

	  Ob_Pop();
	  Env_Pop(env);

	  funarg = Set_Type(funarg_object, make_cons(fun, env));
	  Ob_Save(funarg);
	}

	if (type == user_function_object ||
	    type == built_in_function_object)
	   Ob_Save(args = evlis(args));

	obj = apply(funarg, args);
	break;
	
/*
 * Otherwise, barf up.
 */

      default:
	printcr(fun);
	obj = bad_args("eval: bad function");
	break;
      }

      Ob_Pop();
    }
    break;

  default:
    obj = bad_args("eval");
  }

  if (obj == undefined_object)
    obj = error("undefined object");

  return(obj);
}

/*
 * Lisp interface to eval.
 */

object leval(args)
     object args;
{
  return(eval(ARG1));
}

/*
 * Evaluate a list and return the results of the evaluation of the last 
 * member. 
 */

object dolist(args)
     object args;
{
  object result = Nil;

  while (Object_Type(args) == cons_object) {
    result = eval(ARG1);
    args = Cons_Cdr(args);
  }

  if (args != Nil)
    return(bad_args("do"));

  return(result);
}

/*
 * Evaluate a cond clause. Test the arguments in order until one
 * succeeds. If none succeed, return Nil. An argument succeeds if the
 * result of evaluating its condition is non-nil. If it succeeds, and
 * the consequence is Nil, then return the result, otherwise return
 * the result of calling dolist on the consequence. The condition of
 * an argument is its car. The consequence of an argument is its cdr.
 */

object cond(args)
     object args;
{
  object result = Nil;

  while (Object_Type(args) == cons_object) {

/*
 * Check for proper form.
 */

    if (Object_Type(ARG1) != cons_object ||
	(Object_Type(Cons_Cdr(ARG1)) != cons_object &&
	 Cons_Cdr(ARG1) != Nil))
      return(bad_args("cond"));

/*
 * Test the condition.
 */

    result = eval(Cons_Car(ARG1));
    if (result == Nil) {
      args = Cons_Cdr(args);
      continue;
    }

/*
 * The condition succeeded. If there is not a consequence, return the
 * result of evaluating the condition, otherwise return the result of
 * calling dolist on the consequence.
 */

    if (Cons_Cdr(ARG1) != Nil)
      result = dolist(Cons_Cdr(ARG1));      
    return(result);
  }

  if (args != Nil)
    return(bad_args("cond"));

/*
 * None of the arguments returned non-nil, so return Nil.
 */

  return(Nil);
}

/*
 * Create a user function object. Passed a list of arguments and a
 * body.  Returns an object of type user_function_object.
 */

object lambda(args)
     object args;
{
  if (Object_Type(args) == cons_object)
    return(Set_Type(user_function_object, args));

  return(bad_args("lambda"));
}

/*
 * Create a user special object. Passed a list of arguments and a
 * body. Returns an object of type user_special_object.
 */

object special(args)
     object args;
{
  if (Object_Type(args) == cons_object)
    return(Set_Type(user_special_object, args));

  return(bad_args("special"));
}

/*
 * Create a macro object. Passed a list of arguments and a body.
 * Returns an object of type macro_object.
 */

object macro(args)
     object args;
{
  if (Object_Type(args) == cons_object)
    return(Set_Type(macro_object, args));
  return(bad_args("macro"));
}

/*
 * Create a funarg object. Passed a function suitable for apply.
 * Returns an object of type funarg_object, consisting of the dotted
 * pair (fun . env), where fun is the function, and env is the current
 * environment, i.e.  Ob_List.
 */

object function(args)
     object args;
{
  return(Set_Type(funarg_object, make_cons(ARG1, Ob_List)));
}