#include "os.h"
#include <setjmp.h>
#include "y.tab.h"
#include "lnode.h"
#include "interpret.h"
#include "config.h"
#include "object.h"
#include "wiz_list.h"
#include "regexp.h"

#define DEBUG_EXECUTION (d_flag)
#define ALLOC_CHUNK 50


/* comm1.c */
extern void add_message(char *fmt, ...);

/* simulate.c */
extern struct value *find_value(struct lnode_variable *p);
extern struct lnode_var_def *find_status(char *str, int must_find);
extern struct object *previous_ob;
extern struct value *call_indirect(int fun, ...);
extern void print_local_commands(void);
extern void fatal(char *fmt, ...);
extern int num_error;
extern void error(char *fmt, ...);
extern int transfer_object(struct object *ob, struct object *to);
extern struct object *find_object (char *str);

/* main.c */
extern int d_flag;
extern void *xalloc(int size);
extern char *string_copy(char *str);
extern void debug_message(char *a, ...);
extern void debug_message_value(struct value *v);

/* swap.c */
extern int swap(struct object *ob);
extern void load_ob_from_swap(struct object *ob);

/* object.c */
extern int free_object(struct object *ob, char *from);
extern void add_ref(struct object *ob, char *from);

/* lexical.l */
extern int current_line, eval_cost;


/*
 * This variable is set to true when return is called inside a function.
 */
static int stop_function;

/*
 * The only reason that the long jump data is in a struct, is that
 * it will be easy to copy. The copy is done so we can stack up
 * several return contexts, and pop back them.
 */
struct context {
  jmp_buf a;
  int valid;
};

/*
 * This is used for 'break' in while-statements.
 */
static struct context break_context;

static struct value **current_local_names;


#ifdef TRACE
struct trace {
  char *function_name;
  char *object_name;
  char *command_name;
  int line;
};

#define MAX_TRACE   100
struct trace trace_back[MAX_TRACE];
int trace_depth = 0, worst_depth;
#endif /* TRACE */

static struct value *return_value;     /* Here is a value when "return". */
static struct value *current_argument; /* Arguments to current function */

static struct value *free_value_list;
static struct value *alloced_value_list;
static int num_alloc;
int tot_alloc_value;

/* interpret.c */
static struct value *make_string(char *str);
static struct value *make_number(int n);
static void assign(struct lnode_number *p, struct value *v);
static struct value *print_expr_list (struct lnode *p);
static struct value *print_expr (struct lnode *p);
static struct value *get_one_expr (struct lnode **pp, char *from);
static struct value *inter_sscanf (struct lnode *l);

void free_all_values(void);
int count_value_ref(struct object *ob);
struct value *alloc_value(void);
struct value *apply(char *fun, struct object *ob, struct value *arg);
void call_function(struct lnode_def *pr);


/*
 * The 'eval' flag is true if the function is supposed to be evaluated,
 * not printed.
 */
static struct value *make_string (char *str)
{
  struct value *ret = alloc_value ();

  ret->type = T_STRING;
  ret->u.string = string_copy (str);
  return ret;
}

static struct value *make_number (int n)
{
  struct value *ret = alloc_value ();

  ret->type = T_NUMBER;
  ret->u.number = n;
  return ret;
}

/*
 * Assign a value to a variable or argument.
 */
static void assign (struct lnode_number *p, struct value *v)
{
  if (p->type == F_LOCAL_NAME) {
    struct value *l;
    if (v == 0) {
      current_local_names[p->number] = &const0;
      return;
    }
    l = alloc_value ();
    current_local_names[p->number] = l;
    l->type = v->type;
    l->u = v->u;
    if (l->type == T_STRING)
      l->u.string = string_copy (v->u.string);
    else if (l->type == T_OBJECT)
      add_ref (l->u.ob, "ass to loc var");
    return;
  }
  if (p->type == F_ARGUMENT) {  /* Is it an argument ? */
    if (v == 0) {
      current_argument = &const0;
      return;
    }
    current_argument = alloc_value ();
    current_argument->type = v->type;
    current_argument->u = v->u;
    if (v->type == T_STRING)
      current_argument->u.string = string_copy (v->u.string);
    else if (v->type == T_OBJECT)
      add_ref (v->u.ob, "ass to arg");
  } else {
    struct value *dest = find_value ((struct lnode_variable *) p);
    if (dest->type == T_STRING)
      free (dest->u.string);
    else if (dest->type == T_OBJECT)
      free_object (dest->u.ob, "ass to var");
    if (v == 0) {
      dest->type = T_NUMBER;
      dest->u.number = 0;
      return;
    }
    dest->type = v->type;
    dest->u = v->u;
    if (v->type == T_STRING)
      dest->u.string = string_copy (v->u.string);
    else if (v->type == T_OBJECT)
      add_ref (dest->u.ob, "ass to var");
  }
}

/*
 * Free all values previously allocated.
 */
void free_all_values (void)
{
  for (num_alloc = 0; alloced_value_list; num_alloc++) {
    struct value *tmp;
    tmp = alloced_value_list;
    alloced_value_list = alloced_value_list->next;
    if (tmp->type == T_STRING) {
      free (tmp->u.string);
      tmp->u.string = (char *) 1;       /* Just an illegal value */
    }
    /* The following is a major kludge by Drax.  Dbx(1) told me in a
       core analysis that this routine passed a null pointer to
       free_object.  Therefore, we should just check to make sure
       that the pointer does in fact have a value. The following code
       used to be
       else if (tmp->type == T_OBJECT) {
       free_object(tmp->u.ob, "free_all_values");
       tmp->u.ob = 0;
       }
       but has been changed to: */
    else if ((tmp->type == T_OBJECT) && tmp->u.ob) {
      free_object (tmp->u.ob, "free_all_values");
      tmp->u.ob = 0;
    }
    tmp->next = free_value_list;
    free_value_list = tmp;
  }
#if 0
  if (d_flag)
    debug_message ("%d alloced values.\n", num_alloc);
#endif
}

int count_value_ref (struct object *ob)
{
  int tot = 0;
  struct value *v;
  for (v = alloced_value_list; v; v = v->next) {
    if (v->type == T_OBJECT && v->u.ob == ob)
      tot++;
  }
  return tot;
}

struct value *alloc_value (void)
{
  register struct value *tmp;

  if (free_value_list == 0) {
    int i;
    tmp = (struct value *) xalloc (ALLOC_CHUNK * sizeof (struct value));
    tot_alloc_value += ALLOC_CHUNK;
    for (i = 0; i < ALLOC_CHUNK - 1; i++)
      tmp[i].next = &tmp[i + 1];
    tmp[ALLOC_CHUNK - 1].next = 0;
    free_value_list = tmp;
  }
  tmp = free_value_list;
  free_value_list = free_value_list->next;
  tmp->next = alloced_value_list;
  alloced_value_list = tmp;
  /*
   * We preset the type to number, to ensure that no one forgets to
   * use the value, as it would have an old, undefined type when arriving
   * to free_all_values().
   */
  tmp->type = T_NUMBER;
  return tmp;
}

/*
 * Print or interpret a function.
 * Set up the long jump context, to enable the 'return' statment.
 */

static struct value *print_function (struct lnode_def *p)
{
  struct value **save_current_local_names = current_local_names;
  struct value *new_local_names[MAX_LOCAL];
  int i;
#ifdef TRACE
  int save_trace_depth = trace_depth;
  char *get_current_object_name (), *get_command_giver_name ();
  if (trace_depth < MAX_TRACE) {
    trace_back[trace_depth].function_name = p->name;
    trace_back[trace_depth].object_name = get_current_object_name ();
    trace_back[trace_depth].command_name = get_command_giver_name ();
    trace_back[trace_depth].line = -1;
    trace_depth++;
  } else {
    error ("Recursion is too deep to trace.\n");
  }
#endif

  if (p->type == F_IDENTIFIER) {
    if (d_flag) {
#ifdef TRACE
      debug_message ("%s: ", get_current_object_name ());
#endif
      debug_message ("%s(", p->name);
      debug_message_value (current_argument);
      debug_message (")\n");
    }
    for (i = 0; i < p->num_var; i++) {
      new_local_names[i] = &const0;
    }
    current_local_names = new_local_names;
    return_value = &const0;
    (void) print_expr (p->block);
    stop_function = 0;
#ifdef TRACE
    if (trace_depth > worst_depth) {
      fprintf (stderr, "New worst trace depth: %d\n", trace_depth);
      worst_depth = trace_depth;
    }
    trace_depth = save_trace_depth;
#endif
    current_local_names = save_current_local_names;
    return return_value;
  }
  fatal ("Illegal type %d\n", p->type);
  return 0;
}

static struct value *print_expr (struct lnode *p)
{
  struct value *ret = &const0;
  struct value *arg, *arg1, *arg2;
  struct lnode_block *lb;
  char *block;
  int i;

  if (const1.u.number != 1)
    fatal ("Change in constant 1\n");
  if (const0.u.number != 0)
    fatal ("Change in constant 0\n");
  eval_cost++;
  if (current_object->wl)
    current_object->wl->cost++;
  if (eval_cost > MAX_COST) {
    eval_cost = 0;
    error ("Too long evaluation. Execution aborted.\n");
  }
  if (p == 0) {
    fatal ("print_expr called with null pointer.\n");
    WIN32CLEANUP
    abort ();
  }
  current_line = p->line & ~L_MASK;
  switch (p->type) {
  default:
    fatal ("UNKNOWN(%d)", p->type);
    break;
  case F_CLONE_OBJECT:
    if (DEBUG_EXECUTION)
      debug_message ("clone_object()\n");
    arg1 = print_expr_list (p->a1);
    if (arg1 == 0 || arg1->type != T_STRING) {
      error ("Illegal type argument to clone_object()\n");
      WIN32CLEANUP
      exit (1);
    }
    ret = call_indirect (F_CLONE_OBJECT, arg1->u.string);
    break;
  case F_FUNCTION:
    {
      struct lnode_funcall *f = (struct lnode_funcall *) p;
      if (DEBUG_EXECUTION)
        debug_message ("%s()\n", f->name);
#ifdef TRACE
      trace_back[trace_depth - 1].line = f->line & ~L_MASK;
#endif
      if (p->a1)
        arg = print_expr (p->a1);
      else
        arg = 0;
      ret = call_indirect (F_FUNCTION, f->name, arg);
      break;
    }
  case F_SAVE_OBJECT:
    if (DEBUG_EXECUTION)
      debug_message ("save_object()\n");
    arg = print_expr_list (p->a1);
    if (arg == 0 || arg->type != T_STRING)
      error ("Bad argument to save_object().\n");
    ret = call_indirect (F_SAVE_OBJECT, arg->u.string);
    break;
  case F_FIND_OBJECT:
    if (DEBUG_EXECUTION)
      debug_message ("find_object()");
    arg = print_expr_list (p->a1);
    if (arg == 0 || arg->type != T_STRING)
      error ("Bad argument to find_object().\n");
    ret = call_indirect (F_FIND_OBJECT, arg->u.string);
    break;
  case F_FIND_LIVING:
    if (DEBUG_EXECUTION)
      debug_message ("find_living()");
    arg = print_expr_list (p->a1);
    if (arg == 0 || arg->type != T_STRING)
      error ("Bad argument to find_living().\n");
    ret = call_indirect (F_FIND_LIVING, arg->u.string);
    break;
  case F_FIND_PLAYER:
    if (DEBUG_EXECUTION)
      debug_message ("find_player()");
    arg = print_expr_list (p->a1);
    if (arg == 0 || arg->type != T_STRING)
      error ("Bad argument to find_player().\n");
    ret = call_indirect (F_FIND_PLAYER, arg->u.string);
    break;
  case F_TELL_OBJECT:
    if (DEBUG_EXECUTION)
      debug_message ("tell_object()\n");
    {
      struct value *who, *what;
      struct lnode *l = p->a1;

      who = get_one_expr (&l, "tell_object()");
      what = get_one_expr (&l, "tell_object()");
      if (who == 0 || who->type != T_OBJECT)
        error ("tell_object() first argument not an object.\n");
      if (what == 0 || what->type != T_STRING)
        error ("tell_object() second argument not a string.\n");
      (void) call_indirect (F_TELL_OBJECT, who->u.ob, what->u.string);
    }
    break;
  case F_RESTORE_OBJECT:
    if (DEBUG_EXECUTION)
      debug_message ("restore_object()\n");
    arg = print_expr_list (p->a1);
    if (arg == 0 || arg->type != T_STRING)
      error ("Bad argument to restore_object().\n");
    ret = call_indirect (F_RESTORE_OBJECT, arg->u.string);
    break;
  case F_THIS_PLAYER:
    if (DEBUG_EXECUTION)
      debug_message ("this_player()\n");
    ret = call_indirect (F_THIS_PLAYER);
    break;
  case F_FIRST_INVENTORY:
    if (DEBUG_EXECUTION)
      debug_message ("first_inventory()\n");
    arg = print_expr_list (p->a1);
    if (arg == 0 || (arg->type != T_STRING && arg->type != T_OBJECT))
      error ("Bad type argument to first_inventory()\n");
    ret = call_indirect (F_FIRST_INVENTORY, arg);
    break;
  case F_LIVING:
    if (DEBUG_EXECUTION)
      debug_message ("living()\n");
    arg = print_expr_list (p->a1);
    if (arg == 0 || arg->type != T_OBJECT)
      error ("Bad type argument to living()\n");
    ret = call_indirect (F_LIVING, arg->u.ob);
    break;
  case F_SHUTDOWN:
    if (DEBUG_EXECUTION)
      debug_message ("shutdown()\n");
    (void) call_indirect (F_SHUTDOWN);
    return 0;
  case F_NEXT_INVENTORY:
    if (DEBUG_EXECUTION)
      debug_message ("next_inventory()\n");
    arg = print_expr_list (p->a1);
    if (arg == 0 || (arg->type != T_STRING && arg->type != T_OBJECT))
      error ("Bad type argument to next_inventory()\n");
    ret = call_indirect (F_NEXT_INVENTORY, arg);
    break;
  case F_ENVIRONMENT:
    if (DEBUG_EXECUTION)
      debug_message ("environment()\n");
    arg = print_expr_list (p->a1);
    if (arg && arg->type != T_STRING && arg->type != T_OBJECT)
      error ("Wrong type to optional arg to environment()\n");
    ret = call_indirect (F_ENVIRONMENT, arg);
    break;
  case F_THIS_OBJECT:
    if (DEBUG_EXECUTION)
      debug_message ("this_object()\n");
    ret = call_indirect (F_THIS_OBJECT);
    break;
  case F_PEOPLE:
    if (DEBUG_EXECUTION)
      debug_message ("people()\n");
    (void) call_indirect (F_PEOPLE);
    return 0;
  case F_LOCALCMD:
    if (DEBUG_EXECUTION)
      debug_message ("localcmd()\n");
    print_local_commands ();
    return 0;
  case F_SWAP:
    if (DEBUG_EXECUTION)
      debug_message ("swap()");
    arg = print_expr_list (p->a1);
    if (arg == 0 || arg->type != T_OBJECT)
      error ("bad argument to swap()\n");
    swap (arg->u.ob);
    return 0;
  case F_TIME:
    if (DEBUG_EXECUTION)
      debug_message ("time()");
    ret = make_number (time (0l));
    break;
  case F_WIZLIST:
    if (DEBUG_EXECUTION)
      debug_message ("wizlist()\n");
    (void) call_indirect (F_WIZLIST);
    return 0;
  case F_TRANSFER:
    if (DEBUG_EXECUTION)
      debug_message ("transfer()\n");
    {
      struct object *dest;
      struct lnode *l = p->a1;
      int i;
      arg = get_one_expr (&l, "transfer");
      if (arg->type != T_OBJECT)
        error ("Bad type of artgument 1 to transfer()\n");
      arg1 = get_one_expr (&l, "transfer");
      if (arg1->type != T_OBJECT && arg1->type != T_STRING)
        error ("Bad type of artgument 2 to transfer()\n");
      if (arg1->type == T_STRING) {
        dest = find_object (arg1->u.string);
        if (dest == 0)
          error ("Object not found.\n");
      } else {
        dest = arg1->u.ob;
      }
      i = transfer_object (arg->u.ob, dest);
      if (i == 0)
        ret = &const0;          /* Usually this */
      else if (i == 1)
        ret = &const1;
      else
        ret = make_number (i);
    }
    break;
  case F_ADD_WORTH:
    if (DEBUG_EXECUTION)
      debug_message ("add_worth()\n");
    {
      struct lnode *l = p->a1;
      arg = get_one_expr (&l, "add_worth");
      if (arg->type != T_NUMBER)
        error ("Bad type of argument 1 to add_worth()\n");
      arg1 = get_one_expr (&l, 0);
      if (arg1 != 0 && arg1->type != T_OBJECT)
        error ("Bad type of argument 2 to add_worth()\n");
      if (strncmp (current_object->name, "obj/", 4) != 0 &&
        strncmp (current_object->name, "room/", 5) != 0)
        error ("Illegal call of add_worth.\n");
      if (arg1) {
        if (arg1->u.ob->wl)
          arg1->u.ob->wl->total_worth += arg->u.number;
        return 0;
      }
      if (previous_ob == 0)
        return 0;
      if (previous_ob->wl)
        previous_ob->wl->total_worth += arg->u.number;
    }
    return 0;
  case F_ADD:
    if (DEBUG_EXECUTION)
      debug_message ("+()\n");
    ret = alloc_value ();
    arg1 = print_expr (p->a1);
    arg2 = print_expr (p->a2);
    if (arg1 == 0 || arg2 == 0)
      error ("Bad type on arg to '+'\n");
    if (arg1->type == T_STRING && arg2->type == T_STRING) {
      ret->u.string = xalloc (strlen (arg1->u.string) +
        strlen (arg2->u.string) + 1);
      (void) strcpy (ret->u.string, arg1->u.string);
      (void) strcat (ret->u.string, arg2->u.string);
      ret->type = T_STRING;
      break;
    }
    if (arg1->type == T_NUMBER && arg2->type == T_STRING) {
      char buff[20];
      sprintf (buff, "%d", arg1->u.number);
      ret->type = T_STRING;
      ret->u.string = xalloc (strlen (arg2->u.string) + strlen (buff) + 1);
      strcpy (ret->u.string, buff);
      strcat (ret->u.string, arg2->u.string);
      break;
    }
    if (arg2->type == T_NUMBER && arg1->type == T_STRING) {
      char buff[20];
      sprintf (buff, "%d", arg2->u.number);
      ret->type = T_STRING;
      ret->u.string = xalloc (strlen (arg1->u.string) + strlen (buff) + 1);
      strcpy (ret->u.string, arg1->u.string);
      strcat (ret->u.string, buff);
      break;
    }
    if (arg1->type == T_NUMBER && arg2->type == T_NUMBER) {
      ret->u.number = arg1->u.number + arg2->u.number;
      ret->type = T_NUMBER;
      break;
    }
    error ("Bad type of arg to '+'\n");
    WIN32CLEANUP
    exit (1);
  case F_SUBTRACT:
    if (DEBUG_EXECUTION)
      debug_message ("-()\n");
    arg1 = print_expr (p->a1);
    arg2 = print_expr (p->a2);
    if ((arg1 && arg1->type != T_NUMBER) || (arg2 && arg2->type != T_NUMBER)) {
      error ("Bad type on arg to '-'\n");
      WIN32CLEANUP
      exit (1);
    }
    ret = make_number (arg1->u.number - arg2->u.number);
    break;
  case F_AND:
    if (DEBUG_EXECUTION)
      debug_message ("and()\n");
    arg1 = print_expr (p->a1);
    if (arg1 == 0 || (arg1->type == T_NUMBER && arg1->u.number == 0))
      break;
    arg2 = print_expr (p->a2);
    if (arg2 == 0 || (arg2->type == T_NUMBER && arg2->u.number == 0))
      break;
    ret = &const1;
    break;
  case F_OR:
    if (DEBUG_EXECUTION)
      debug_message ("or()\n");
    ret = print_expr (p->a1);
    if (ret && ((ret->type == T_NUMBER && ret->u.number != 0) ||
        ret->type != T_NUMBER))
      break;
    ret = print_expr (p->a2);
    if (ret && ((ret->type == T_NUMBER && ret->u.number != 0) ||
        ret->type != T_NUMBER))
      break;
    ret = &const0;
    break;
  case F_MULTIPLY:
    if (DEBUG_EXECUTION)
      debug_message ("mult()\n");
    arg1 = print_expr (p->a1);
    arg2 = print_expr (p->a2);
    if ((arg1 && arg1->type != T_NUMBER) || (arg2 && arg2->type != T_NUMBER)) {
      error ("Bad type on arg to '*'\n");
      WIN32CLEANUP
      exit (1);
    }
    ret = make_number (arg1->u.number * arg2->u.number);
    break;
  case F_DIVIDE:
    if (DEBUG_EXECUTION)
      debug_message ("div()\n");
    arg1 = print_expr (p->a1);
    arg2 = print_expr (p->a2);
    if ((!arg1 || arg1->type != T_NUMBER || !arg2 || arg2->type != T_NUMBER)) {
      error ("Bad type on arg to '/'\n");
      WIN32CLEANUP
      exit (1);
    }
    if (arg2->u.number == 0)
      error ("Division by zero.\n");
    ret = make_number (arg1->u.number / arg2->u.number);
    break;
  case F_MOD:
    if (DEBUG_EXECUTION)
      debug_message ("mod()\n");
    arg1 = print_expr (p->a1);
    arg2 = print_expr (p->a2);
    if (arg1->type != T_NUMBER || arg2->type != T_NUMBER) {
      error ("Bad type on arg to %%\n");
      WIN32CLEANUP
      exit (1);
    }
    if (arg2->u.number == 0)
      error ("Modulus by zero.\n");
    ret = make_number (arg1->u.number % arg2->u.number);
    break;
  case F_MOD_EQ:
    if (DEBUG_EXECUTION)
      debug_message ("%%=\n");
    {
      struct value *v;
      ret = print_expr (p->a2);
      if (ret == 0 || ret->type != T_NUMBER)
        error ("Bad type to %%=.\n");
      v = print_expr (p->a1);
      if (v == 0 || v->type != T_NUMBER)
        error ("Bad type to %%=");
      if (ret->u.number == 0)
        error ("Modulus by zero.");
      assign ((struct lnode_number *) (p->a1),
        make_number (v->u.number % ret->u.number));
    }
    return 0;
  case F_GT:
    if (DEBUG_EXECUTION)
      debug_message ("gt()\n");
    arg1 = print_expr (p->a1);
    arg2 = print_expr (p->a2);
    if ((!arg1 || arg1->type != T_NUMBER || !arg2 || arg2->type != T_NUMBER)) {
      error ("Bad type on arg to '>'\n");
      WIN32CLEANUP
      exit (1);
    }
    if (arg1->u.number > arg2->u.number)
      ret = &const1;
    else
      ret = &const0;
    break;
  case F_GE:
    if (DEBUG_EXECUTION)
      debug_message ("GE()\n");
    arg1 = print_expr (p->a1);
    arg2 = print_expr (p->a2);
    if ((!arg1 || arg1->type != T_NUMBER || !arg2 || arg2->type != T_NUMBER)) {
      error ("Bad type on arg to '>='\n");
      WIN32CLEANUP
      exit (1);
    }
    if (arg1->u.number >= arg2->u.number)
      ret = &const1;
    else
      ret = &const0;
    break;
  case F_LT:
    if (DEBUG_EXECUTION)
      debug_message ("lt()\n");
    arg1 = print_expr (p->a1);
    arg2 = print_expr (p->a2);
    if ((!arg1 || arg1->type != T_NUMBER || !arg2 || arg2->type != T_NUMBER)) {
      error ("Bad type on arg to '<'\n");
      WIN32CLEANUP
      exit (1);
    }
    if (arg1->u.number < arg2->u.number)
      ret = &const1;
    else
      ret = &const0;
    break;
  case F_LE:
    if (DEBUG_EXECUTION)
      debug_message ("le()\n");
    arg1 = print_expr (p->a1);
    arg2 = print_expr (p->a2);
    if ((!arg1 || arg1->type != T_NUMBER || !arg2 || arg2->type != T_NUMBER)) {
      error ("Bad type on arg to '<='\n");
      WIN32CLEANUP
      exit (1);
    }
    if (arg1->u.number <= arg2->u.number)
      ret = &const1;
    else
      ret = &const0;
    break;
  case F_EQ:
    if (DEBUG_EXECUTION)
      debug_message ("eq()\n");
    arg1 = print_expr (p->a1);
    arg2 = print_expr (p->a2);
    if ((arg1 == 0 && arg2 != 0) || (arg1 != 0 && arg2 == 0))
      break;
    ret = alloc_value ();
    ret->type = T_NUMBER;
    if (arg1 == 0 && arg2 == 0) {
      ret->u.number = 1;
    } else if (arg1->type == T_NUMBER && arg2->type == T_NUMBER) {
      ret->u.number = arg1->u.number == arg2->u.number;
    } else if (arg1->type == T_STRING && arg2->type == T_STRING) {
      ret->u.number = !strcmp (arg1->u.string, arg2->u.string);
    } else if (arg1->type == T_OBJECT && arg2->type == T_OBJECT) {
      ret->u.number = arg1->u.ob == arg2->u.ob;
    } else
      ret->u.number = 0;
    break;
  case F_NE:
    if (DEBUG_EXECUTION)
      debug_message ("ne()\n");
    arg1 = print_expr (p->a1);
    arg2 = print_expr (p->a2);
    if (arg1 == 0) {
      if (arg2 == 0)
        break;
      ret = &const1;
      break;
    }
    if (arg2 == 0) {
      ret = &const1;
      break;
    }
    if (arg1->type != arg2->type) {
      ret = &const1;
      break;
    }
    ret = alloc_value ();
    ret->type = T_NUMBER;
    if (arg1->type == T_NUMBER) {
      ret->u.number = arg1->u.number != arg2->u.number;
    } else if (arg1->type == T_STRING) {
      ret->u.number = strcmp (arg1->u.string, arg2->u.string);
    } else if (arg1->type == T_OBJECT) {
      ret->u.number = arg1->u.ob != arg2->u.ob;
    } else
      ret->u.number = 0;
    break;
  case F_BLOCK:                /* Sequential list of statements. */
    if (DEBUG_EXECUTION)
      debug_message ("block block:\n");
    {
      lb = (struct lnode_block *) p;
      block = lb->block;

      for (i = 0; i < lb->num_nodes && !stop_function; i++) {
        print_expr ((struct lnode *) block);
        block += lnode_size[((struct lnode *) block)->line >> L_SHIFT];
      }
      return 0;
    }
  case F_CONS:                 /* Linked list of statements. */
    if (DEBUG_EXECUTION)
      debug_message ("cons block:\n");
    while (p && !stop_function) {
      (void) print_expr (p->a1);
      p = p->a2;
    }
    if (DEBUG_EXECUTION)
      debug_message ("end block.\n");
    return 0;
  case F_IF:
    if (DEBUG_EXECUTION)
      debug_message ("if()\n");
    ret = print_expr (p->a1);
    if (ret && ((ret->type == T_NUMBER && ret->u.number) ||
        ret->type == T_STRING || ret->type == T_OBJECT))
      (void) print_expr (p->a2);
    else if (p->a3)
      (void) print_expr (p->a3);
    return 0;
  case F_ARGUMENT:
    if (DEBUG_EXECUTION)
      debug_message ("ARG\n");
    if (current_argument == 0) {
      ret = &const0;
      break;
    }
    ret = alloc_value ();
    ret->type = current_argument->type;
    ret->u = current_argument->u;
    if (ret->type == T_STRING)
      ret->u.string = string_copy (current_argument->u.string);
    else if (ret->type == T_OBJECT) {
      if (ret->u.ob->destructed)
        ret = &const0;
      add_ref (current_argument->u.ob, "cp arg");
    }
    break;
  case F_IDENTIFIER:
    if (DEBUG_EXECUTION)
      debug_message ("var(%d)\n", ((struct lnode_number *) p)->number);
    {
      struct value *v = find_value ((struct lnode_variable *) p);
      ret = alloc_value ();
      ret->type = v->type;
      ret->u = v->u;
      if (v->type == T_STRING)
        ret->u.string = string_copy (v->u.string);
      else if (v->type == T_OBJECT) {
        if (v->u.ob->destructed)
          ret = &const0;
        add_ref (v->u.ob, "cp var");
      }
    }
    break;
  case F_RETURN:
    if (DEBUG_EXECUTION)
      debug_message ("return()\n");
    if (p->a1)
      return_value = print_expr (p->a1);
    else
      return_value = &const0;
    stop_function = 1;
    return 0;
  case F_BREAK:
    if (DEBUG_EXECUTION)
      debug_message ("break\n");
    if (!break_context.valid)
      error ("Illegal break statement!\n");
    longjmp (break_context.a, 1);
    fatal ("Return from longjmp\n");
  case F_CONTINUE:
    if (DEBUG_EXECUTION)
      debug_message ("continue\n");
    if (!break_context.valid)
      error ("Illegal continue statement!\n");
    longjmp (break_context.a, 2);
    fatal ("Return from longjmp\n");
  case F_LOG_FILE:
    if (DEBUG_EXECUTION)
      debug_message ("log_file");
    {
      struct lnode *l;
      l = p->a1;
      arg1 = get_one_expr (&l, "log_file");
      arg2 = get_one_expr (&l, "log_file");
      if (arg1 == 0 || arg1->type != T_STRING ||
        arg2 == 0 || arg2->type != T_STRING)
        error ("Bad type argument to log_file().\n");
      (void) call_indirect (F_LOG_FILE, arg1->u.string, arg2->u.string);
    }
    return 0;
  case F_NOT:
    if (DEBUG_EXECUTION)
      debug_message ("not()\n");
    arg = print_expr (p->a1);
    if (arg == 0 || (arg->type == T_NUMBER && arg->u.number == 0))
      ret = &const1;
    else
      ret = &const0;
    break;
  case F_NEGATE:
    if (DEBUG_EXECUTION)
      debug_message ("negate()\n");
    arg = print_expr (p->a1);
    if (arg == 0 || arg->type != T_NUMBER)
      error ("Bad argument to unary '-'\n");
    ret = make_number (-arg->u.number);
    break;
  case F_CALL_OTHER:
    if (DEBUG_EXECUTION)
      debug_message ("call_other()\n");
    {
      struct value *a1, *a2, *a3;
      struct lnode *l = p->a1;
      a1 = get_one_expr (&l, "call_other");
      a2 = get_one_expr (&l, "call_other");
      a3 = get_one_expr (&l, (char *) 0);
      if (a1 == 0 || (a1->type != T_STRING && a1->type != T_OBJECT)) {
        error ("Wrong type arg 1 to call_other()\n");
        WIN32CLEANUP
        exit (1);
      }
      if (a2->type != T_STRING) {
        error ("Wrong type arg 2 to call_other()\n");
        WIN32CLEANUP
        exit (1);
      }
      ret = call_indirect (F_CALL_OTHER, a1, a2->u.string, a3);
    }
    break;
  case F_WRITE:
    if (DEBUG_EXECUTION)
      debug_message ("write()\n");
    arg = print_expr_list (p->a1);
    if (arg == 0)
      error ("Bad argument to write()");
    (void) call_indirect (F_WRITE, arg);
    return 0;
  case F_REGCOMP:
    if (DEBUG_EXECUTION)
      debug_message ("regcomp()\n");
    arg = print_expr_list (p->a1);
    if (arg == 0 || arg->type != T_STRING)
      error ("Bad argument to regcomp()");
    ret = alloc_value ();
    ret->type = T_STRING;
    ret->u.string = (char *) regcomp (arg->u.string);
    debug_message ("regcomp: u.string: %x\n", ret->u.string);
    break;
  case F_REGEXEC:
    if (DEBUG_EXECUTION)
      debug_message ("regexec()");
    {
      struct lnode *l = p->a1;
      arg1 = get_one_expr (&l, "regexec");
      arg2 = get_one_expr (&l, "regexec");
      if (arg1 == 0 || arg2->type != T_STRING)
        error ("Bad arg 1 to regexec.\n");
      if (arg2 == 0 || arg2->type != T_STRING)
        error ("Bad arg 2 to regexec.\n");
      debug_message ("regexec: arg1 u.string: %x\n", arg1->u.string);
      debug_message ("regexec: arg2 u.string: %x\n", arg2->u.string);
      if (regexec ((regexp *) arg1->u.string, arg2->u.string))
        ret = &const1;
      else
        ret = &const0;
    }
    break;
  case F_MOVE_OBJECT:
    if (DEBUG_EXECUTION)
      debug_message ("move_object()\n");
    {
      struct lnode *l = p->a1;
      arg1 = get_one_expr (&l, "move_object");
      arg2 = get_one_expr (&l, "move_object");
      if (arg1 == 0 || (arg1->type != T_STRING && arg1->type != T_OBJECT)) {
        error ("Bad type argument to move_object()\n");
        return 0;
      }
      if (arg2 == 0 || (arg2->type != T_STRING && arg2->type != T_OBJECT)) {
        error ("Bad type argument to move_object()\n");
        return 0;
      }
      (void) call_indirect (F_MOVE_OBJECT, arg1, arg2);
      return 0;
    }
  case F_SNOOP:
    if (DEBUG_EXECUTION)
      debug_message ("snoop()\n");
    {
      struct lnode *l = p->a1;
      arg1 = get_one_expr (&l, (char *) 0);
      if (arg1 && arg1->type != T_OBJECT)
        error ("Bad type arg to snoop.\n");
      (void) call_indirect (F_SNOOP, arg1 ? arg1->u.ob : 0);
      return 0;
    }
  case F_ADD_ACTION:
    if (DEBUG_EXECUTION)
      debug_message ("add_action()\n");
    arg1 = print_expr_list (p->a1);
    if (arg1 == 0 || arg1->type != T_STRING) {
      error ("Bad type argument to add_action()\n");
      WIN32CLEANUP
      exit (1);
    }
    (void) call_indirect (F_ADD_ACTION, arg1->u.string, 0);
    return 0;
  case F_ADD_VERB:
    if (DEBUG_EXECUTION)
      debug_message ("add_verb()\n");
    ret = print_expr_list (p->a1);
    if (ret == 0 || ret->type != T_STRING) {
      error ("Bad type argument to add_verb()\n");
      WIN32CLEANUP
      exit (1);
    }
    (void) call_indirect (F_ADD_VERB, ret->u.string);
    return 0;
  case F_ED:
    if (DEBUG_EXECUTION)
      debug_message ("ed()\n");
    arg = print_expr_list (p->a1);
    if (arg && arg->type != T_STRING)
      error ("Bad argument to ed().\n");
    (void) call_indirect (F_ED, arg ? arg->u.string : 0);
    return 0;
  case F_CRYPT:
    if (DEBUG_EXECUTION)
      debug_message ("crypt()\n");
    arg = print_expr_list (p->a1);
    if (arg == 0 || arg->type != T_STRING)
      error ("Bad type arg to crypt.\n");
    ret = alloc_value ();
    ret->type = T_STRING;
#ifdef sun
    ret->u.string = string_copy (_crypt (arg->u.string, arg->u.string));
#else
    ret->u.string = string_copy (crypt (arg->u.string, arg->u.string));
#endif
    break;
  case F_CREATE_WIZARD:
    if (DEBUG_EXECUTION)
      debug_message ("create_wizard()\n");
    arg = print_expr_list (p->a1);
    if (arg == 0 || arg->type != T_STRING)
      error ("Bad argument to create_wizard().\n");
    ret = call_indirect (F_CREATE_WIZARD, arg->u.string);
    break;
  case F_DESTRUCT:
    if (DEBUG_EXECUTION)
      debug_message ("destruct()\n");
    ret = print_expr_list (p->a1);
    if (ret == 0 || (ret->type != T_STRING && ret->type != T_OBJECT)) {
      error ("Bad type argument to destruct()\n");
      WIN32CLEANUP
      exit (1);
    }
    (void) call_indirect (F_DESTRUCT, ret);
    return 0;
  case F_RANDOM:
    if (DEBUG_EXECUTION)
      debug_message ("random()\n");
    arg = print_expr_list (p->a1);
    if (arg == 0 || arg->type != T_NUMBER)
      error ("Bad type arg to random()\n");
    if (arg->u.number <= 0) {
      ret = &const0;
      break;
    }
#ifdef DRAND48
    ret = make_number (drand48 () * arg->u.number);
#else
#ifdef RANDOM
    ret = make_number (OS_RAND () % arg->u.number);
#else
    ret = make_number ((((int) arg + (int) ret) >> 2 + time (0l)) %
      arg->u.number);
#endif /* RANDOM */
#endif /* DRAND48 */
    break;
  case F_SAY:
    if (DEBUG_EXECUTION)
      debug_message ("say()\n");
    {
      struct lnode *l = p->a1;
      arg1 = get_one_expr (&l, "say()");
      if (arg1 == 0) {
        error ("Bad type argument to say()\n");
        WIN32CLEANUP
        exit (1);
      }
      arg2 = get_one_expr (&l, (char *) 0);
      if (arg2 && arg2->type != T_OBJECT)
        error ("Bad type argument to say()\n");
      (void) call_indirect (F_SAY, arg1, arg2 ? arg2->u.ob : 0);
    }
    return 0;
  case F_TELL_ROOM:
    if (DEBUG_EXECUTION)
      debug_message ("tell_room()\n");
    {
      struct lnode *l = p->a1;
      arg1 = get_one_expr (&l, "tell_room");
      if (arg1 == 0 || arg1->type != T_OBJECT)
        error ("Bad type argument to tell_room()\n");
      arg2 = get_one_expr (&l, "tell_room");
      if (arg2 == 0 || arg2->type != T_STRING)
        error ("Bad type second argument to tell_room()\n");
      (void) call_indirect (F_TELL_ROOM, arg1->u.ob, arg2);
    }
    return 0;
  case F_SHOUT:
    if (DEBUG_EXECUTION)
      debug_message ("shout()\n");
    ret = print_expr_list (p->a1);
    if (ret == 0 || ret->type != T_STRING) {
      error ("Bad type argument to shout()\n");
      WIN32CLEANUP
      exit (1);
    }
    (void) call_indirect (F_SHOUT, ret->u.string);
    return 0;
  case F_WHILE:
    if (DEBUG_EXECUTION)
      debug_message ("while()\n");
    {
      struct context old_context;

      old_context = break_context;
      /*
       * We come to the next statement in three ways:
       * 0: Set up of long jump.
       * 1: break statement.
       * 2: continue statement.
       */
      if (setjmp (break_context.a) == 1) {
        break_context.valid = 0;
        break;
      }
      break_context.valid = 1;
      while (!stop_function) {
        arg = print_expr (p->a1);
        if (arg == 0 || (arg->type == T_NUMBER && arg->u.number == 0))
          break;
        (void) print_expr (p->a2);
      }
      break_context = old_context;
      return 0;
    }
  case F_SUBSCRIPT:
    if (DEBUG_EXECUTION)
      debug_message ("subscript()\n");
    arg1 = print_expr (p->a1);
    arg2 = print_expr (p->a2);
    if (arg1 == 0 || arg2 == 0 || arg1->type != T_STRING ||
      arg2->type != T_NUMBER)
      error ("Bad type argument to subscripts.\n");
    if (arg2->u.number >= (int) strlen (arg1->u.string))
      break;
    ret = alloc_value ();
    ret->type = T_NUMBER;
    ret->u.number = arg1->u.string[arg2->u.number];
    break;
  case F_STRLEN:
    if (DEBUG_EXECUTION)
      debug_message ("strlen()\n");
    arg = print_expr_list (p->a1);
    if (arg == 0 || arg->type != T_STRING)
      break;
    ret = alloc_value ();
    ret->type = T_NUMBER;
    ret->u.number = strlen (arg->u.string);
    break;
  case F_LOWER_CASE:
    if (DEBUG_EXECUTION)
      debug_message ("lower_case()\n");
    ret = print_expr_list (p->a1);
    if (ret == 0 || ret->type != T_STRING)
      error ("Bad type argument to lowercase\n");
    {
      int i;
      for (i = strlen (ret->u.string) - 1; i >= 0; i--)
        if (isalpha (ret->u.string[i]))
          ret->u.string[i] |= 'a' - 'A';
    }
    break;
  case F_SET_HEART_BEAT:
    if (DEBUG_EXECUTION)
      debug_message ("set_heart_beat()\n");
    arg = print_expr_list (p->a1);
    if (arg == 0 || arg->type != T_NUMBER)
      error ("Bad type argument to set_heart_beat()\n");
    call_indirect (F_SET_HEART_BEAT, arg->u.number);
    return 0;
  case F_CAPITALIZE:
    if (DEBUG_EXECUTION)
      debug_message ("capitalize()\n");
    ret = print_expr_list (p->a1);
    if (ret == 0 || ret->type != T_STRING)
      error ("Bad type arg to capitalize\n");
    if (ret->u.string[0] == '\0')
      break;
    if (islower (ret->u.string[0]))
      ret->u.string[0] += 'A' - 'a';
    break;
  case F_COMMAND:
    if (DEBUG_EXECUTION)
      debug_message ("command()\n");
    ret = print_expr_list (p->a1);
    if (ret == 0 || ret->type != T_STRING) {
      error ("Bad type argument to command()\n");
      WIN32CLEANUP
      exit (1);
    }
    (void) call_indirect (F_COMMAND, ret->u.string);
    return 0;
  case F_LS:
    if (DEBUG_EXECUTION)
      debug_message ("ls()\n");
    ret = print_expr_list (p->a1);
    if (ret == 0 || (ret->type != T_STRING && ret->type != T_NUMBER)) {
      error ("Bad type argument to command()\n");
      WIN32CLEANUP
      exit (1);
    }
    (void) call_indirect (F_LS, ret->type == T_STRING ? ret->u.string : 0);
    return 0;
  case F_RM:
    if (DEBUG_EXECUTION)
      debug_message ("rm()\n");
    ret = print_expr_list (p->a1);
    if (ret == 0 || ret->type != T_STRING) {
      error ("Bad type argument to rm()\n");
      WIN32CLEANUP
      exit (1);
    }
    (void) call_indirect (F_RM, ret->u.string);
    return 0;
  case F_CAT:
    if (DEBUG_EXECUTION)
      debug_message ("cat()\n");
    ret = print_expr_list (p->a1);
    if (ret == 0 || ret->type != T_STRING) {
      error ("Bad type argument to cat()\n");
      WIN32CLEANUP
      exit (1);
    }
    (void) call_indirect (F_CAT, ret->u.string);
    return 0;
  case F_INPUT_TO:
    if (DEBUG_EXECUTION)
      debug_message ("input_to()\n");
    ret = print_expr_list (p->a1);
    if (ret == 0 || ret->type != T_STRING) {
      error ("Bad type argument to input_to()\n");
      WIN32CLEANUP
      exit (1);
    }
    ret = call_indirect (F_INPUT_TO, ret->u.string);
    break;
  case F_SSCANF:
    if (DEBUG_EXECUTION)
      debug_message ("sscanf()\n");
    ret = inter_sscanf (p->a1);
    break;
  case F_ENABLE_COMMANDS:
    if (DEBUG_EXECUTION)
      debug_message ("enable_commands()\n");
    (void) call_indirect (F_ENABLE_COMMANDS);
    return 0;
  case F_PRESENT:
    if (DEBUG_EXECUTION)
      debug_message ("present()\n");
    {
      struct lnode *l = p->a1;
      arg1 = get_one_expr (&l, "present()");
      if (arg1->type != T_STRING && arg1->type != T_OBJECT)
        error ("Bad type argument to present()\n");
      arg2 = get_one_expr (&l, NULL);
      if (arg2 && arg2->type != T_OBJECT)
        error ("Bad second argument to present()\n");
      ret = call_indirect (F_PRESENT, arg1, arg2 ? arg2->u.ob : 0);
    }
    break;
  case F_SET_LIGHT:
    if (DEBUG_EXECUTION)
      debug_message ("set_light()\n");
    arg = print_expr_list (p->a1);
    if (arg == 0 || arg->type != T_NUMBER)
      error ("Bad type argument to set_light()\n");
    ret = call_indirect (F_SET_LIGHT, arg->u.number);
    break;
  case F_CONST0:
    if (DEBUG_EXECUTION)
      debug_message ("const 0\n");
    ret = &const0;
    break;
  case F_CONST1:
    if (DEBUG_EXECUTION)
      debug_message ("const 1\n");
    ret = &const1;
    break;
  case F_NUMBER:
    if (DEBUG_EXECUTION)
      debug_message ("number(%d)\n", (int) p->a1);
    ret = alloc_value ();
    ret->type = T_NUMBER;
    ret->u.number = (int) p->a1;
    break;
  case F_ASSIGN:
    if (DEBUG_EXECUTION)
      debug_message ("assign()\n");
    ret = print_expr (p->a2);
    assign ((struct lnode_number *) (p->a1), ret);
    return 0;
  case F_ADD_EQ:
    if (DEBUG_EXECUTION)
      debug_message ("+=\n");
    {
      struct value *v;
      ret = print_expr (p->a2);
      if (ret == 0 || ret->type != T_NUMBER)
        error ("Bad type to +=.\n");
      v = print_expr (p->a1);
      if (v == 0 || v->type != T_NUMBER)
        error ("Bad type to +=");
      assign ((struct lnode_number *) (p->a1),
        make_number (v->u.number + ret->u.number));
    }
    return 0;
  case F_SUB_EQ:
    if (DEBUG_EXECUTION)
      debug_message ("-=\n");
    {
      struct value *v;
      ret = print_expr (p->a2);
      if (ret == 0 || ret->type != T_NUMBER)
        error ("Bad type to -=.\n");
      v = print_expr (p->a1);
      if (v == 0 || v->type != T_NUMBER)
        error ("Bad type to -=");
      assign ((struct lnode_number *) (p->a1),
        make_number (v->u.number - ret->u.number));
    }
    return 0;
  case F_MULT_EQ:
    if (DEBUG_EXECUTION)
      debug_message ("*=\n");
    {
      struct value *v;
      ret = print_expr (p->a2);
      if (ret == 0 || ret->type != T_NUMBER)
        error ("Bad type to *=.\n");
      v = print_expr (p->a1);
      if (v == 0 || v->type != T_NUMBER)
        error ("Bad type to *=");
      assign ((struct lnode_number *) (p->a1),
        make_number (v->u.number * ret->u.number));
    }
    return 0;
  case F_LOCAL_NAME:
    if (DEBUG_EXECUTION)
      debug_message ("LOCAL(%d)\n", p->a1);
    ret = alloc_value ();
    ret->type = current_local_names[(int) p->a1]->type;
    ret->u = current_local_names[(int) p->a1]->u;
    if (ret->type == T_STRING)
      ret->u.string =
        string_copy (current_local_names[(int) p->a1]->u.string);
    else if (ret->type == T_OBJECT) {
      if (ret->u.ob->destructed)
        ret = &const0;
      add_ref (current_local_names[(int) p->a1]->u.ob, "cp loc");
    }
    break;
  case F_DIV_EQ:
    if (DEBUG_EXECUTION)
      debug_message ("/=\n");
    {
      struct value *v;
      ret = print_expr (p->a2);
      if (ret == 0 || ret->type != T_NUMBER)
        error ("Bad type to /=.\n");
      v = print_expr (p->a1);
      if (v == 0 || v->type != T_NUMBER)
        error ("Bad type to /=");
      if (ret->u.number == 0)
        error ("Division by zero.");
      assign ((struct lnode_number *) (p->a1),
        make_number (v->u.number / ret->u.number));
    }
    return 0;
  case F_STRING:
    {
      struct lnode_name *n = (struct lnode_name *) p;
      if (DEBUG_EXECUTION)
        debug_message ("\"%s\"", n->name);
      ret = alloc_value ();
      ret->u.string = string_copy (n->name);
      ret->type = T_STRING;
      break;
    }
  }
  if (d_flag) {
    debug_message ("RESULT: '");
    debug_message_value (ret);
    debug_message ("'\n");
  }
  return ret;
}

static struct value *print_expr_list (struct lnode *p)
{
  if (p == 0)
    return 0;
  if (p->type != F_CONS)
    fatal ("Bad type to print_expr_list()\n");
  return print_expr (p->a1);
}

/*
 * Apply a fun 'fun' to the program in object 'ob', with the
 * optional argument 'arg'.
 */
struct value *apply (char *fun, struct object *ob, struct value *arg)
{
  struct lnode_def *pr;
  struct value *old_argument = current_argument;
  struct object *save_current_object = current_object;

  /*
   * We don't want to keep looping through errors here, yet we should try
   * even if there has been one error for the benefit of the apply's called
   * by the error() routine in simulate.c.
   */
  if (num_error > 1)
    return 0;
  if (ob->destructed)
    error ("Executing '%s' in destructed object.\n", fun);
  if (ob->swapped)
    load_ob_from_swap (ob);
  pr = ob->prog;
  if (pr == 0)
    return 0;
  for (; pr; pr = pr->next) {
    if (pr->type == F_IDENTIFIER && strcmp (pr->name, fun) == 0) {
      struct value *ret;
      current_argument = arg;
      current_object = ob;
      ret = print_function (pr);
      current_object = save_current_object;
      current_argument = old_argument;
      return ret;
    }
  }
  current_argument = old_argument;
  if (d_flag)
    debug_message ("--Could not find the function %s\n", fun);
  return 0;
}

/*
 * Call a specific function in an object.
 * Make sure that current_object is set up, and the the program
 * is not swapped.
 */
void call_function (struct lnode_def *pr)
{
  (void) print_function (pr);
}

#ifdef TRACE
/*
 * Write out a trace. If there are an heart_beat(), then return the
 * object that had that heart beat.
 */
char *dump_trace (void)
{
  int i;
  char *ret = 0;

  if (trace_depth == 0) {
    (void) printf ("No trace.\n");
    debug_message ("No trace.\n");
    return 0;
  }
  for (i = 0; i < trace_depth; i++) {
    (void) printf ("%-3d: '%-10s' in '%-10s' by %-10s line %d\n", i,
      trace_back[i].function_name,
      trace_back[i].object_name,
      trace_back[i].command_name, trace_back[i].line);
    debug_message ("%-3d: '%20s' in '%20s' line %d\n", i,
      trace_back[i].function_name, trace_back[i].object_name,
      trace_back[i].line);
    if (strcmp (trace_back[i].function_name, "heart_beat") == 0)
      ret = trace_back[i].object_name;
  }
  return ret;
}
#endif /* TRACE */

static struct value *get_one_expr (struct lnode **pp, char *from)
{
  struct value *v;

  if (*pp == 0) {
    if (from == 0)
      return 0;
    error ("Wrong number of arguments to %s", from);
  }
  v = print_expr ((*pp)->a1);
  *pp = (*pp)->a2;
  return v;
}

static char *find_percent (char *str)
{
  while (1) {
    str = strchr (str, '%');
    if (str == 0)
      return 0;
    if (str[1] != '%')
      return str;
    str++;
  }
}

static struct value *inter_sscanf (struct lnode *l)
{
  struct value *p;
  char *fmt;                    /* Format description */
  char *in_string;              /* The string o be parsed. */
  int number_of_matches;
  char *cp;

  /*
   * First get the string to be parsed.
   */
  p = get_one_expr (&l, "sscanf");
  if (p == 0 || p->type != T_STRING)
    error ("Bad first argument to sscanf.");
  in_string = p->u.string;
  if (in_string == 0)
    return 0;
  /*
   * Now get the format description.
   */
  p = get_one_expr (&l, "sscanf");
  if (p == 0 || p->type != T_STRING)
    error ("Bad second argument to sscanf.");
  fmt = p->u.string;
  /*
   * First, skip and match leading text.
   */
  for (cp = find_percent (fmt); fmt != cp; fmt++, in_string++) {
    if (in_string[0] == '\0' || fmt[0] != in_string[0])
      return &const0;
  }
  /*
   * For every % or substring in the format.
   */
  for (number_of_matches = 0; l && l->a1; number_of_matches++, l = l->a2) {
    int i, type;

    if (fmt[0] == '\0') {
      /*
       * We have reached end of the format string.
       * If there are any chars left in the in_string,
       * then we put them in the last variable (if any).
       */
      if (in_string[0]) {
        assign ((struct lnode_number *) (l->a1), make_string (in_string));
        number_of_matches++;
      }
      break;
    }
    if (fmt[0] != '%')
      fatal ("Should be a %% now !\n");
    type = T_STRING;
    if (fmt[1] == 'd')
      type = T_NUMBER;
    else if (fmt[1] != 's')
      error ("Bad type : '%%%c' in sscanf fmt string.", fmt[1]);
    fmt += 2;
    /*
     * Parsing a number is the easy case. Just use strtol() to
     * find the end of the number.
     */
    if (type == T_NUMBER) {
      char *tmp = in_string;
      int tmp_num;

      tmp_num = (int) strtol (in_string, &in_string, 0);
      if (tmp == in_string) {
        /* No match */
        break;
      }
      assign ((struct lnode_number *) (l->a1), make_number (tmp_num));
      while (fmt[0] && fmt[0] == in_string[0])
        fmt++, in_string++;
      if (fmt[0] != '%') {
        number_of_matches++;
        break;
      }
      continue;
    }
    /*
     * Now we have the string case.
     */
    cp = find_percent (fmt);
    if (cp == fmt)
      error ("Illegal to have 2 adjacent %'s in fmt string in sscanf.");
    if (cp == 0)
      cp = fmt + strlen (fmt);
    /*
     * First case: There was no extra characters to match.
     * Then this is the last match.
     */
    if (cp == fmt) {
      assign ((struct lnode_number *) (l->a1), make_string (in_string));
      number_of_matches++;
      break;
    }
    for (i = 0; in_string[i]; i++) {
      if (strncmp (in_string + i, fmt, cp - fmt) == 0) {
        char *match;
        /*
         * Found a match !
         */
        match = xalloc (i + 1);
        (void) strncpy (match, in_string, i);
        in_string += i + cp - fmt;
        match[i] = '\0';
        assign ((struct lnode_number *) (l->a1), make_string (match));
        free (match);
        fmt = cp;               /* Advance fmt to next % */
        break;
      }
    }
    if (fmt == cp)              /* If match, then do continue. */
      continue;
    /*
     * No match was found. Then we stop here, and return
     * the result so far !
     */
    break;
  }
  return make_number (number_of_matches);
}