/*
 * Lisp utilities
 * Don Hopkins
 */

#include "lisp.h"

/*
 * Return a pointer to either the current binding of the atom var, or
 * its value field if there is no binding on Ob_List. 
 */

object *find_variable(var)
     object var;
{
  object obj, frame;

  if (Object_Type(var) != atom_object) {
    printcr(var);
    error("Non atom given to find_variable");
  }

  for (frame = Ob_List;
       Object_Type(frame) == cons_object;
       frame = Cons_Cdr(frame))

    for (obj = Cons_Car(frame);
	 Object_Type(obj) == cons_object;
	 obj = Cons_Cdr(obj))

      if (Object_Type(Cons_Car(obj)) == cons_object &&
	  Cons_Car(Cons_Car(obj)) == var)

	return(&Cons_Cdr(Cons_Car(obj)));

  return(&Atom_Value(var));
}

/*
 * Push an input or output stream. Stackp is a pointer to the stack to
 * save the file name and old stream on. Streamp is a pointer to the
 * stream variable holding the file pointer. Obj is an atom whose name
 * is used as a file name. Mode is the mode to open the file in.
 * Returns the file name of the stream.
 */

object push_stream(stackp, streamp, obj, mode)
     object *stackp;
     FILE **streamp;
     object obj;
     char *mode;
{
  FILE *fp;

  if (Object_Type(obj) == atom_object) {

    if ((fp = fopen(Atom_Name(obj), mode)) > 0) {

      O_Push(*stackp,
	     Set_Type(stream_object, make_cons(obj, (object)*streamp)));
      *streamp = fp;

      return(obj);
    }

    perror("push_stream");
    return(error("Error opening stream"));
  }

  return(bad_args("push_stream"));
}
     
/* 
 * Pop an input or output stream. Stackp is a pointer to the stack
 * that the file name and old stream are saved on. Streamp is a
 * pointer to the variable holding the file pointer. Returns the file
 * name of the stream closed, or Nil if the stack is empty. 
 */

object pop_stream(stackp, streamp)
     object *stackp;
     FILE **streamp;
{
  object obj = Nil;

  if (*stackp != Nil) {
    obj = O_Top(*stackp);
    fclose(*streamp);
    *streamp = (FILE *)Cons_Cdr(obj);
    obj = Cons_Car(obj);
    O_Pop(*stackp);
  }

  return(obj);
}

/*
 * Push the output stream to a file. Open the file in append mode,
 * creating the file if it does not exist. Output will go to that
 * file, which will remain open until a corresponding pop-output is
 * done. Returns the file name of the output stream.
 */

object push_output(args)
     object args;
{
  if (Object_Type(ARG1) == atom_object)
    return(push_stream(&Output_Stack, &Output_File, ARG1, "a+"));

  return(bad_args("push_output"));
}

/*
 * Push the input stream to a file. Open the file in read mode. Input
 * will come from that file, which will remain open until a
 * corresponding pop-input is done, or an end of file is reached.
 * Returns the file name of the input stream. 
 */

object push_input(args)
     object args;
{
  if (Object_Type(ARG1) == atom_object)
    return(push_stream(&Input_Stack, &Input_File, ARG1, "r"));

  return(bad_args("push_input"));
}

/*
 * Pop the output stream. Returns the file name of the output stream
 * closed, or Nil if the stack is empty. 
 */

object pop_output(args)
     object args;
{
  return(pop_stream(&Output_Stack, &Output_File));
}

/*
 * Pop the input stream. Returns the file name of the input stream
 * closed, or Nil if the stack is empty. 
 */

object pop_input(args)
     object args;
{
  return(pop_stream(&Input_Stack, &Input_File));
}

/*
 * Compare two lisp objects. If they are different types, return Nil.
 * If they are numbers, and within ZERO_THRESHOLD if each other,
 * return T. If they are the same object, then return T. Otherwise,
 * return Nil.
 */

object eq(args)
     object args;
{
  int equality;
  double fabs();

  if (Object_Type(ARG1) != Object_Type(ARG2))
    equality = 0;

  else
    if (Object_Type(ARG1) == number_object)
      equality = (fabs(Number_Value(ARG1) -
		       Number_Value(ARG2)) <= ZERO_THRESHOLD);
    else
      equality = (Object_Index(ARG1) == Object_Index(ARG2));
  
  if (equality)
    return(T);

  return(Nil);
}

/*
 * Take the two arguments car and cdr, and return a cons node, with
 * the specified car and cdr fields.
 */

object lcons(args)
     object args;
{
  return(make_cons(ARG1, ARG2));
}

/*
 * Take one argument which must be a cons, and return its car field.
 */

object lcar(args)
     object args;
{
  if (Object_Type(ARG1) == cons_object)
    return(Cons_Car(ARG1));

  return(bad_args("car"));
}

/*
 * Take one argument which must be a cons, and return its cdr field.
 */

object lcdr(args)
     object args;
{
  if (Object_Type(ARG1) == cons_object)
    return(Cons_Cdr(ARG1));

  return(bad_args("cdr"));
}

/*
 * Return T if the one argument is an atom or a number. Otherwise,
 * return Nil.
 */

object latom(args)
     object args;
{
  if (Object_Type(ARG1) == number_object ||
      Object_Type(ARG1) == atom_object)
    return(T);

  return(Nil);
}

/*
 * Return a list of any length of the evaluated arguments. 
 */

object list(args)
     object args;
{
  return(args);
}

/*
 * Return the ordinal type number of the one argument. 
 */

object type(args)
     object args;
{
  return(make_number((double)Type_Ord(ARG1)));
}

/*
 * Set the bindings or values of atoms. Take an even number of
 * arguments, the first of each pair being an atom whose current
 * binding or value is to be set, and the second being an expression
 * to evaluate and set the atom to. Return the value that the last
 * atom was set to. 
 */

object setq(args)
     object args;
{
  object obj, *target;

  if (Object_Type(args) != cons_object)
    return(bad_args("setq"));

  while (Object_Type(args) == cons_object &&
	 Object_Type(Cons_Cdr(args)) == cons_object) {

    if (Object_Type(ARG1) != atom_object)
      return(bad_args("setq"));

    target = find_variable(ARG1);
    *target = obj = eval(ARG2);

    args = Cons_Cdr(Cons_Cdr(args));
  }

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

  return(bad_args("setq"));
}

/*
 * Return the one unevaluated argument. 
 */

object quote(args)
     object args;
{
  return(ARG1);
}

/*
 * Evaluate the expressions in a list sequentially until one evals to
 * Nil, or the end of the list is reached. If one evals to Nil, don't
 * evaluate the rest of the list, and return Nil. If the end of the
 * list is reached first, return T.
 */

object and(args)
     object args;
{
  while (Object_Type(args) == cons_object)

    if (eval(ARG1) == Nil)
      return(Nil);

    else
      args = Cons_Cdr(args);

  if (args == Nil)
    return(T);

  return(bad_args("and"));
}

/*
 * Evaluate the expressions in a list sequentially until one evals to
 * non-Nil, or the end of the list is reached. If one evals to
 * non-Nil, don't evaluate the rest of the list, and return T. If the
 * end of the list is reached first, return Nil.
 */

object or(args)
     object args;
{
  while (Object_Type(args) == cons_object)

    if (eval(ARG1) != Nil)
      return(T);

    else
      args = Cons_Cdr(args);

  if (args == Nil)
    return(Nil);

  return(bad_args("or"));
}

/*
 * Explode an atom into a list of its characters.
 */

object explode(args)
     object args;
{
  object head = Nil, tail = Nil;
  char *name, newname[4];

  if (Object_Type(ARG1) != atom_object)
    return(error("Non atomic argument to explode"));

  name = Atom_Name(ARG1);
  
  if (*name == '\0')
    return(Nil);

  Ob_Push();

  Ob_Save(head = tail = make_cons(Nil, Nil));

  while (*name != '\0') {
    newname[0] = *name;
    newname[1] = '\0';
    Cons_Car(tail) = make_atom(newname);
    if (*(++name) != '\0') {
      Cons_Cdr(tail) = make_cons(Nil, Nil);
      tail = Cons_Cdr(tail);
    }
  }
  Ob_Pop();
  return(head);
}

/*
 * Given a list of atoms, returns an atom that is the concatination of
 * the atoms in the list.
 */

object implode(args)
     object args;
{
  object obj;
  char *newname;
  int len = 0;

  if (Object_Type(ARG1) != cons_object)
    return(error("Arg to implode not a list."));

  for (obj = ARG1; obj != Nil; obj = Cons_Cdr(obj)) {
    if (Object_Type(Cons_Car(obj)) != atom_object)
      return(error("Non atomic element in list given to implode"));
    len += strlen(Atom_Name(Cons_Car(obj)));
  }

  newname = (char *)malloc(len+1);
  newname[0] = '\0';
  for (obj = ARG1; obj != Nil; obj = Cons_Cdr(obj)) {
    strcat(newname, Atom_Name(Cons_Car(obj)));
  }

  obj = make_atom(newname);
  free(newname);
  return(obj);
}