# 1 "eval.c"
/* 
 * Lisp evaluator
 * Don Hopkins
 */


# 1 "./lisp.h"
/*
 * Lisp header file
 */


# 1 "/usr/include/stdio.h"
/*	@(#)stdio.h 1.2 85/01/21 SMI; from UCB 1.4 06/30/83	*/




extern	struct	_iobuf {
	int	_cnt;
	char	*_ptr;
	char	*_base;
	int	_bufsiz;
	short	_flag;
	char	_file;
} _iob[30];


























struct _iobuf	*fopen();
struct _iobuf	*fdopen();
struct _iobuf	*freopen();
struct _iobuf	*popen();
long	ftell();
char	*fgets();
# 48 "/usr/include/stdio.h"





# 6 "./lisp.h"

# 1 "/usr/include/setjmp.h"
/*	@(#)setjmp.h 1.1 84/12/20 SMI; from UCB 4.1 83/05/03	*/

# 5 "/usr/include/setjmp.h"



typedef int jmp_buf[15];	/* pc,sigmask,onsstack,d2-7,a2-7 */

# 7 "./lisp.h"

/*
 * Constants specifying the initial and growth sizes of the cons,
 * atom, and number spaces.
 */








/*
 * Maximum atom length.
 */



/*
 * Maximum number of times to eval a prospective function while it's
 * still an atom or cons node.
 */



/*
 * Maximum number of elements of a list to print.
 */



/*
 * How close two numbers must to be to be considered equal, and how
 * small a number must be to be considered zero. 
 */
 


/*
 * File to read from upon initialization.
 */



/*
 * Mask to extract an object's index.
 */



/*
 * Mask to extract an object's type.
 */



/*
 * Mask used to mark nodes during garbage collection.
 */



/*
 * Number of different types of lisp objects.
 */



/*
 * Lisp object type values.
 */













/*
 * Define the C data type that represents a lisp object.
 */

typedef long object;

/*
 * Macros to manipulate a lisp objects. 
 */

/*
 * The index of an object.
 */



/* 
 * The type of an object.
 */



/*
 * The ordinal value of the type of an object. Will range from 1 to
 * TYPE_COUNT. 
 */



/*
 * An object coerced into a given type.
 */



/*
 * The cons structure. 
 */

struct cons {
  object car;
  object cdr;
};

/*
 * Macros to manipulate cons objects. Cons_Car(cons) references the
 * car field of a cons object, and Cons_Cdr references the cdr field
 * of a cons object.
 */




/*
 * The atom structure.
 */

struct atom {
  object value;
  char *name;
};

/*
 * Macros to manipulate atom objects. Atom_Value(atom) references the
 * value field of an atom object, and Atom_Name references the name field
 * of an atom object.
 */




/*
 * The number structure.
 */

struct number {
  double value;
};

/*
 * Macro to manipulate number objects. Number_Value(atom) references the
 * value field of a number object.
 */



/*
 * The built-in structure.
 */

struct built_in {
  char *name;
  object type;
  object (*fun)();
  int args;
};

/*
 * Macros to manipulate built in objects. Built_In_Name(built_in)
 * references the name field of the built in object,
 * Built_In_Type(built_in) references its type field, 
 * Built_In_Fun(built_in) references its fun field, and
 * Built_In_Args(built_in) references its args field.
 * Apply_Built_In(built_in, args) calls the C code associated with the
 * built in function, passing it args.
 */







/*
 * Macros to deal with stacks. O_Push(stack, object) pushes object
 * onto stack. O_Top(stack) references the top object on stack.
 * O_Pop(stack) pops the top of a stack. 
 */






/* 
 * Macros for dealing with the Ob_List. Ob_Push() pushed a new frame
 * onto the Ob_List. Ob_Pop() pops the top frame from the Ob_List.
 * Ob_Bind(var, val) binds var to val in the current frame.
 * Ob_Unbind() pops the latest binding off of the current frame.
 * Ob_Save(object) pushed the pair (<undefined> . object) onto the
 * Ob_List to protect it from garbage collection. Env_Push(env) saves
 * the current Ob_List on Ob_Stack, and sets Ob_List to env. Env_Pop()
 * sets the Ob_List to the top of Ob_Stack, and pops Ob_Stack.
 */












/*
 * Macros for refering to the arguments of built-in functions. The
 * variable args is assumed to contain the head of the argument list. 
 */





/*
 * Global function declarations.
 */

/* In math.c */
object plus(), times(), quotient(), remainder(), minus(), 
       lfloor(), numberp(), greaterp(), zerop();

/* In util.c */
object *find_variable();
object push_stream(), pop_stream(), push_output(), push_input(),
       pop_output(), pop_input(), eq(), lcons(), lcar(), lcdr(),
       latom(), list(), type(), setq(), quote(), and(), or();

/* In read.c */
object get_token(), sread(), read_quote(), read_list();

/* In print.c */
object lprin1(), lprint(), lprintcr(), terpri();

/* In gc.c */
object lgc();

/* In eval.c */
object body(), apply(), lapply(), funcall(), lfuncall(), eval(), leval(),
       dolist(), cond(), lambda(), special(), macro(), function();

/* In memory.c */
object get_cons(), make_cons(), get_atom(), make_atom(),
       get_number(), make_number();

/* In error.c */
object error();
char *type_name();

/*
 * Global variables
 */

/*
 * Counters for the number of allocated and used conses, atoms, and numbers.
 */

extern int Cons_Count, Cons_Free;
extern int Atom_Count, Atom_Free;
extern int Number_Count, Number_Free;

/*
 * Pointers to beginning of the the cons, atom, and number, and
 * built-in storage spaces. 
 */

extern struct cons *Cons;
extern struct atom *Atom;
extern struct number *Number;
extern struct built_in Built_In[];

/*
 * Objects refering to atoms. These are set to refer to their
 * respective atoms in initialize(). 
 */

extern object Nil, T, Quote, Lambda, Special, Macro;

/*
 * Stacks used by lisp and known about by the garbage collector. These
 * are set to Nil in initialize().
 */

extern object Ob_List, Ob_Stack, Back_Trace, Free_List,
              Input_Stack, Output_Stack;

/*
 * Input and output streams.
 */

extern struct _iobuf *Input_File, *Output_File;

/*
 * A longjmp() label for top level lisp read-eval-print loop. Used by
 * abort() to jump to lisp warm start in main().
 */

extern jmp_buf Top_Level;

/*
 * Names of the lisp object types.
 */

extern char *Type_Name[];

# 7 "eval.c"

/*
 * 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-- &&
	  		(args & 		0x0f000000) == 		0x04000000)
    args = 			(Cons[		(args & 		0x00ffffff)].cdr);

  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 ( 		(						(Cons[		(args & 		0x00ffffff)].car) & 		0x0f000000)) {

  case 	0x05000000:
    obj = Lambda;
    break;

  case 	0x06000000:
    obj = Special;
    break;

  case 		0x0a000000:
    obj = Macro;
    break;

  default:
    bad_args("body");
  }

  return(make_cons(obj, make_cons(			(Cons[		(			(Cons[		(args & 		0x00ffffff)].car) & 		0x00ffffff)].car),
				  			(Cons[		(			(Cons[		(args & 		0x00ffffff)].car) & 		0x00ffffff)].cdr))));
}

/*
 * 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 ( 		(parms & 		0x0f000000) == 		0x04000000 &&
	  		(values & 		0x0f000000) == 		0x04000000) {

    				((			(			(Cons[		(Ob_List & 		0x00ffffff)].car))) = make_cons(( 					       make_cons(			(Cons[		(parms & 		0x00ffffff)].car),  			(Cons[		(values & 		0x00ffffff)].car))), 							     (			(			(Cons[		(Ob_List & 		0x00ffffff)].car)))));

    parms = 			(Cons[		(parms & 		0x00ffffff)].cdr);
    values = 			(Cons[		(values & 		0x00ffffff)].cdr);
  }

  if (parms != Nil &&
       		(parms & 		0x0f000000) == 		0x02000000) {

    				((			(			(Cons[		(Ob_List & 		0x00ffffff)].car))) = make_cons(( 					       make_cons(parms,  values)), 							     (			(			(Cons[		(Ob_List & 		0x00ffffff)].car)))));
    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 ( 		(obj & 		0x0f000000) != 		0x04000000)
    return(bad_args("evlis"));

  					((Ob_List) = make_cons(( Nil), 							     (Ob_List)));
  							((			(			(Cons[		(Ob_List & 		0x00ffffff)].car))) = make_cons(( 					       make_cons(	0x01000000,  result = eval(			(Cons[		(obj & 		0x00ffffff)].car)))), 							     (			(			(Cons[		(Ob_List & 		0x00ffffff)].car)))));
  result = make_cons(result,
		     evlis(			(Cons[		(obj & 		0x00ffffff)].cdr)));
  						((Ob_List) = 			(Cons[		(Ob_List & 		0x00ffffff)].cdr));
  return(result);
}

/*
 * Lisp interface to evlis.
 */

object levlis(args)
     object args;
{
  return(evlis(						(Cons[		(args & 		0x00ffffff)].car)));
}

/*
 * 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 = 	0x01000000;

  					((Ob_List) = make_cons(( Nil), 							     (Ob_List)));

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

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

  while ((loop++ < 		256) &&
	 ( 		(fun & 		0x0f000000) == 		0x02000000 ||
	   		(fun & 		0x0f000000) == 		0x04000000))
    							((			(			(Cons[		(Ob_List & 		0x00ffffff)].car))) = make_cons(( 					       make_cons(	0x01000000,  fun = eval(fun))), 							     (			(			(Cons[		(Ob_List & 		0x00ffffff)].car)))));

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

  case 	0x05000000:
  case 	0x06000000:
    if (bind_args(			(Cons[		(fun & 		0x00ffffff)].car), args))
      result = dolist(			(Cons[		(fun & 		0x00ffffff)].cdr));
    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 0x07000000:
  case 	0x08000000:
    if (check_args(args, 		(Built_In[		(fun & 		0x00ffffff)].args)))
      result = 	((		(Built_In[		(fun & 		0x00ffffff)].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 		0x0a000000:
    					((Ob_List) = make_cons(( Nil), 							     (Ob_List)));
    if (bind_args(			(Cons[		(fun & 		0x00ffffff)].car), args)) {
      result = dolist(			(Cons[		(fun & 		0x00ffffff)].cdr));
      						((Ob_List) = 			(Cons[		(Ob_List & 		0x00ffffff)].cdr));
      							((			(			(Cons[		(Ob_List & 		0x00ffffff)].car))) = make_cons(( 					       make_cons(	0x01000000,  result)), 							     (			(			(Cons[		(Ob_List & 		0x00ffffff)].car)))));
      result = eval(result);
    }
    else {
      result = bad_args("macro in apply");
      						((Ob_List) = 			(Cons[		(Ob_List & 		0x00ffffff)].cdr));
    }
    break;

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

  case 		0x0b000000:
    			(		((Ob_Stack) = make_cons(( Ob_List), 							     (Ob_Stack))), 					 (Ob_List = 			(Cons[		(fun & 		0x00ffffff)].cdr)));
    result = apply(			(Cons[		(fun & 		0x00ffffff)].car), args);
    			((Ob_List = 			(			(Cons[		(Ob_Stack & 		0x00ffffff)].car))), 					 			((Ob_Stack) = 			(Cons[		(Ob_Stack & 		0x00ffffff)].cdr)));
    break;

  default:
    result = bad_args("apply");
    break;
  }
  
  if (result == 	0x01000000)
    result = error("undefined object");
	   
  						((Ob_List) = 			(Cons[		(Ob_List & 		0x00ffffff)].cdr));

/* 
 * Pop back_trace stack.
 */

  			((Back_Trace) = 			(Cons[		(Back_Trace & 		0x00ffffff)].cdr));

  return(result);
}

/*
 * Lisp interface to apply.
 */

object lapply(args)
     object args;
{
  return(apply(						(Cons[		(args & 		0x00ffffff)].car), 						(Cons[		(			(Cons[		(args & 		0x00ffffff)].cdr) & 		0x00ffffff)].car)));
}

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

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

  					((Ob_List) = make_cons(( Nil), 							     (Ob_List)));
  							((			(			(Cons[		(Ob_List & 		0x00ffffff)].car))) = make_cons(( 					       make_cons(	0x01000000,  args)), 							     (			(			(Cons[		(Ob_List & 		0x00ffffff)].car)))));
  							((			(			(Cons[		(Ob_List & 		0x00ffffff)].car))) = make_cons(( 					       make_cons(	0x01000000,  args = evlis(args))), 							     (			(			(Cons[		(Ob_List & 		0x00ffffff)].car)))));
   result = apply(fun, args);  
  						((Ob_List) = 			(Cons[		(Ob_List & 		0x00ffffff)].cdr));
  return(result);
}

/*
 * Lisp interface to funcall.
 */

object lfuncall(args)
     object args;
{
  if ( 		(args & 		0x0f000000) == 		0x04000000)
    return(funcall(						(Cons[		(args & 		0x00ffffff)].car), 			(Cons[		(args & 		0x00ffffff)].cdr)));
  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 ( 		(obj & 		0x0f000000)) {

/*
 * Return a number.
 */

  case 		0x03000000:
    break;

/*
 * Look up an atom binding.
 */

  case 		0x02000000:
    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 		0x04000000:
    {
      object fun = 			(Cons[		(obj & 		0x00ffffff)].car), args = 			(Cons[		(obj & 		0x00ffffff)].cdr), type, funarg, env;

      					((Ob_List) = make_cons(( Nil), 							     (Ob_List)));

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

      while ((loop++ < 		256) &&
	     ((type =  		(fun & 		0x0f000000)) == 		0x02000000 ||
	      type == 		0x04000000))
        							((			(			(Cons[		(Ob_List & 		0x00ffffff)].car))) = make_cons(( 					       make_cons(	0x01000000,  fun = eval(fun))), 							     (			(			(Cons[		(Ob_List & 		0x00ffffff)].car)))));

      switch (type) {

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

      case 	0x05000000:
      case 0x07000000:
								((			(			(Cons[		(Ob_List & 		0x00ffffff)].car))) = make_cons(( 					       make_cons(	0x01000000,  args = evlis(args))), 							     (			(			(Cons[		(Ob_List & 		0x00ffffff)].car)))));

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

      case 	0x06000000:
      case 	0x08000000:
      case 		0x0a000000:
	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 		0x0b000000:
	funarg = fun;
	env = 			(Cons[		(fun & 		0x00ffffff)].cdr);
	fun = 			(Cons[		(fun & 		0x00ffffff)].car);

	if ((type =  		(fun & 		0x0f000000)) == 		0x02000000 ||
	    type == 		0x04000000) {

	  			(		((Ob_Stack) = make_cons(( Ob_List), 							     (Ob_Stack))), 					 (Ob_List = env));
	  					((Ob_List) = make_cons(( Nil), 							     (Ob_List)));

	  while ((loop++ < 		256) &&
		 ((type =  		(fun & 		0x0f000000)) == 		0x02000000 ||
		  type == 		0x04000000))
	    							((			(			(Cons[		(Ob_List & 		0x00ffffff)].car))) = make_cons(( 					       make_cons(	0x01000000,  fun = eval(fun))), 							     (			(			(Cons[		(Ob_List & 		0x00ffffff)].car)))));

	  						((Ob_List) = 			(Cons[		(Ob_List & 		0x00ffffff)].cdr));
	  			((Ob_List = 			(			(Cons[		(Ob_Stack & 		0x00ffffff)].car))), 					 			((Ob_Stack) = 			(Cons[		(Ob_Stack & 		0x00ffffff)].cdr)));

	  funarg = 		(		0x0b000000 | 		( make_cons(fun, env) & 		0x00ffffff));
	  							((			(			(Cons[		(Ob_List & 		0x00ffffff)].car))) = make_cons(( 					       make_cons(	0x01000000,  funarg)), 							     (			(			(Cons[		(Ob_List & 		0x00ffffff)].car)))));
	}

	if (type == 	0x05000000 ||
	    type == 0x07000000)
	   							((			(			(Cons[		(Ob_List & 		0x00ffffff)].car))) = make_cons(( 					       make_cons(	0x01000000,  args = evlis(args))), 							     (			(			(Cons[		(Ob_List & 		0x00ffffff)].car)))));

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

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

      						((Ob_List) = 			(Cons[		(Ob_List & 		0x00ffffff)].cdr));
    }
    break;

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

  if (obj == 	0x01000000)
    obj = error("undefined object");

  return(obj);
}

/*
 * Lisp interface to eval.
 */

object leval(args)
     object args;
{
  return(eval(						(Cons[		(args & 		0x00ffffff)].car)));
}

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

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

  while ( 		(args & 		0x0f000000) == 		0x04000000) {
    result = eval(						(Cons[		(args & 		0x00ffffff)].car));
    args = 			(Cons[		(args & 		0x00ffffff)].cdr);
  }

  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 ( 		(args & 		0x0f000000) == 		0x04000000) {

/*
 * Check for proper form.
 */

    if ( 		(						(Cons[		(args & 		0x00ffffff)].car) & 		0x0f000000) != 		0x04000000 ||
	( 		(			(Cons[		(						(Cons[		(args & 		0x00ffffff)].car) & 		0x00ffffff)].cdr) & 		0x0f000000) != 		0x04000000 &&
	 			(Cons[		(						(Cons[		(args & 		0x00ffffff)].car) & 		0x00ffffff)].cdr) != Nil))
      return(bad_args("cond"));

/*
 * Test the condition.
 */

    result = eval(			(Cons[		(						(Cons[		(args & 		0x00ffffff)].car) & 		0x00ffffff)].car));
    if (result == Nil) {
      args = 			(Cons[		(args & 		0x00ffffff)].cdr);
      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[		(						(Cons[		(args & 		0x00ffffff)].car) & 		0x00ffffff)].cdr) != Nil)
      result = dolist(			(Cons[		(						(Cons[		(args & 		0x00ffffff)].car) & 		0x00ffffff)].cdr));      
    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 ( 		(args & 		0x0f000000) == 		0x04000000)
    return(		(	0x05000000 | 		( args & 		0x00ffffff)));

  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 ( 		(args & 		0x0f000000) == 		0x04000000)
    return(		(	0x06000000 | 		( args & 		0x00ffffff)));

  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 ( 		(args & 		0x0f000000) == 		0x04000000)
    return(		(		0x0a000000 | 		( args & 		0x00ffffff)));
  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(		(		0x0b000000 | 		( make_cons(						(Cons[		(args & 		0x00ffffff)].car), Ob_List) & 		0x00ffffff)));
}