execute.c

/******************************************************************************
  Copyright (c) 1992, 1995, 1996 Xerox Corporation.  All rights reserved.
  Portions of this code were written by Stephen White, aka ghond.
  Use and copying of this software and preparation of derivative works based
  upon this software are permitted.  Any distribution of this software or
  derivative works must comply with all applicable United States export
  control laws.  This software is made available AS IS, and Xerox Corporation
  makes no warranty about the software, its performance or its conformity to
  any specification.  Any person obtaining a copy of this software is requested
  to send their name and post office or electronic mail address to:
    Pavel Curtis
    Xerox PARC
    3333 Coyote Hill Rd.
    Palo Alto, CA 94304
    Pavel@Xerox.Com
 *****************************************************************************/

#include "my-string.h"

#include "config.h"
#include "db.h"
#include "db_io.h"
#include "decompile.h"
#include "eval_env.h"
#include "eval_vm.h"
#include "exceptions.h"
#include "execute.h"
#include "functions.h"
#include "list.h"
#include "log.h"
#include "numbers.h"
#include "opcode.h"
#include "options.h"
#include "parse_cmd.h"
#include "server.h"
#include "storage.h"
#include "streams.h"
#include "structures.h"
#include "sym_table.h"
#include "tasks.h"
#include "timers.h"
#include "utf.h"
#include "utils.h"
#include "waif.h"
#include "version.h"

/* the following globals are the guts of the virtual machine: */
static activation *activ_stack = 0;
static Num max_stack_size = 0;
static unsigned top_activ_stack;	/* points to top-of-stack
					   (last-occupied-slot),
					   not next-empty-slot */
static Num root_activ_vector;	/* root_activ_vector == MAIN_VECTOR
				   iff root activation is main
				   vector */

/* these globals are not part of the vm because they get re-initialized
   after a suspend */
static int ticks_remaining;
int task_timed_out;
static int interpreter_is_running = 0;
static Timer_ID task_alarm_id;

static const char *handler_verb_name;	/* For in-DB traceback handling */
static Var handler_verb_args;

#ifdef WAIF_DICT
/*
 * Jay Carlson's WAIF DICT patch.  These static moo-strings are needed for
 * the new call_verb2 interface which assumes verb is a moo-string rather
 * than a (non reference-counted) C-string.
 */
static char *waif_index_verb;
static char *waif_indexset_verb;
#endif				/* WAIF_DICT */

/* macros to ease indexing into activation stack */
#define RUN_ACTIV     activ_stack[top_activ_stack]
#define CALLER_ACTIV  activ_stack[top_activ_stack - 1]

/**** error handling ****/

typedef enum {			/* Reasons for executing a FINALLY handler */
    /* These constants are stored in the DB, so don't change the order... */
    FIN_FALL_THRU, FIN_RAISE, FIN_UNCAUGHT, FIN_RETURN,
    FIN_ABORT,			/* This doesn't actually get you into a FINALLY... */
    FIN_EXIT
} Finally_Reason;

/*
 * Keep a pool of the common size rt_stacks around to avoid beating up on
 * malloc.  This doesn't really need tuning.  Most rt_stacks will be less
 * than size 10.  I rounded up to a size which won't waste a lot of space
 * with a powers-of-two malloc (while leaving some room for mymalloc
 * overhead, if any).
 */
static Var *rt_stack_quick;
#define RT_STACK_QUICKSIZE	15

static void
alloc_rt_stack(activation * a, Num size)
{
    Var *res;

    if (size <= RT_STACK_QUICKSIZE && rt_stack_quick) {
	res = rt_stack_quick;
	rt_stack_quick = rt_stack_quick[0].v.list;
    } else {
	res = mymalloc(MAX(size, RT_STACK_QUICKSIZE) * sizeof(Var), M_RT_STACK);
    }
    a->base_rt_stack = a->top_rt_stack = res;
    a->rt_stack_size = size;
}

static void
free_rt_stack(activation * a)
{
    Var *stack = a->base_rt_stack;

    if (a->rt_stack_size <= RT_STACK_QUICKSIZE) {
	stack[0].v.list = rt_stack_quick;
	rt_stack_quick = stack;
    } else
	myfree(stack, M_RT_STACK);
}

void
print_error_backtrace(const char *msg, void (*output) (const char *))
{
    int t;
    Stream *str;

    if (!interpreter_is_running)
	return;
    str = new_stream(100);
    for (t = top_activ_stack; t >= 0; t--) {
	if (t != top_activ_stack)
	    stream_printf(str, "... called from ");
	stream_printf(str, "#%"PRIdN":%s", activ_stack[t].vloc,
		      activ_stack[t].verbname);
	if (activ_stack[t].vloc != activ_stack[t].this)
	    stream_printf(str, " (this == #%"PRIdN")", activ_stack[t].this);

	stream_printf(str, ", line %d",
		      find_line_number(activ_stack[t].prog,
				       (t == 0 ? root_activ_vector
					: MAIN_VECTOR),
				       activ_stack[t].error_pc));
	if (t == top_activ_stack)
	    stream_printf(str, ":  %s", msg);
	output(reset_stream(str));
	if (t > 0 && activ_stack[t].bi_func_pc) {
	    stream_printf(str, "... called from built-in function %s()",
			  name_func_by_num(activ_stack[t].bi_func_id));
	    output(reset_stream(str));
	}
    }
    output("(End of traceback)");
    free_stream(str);
}

void
output_to_log(const char *line)
{
    oklog("%s\n", line);
}

static Var backtrace_list;

static void
output_to_list(const char *line)
{
    Var str;

    str.type = TYPE_STR;
    str.v.str = str_dup(line);
    backtrace_list = listappend(backtrace_list, str);
}

static Var
error_backtrace_list(const char *msg)
{
#ifdef DEBUG_LOG_TRACEBACKS
    print_error_backtrace(msg, output_to_log);
#endif
    backtrace_list = new_list(0);
    print_error_backtrace(msg, output_to_list);
    return backtrace_list;
}

static enum error
suspend_task(package p)
{
    vm the_vm = new_vm(current_task_id, top_activ_stack + 1);
    int i;
    enum error e;

    the_vm->max_stack_size = max_stack_size;
    the_vm->top_activ_stack = top_activ_stack;
    the_vm->root_activ_vector = root_activ_vector;
    the_vm->func_id = 0;	/* shouldn't need func_id; */
    for (i = 0; i <= top_activ_stack; i++)
	the_vm->activ_stack[i] = activ_stack[i];

    e = (*p.u.susp.proc) (the_vm, p.u.susp.data);
    if (e != E_NONE)
	free_vm(the_vm, 0);
    return e;
}

static int raise_error(package p, enum outcome *outcome);

static int
unwind_stack(Finally_Reason why, Var value, enum outcome *outcome)
{
    /* Returns true iff the entire stack was unwound and the interpreter
     * should stop, in which case *outcome is the correct outcome to return. */
    Var code = (why == FIN_RAISE ? value.v.list[1] : zero);

    for (;;) {			/* loop over activations */
	activation *a = &(activ_stack[top_activ_stack]);
	void *bi_func_data = 0;
	int bi_func_pc;
	unsigned bi_func_id = 0;
	Objid player;
	Var v, *goal = a->base_rt_stack;

	if (why == FIN_EXIT)
	    goal += value.v.list[1].v.num;
	while (a->top_rt_stack > goal) {	/* loop over rt stack */
	    a->top_rt_stack--;
	    v = *(a->top_rt_stack);
	    if (why != FIN_ABORT && v.type == TYPE_FINALLY) {
		/* FINALLY handler */
		a->pc = v.v.num;
		v.type = TYPE_INT;
		v.v.num = why;
		*(a->top_rt_stack++) = v;
		*(a->top_rt_stack++) = value;
		return 0;
	    } else if (why == FIN_RAISE && v.type == TYPE_CATCH) {
		/* TRY-EXCEPT or `expr ! ...' handler */
		Var *new_top = a->top_rt_stack - 2 * v.v.num;
		Var *vv;
		int found = 0;

		for (vv = new_top; vv < a->top_rt_stack; vv += 2) {
		    if (!found && (vv->type != TYPE_LIST
				   || ismember(code, *vv, 0))) {
			found = 1;
			v = *(vv + 1);
			if (v.type != TYPE_INT)
			    panic("Non-numeric PC value on stack!");
			a->pc = v.v.num;
		    }
		    free_var(*vv);
		}

		a->top_rt_stack = new_top;
		if (found) {
		    *(a->top_rt_stack++) = value;
		    return 0;
		}
	    } else
		free_var(v);
	}
	if (why == FIN_EXIT) {
	    a->pc = value.v.list[2].v.num;
	    free_var(value);
	    return 0;
	}
	bi_func_pc = a->bi_func_pc;
	if (bi_func_pc) {
	    bi_func_id = a->bi_func_id;
	    bi_func_data = a->bi_func_data;
	}
	player = a->player;
	free_activation(a, 0);	/* 0 == don't free bi_func_data */

	if (top_activ_stack == 0) {	/* done */
	    if (outcome)
		*outcome = (why == FIN_RETURN
			    ? OUTCOME_DONE
			    : OUTCOME_ABORTED);
	    return 1;
	}
	top_activ_stack--;

	if (bi_func_pc != 0) {	/* Must unwind through a built-in function */
	    package p;

	    if (why == FIN_RETURN) {
		a = &(activ_stack[top_activ_stack]);
		p = call_bi_func(bi_func_id, value, bi_func_pc, a->progr,
				 bi_func_data);
		switch (p.kind) {
		case BI_RETURN:
		    *(a->top_rt_stack++) = p.u.ret;
		    return 0;
		case BI_RAISE:
		    if (a->debug)
			return raise_error(p, outcome);
		    else {
			*(a->top_rt_stack++) = p.u.raise.code;
			free_str(p.u.raise.msg);
			free_var(p.u.raise.value);
			return 0;
		    }
		case BI_SUSPEND:
		    {
			enum error e = suspend_task(p);

			if (e == E_NONE) {
			    if (outcome)
				*outcome = OUTCOME_BLOCKED;
			    return 1;
			} else {
			    value.type = TYPE_ERR;
			    value.v.err = e;
			    return unwind_stack(FIN_RAISE, value, outcome);
			}
		    }
		case BI_CALL:
		    a = &(activ_stack[top_activ_stack]);	/* TOS has changed */
		    a->bi_func_id = bi_func_id;
		    a->bi_func_pc = p.u.call.pc;
		    a->bi_func_data = p.u.call.data;
		    return 0;
		case BI_KILL:
		    return unwind_stack(FIN_ABORT, zero, outcome);
		}
	    } else {
		/* Built-in functions receive zero as a `returned value' on
		 * errors and aborts, all further calls they make are short-
		 * circuited with an immediate return of zero, and any errors
		 * they raise are squelched.  This is compatible with older,
		 * pre-error-handling versions of the server, and thus
		 * acceptible for the existing built-ins.  It is conceivable
		 * that this model will have to be revisited at some point in
		 * the future.
		 */
		do {
		    p = call_bi_func(bi_func_id, zero, bi_func_pc, a->progr,
				     bi_func_data);
		    switch (p.kind) {
		    case BI_RETURN:
			free_var(p.u.ret);
			break;
		    case BI_RAISE:
			free_var(p.u.raise.code);
			free_str(p.u.raise.msg);
			free_var(p.u.raise.value);
			break;
		    case BI_SUSPEND:
		    case BI_KILL:
			break;
		    case BI_CALL:
			free_activation(&activ_stack[top_activ_stack--], 0);
			bi_func_pc = p.u.call.pc;
			bi_func_data = p.u.call.data;
			break;
		    }
		} while (p.kind == BI_CALL && bi_func_pc != 0);		/* !tailcall */
	    }
	} else if (why == FIN_RETURN) {		/* Push the value on the stack & go */
	    a = &(activ_stack[top_activ_stack]);
	    *(a->top_rt_stack++) = value;
	    return 0;
	}
    }
}

static int
find_handler_activ(Var code)
{
    /* Returns the index of the hottest activation with an active exception
     * handler for the given code.
     */
    int frame;

    for (frame = top_activ_stack; frame >= 0; frame--) {
	activation *a = &(activ_stack[frame]);
	Var *v, *vv;

	for (v = a->top_rt_stack - 1; v >= a->base_rt_stack; v--)
	    if (v->type == TYPE_CATCH) {
		for (vv = v - 2 * v->v.num; vv < v; vv += 2)
		    if (vv->type != TYPE_LIST || ismember(code, *vv, 0))
			return frame;
		v -= 2 * v->v.num;
	    }
    }

    return -1;
}

static Var
make_stack_list(activation * stack, int start, int end, int include_end,
		int root_vector, int line_numbers_too)
{
    Var r;
    int count = 0, i, j;

    for (i = end; i >= start; i--) {
	if (include_end || i != end)
	    count++;
	if (i != start && stack[i].bi_func_pc)
	    count++;
    }

    r = new_list(count);
    j = 1;
    for (i = end; i >= start; i--) {
	Var v;

	if (include_end || i != end) {
	    v = r.v.list[j++] = new_list(line_numbers_too ? 6 : 5);
	    v.v.list[1] = var_ref(stack[i].THIS);
	    v.v.list[2].type = TYPE_STR;
	    v.v.list[2].v.str = str_ref(stack[i].verb);
	    v.v.list[3].type = TYPE_OBJ;
	    v.v.list[3].v.obj = stack[i].progr;
	    v.v.list[4].type = TYPE_OBJ;
	    v.v.list[4].v.obj = stack[i].vloc;
	    v.v.list[5].type = TYPE_OBJ;
	    v.v.list[5].v.obj = stack[i].player;
	    if (line_numbers_too) {
		v.v.list[6].type = TYPE_INT;
		v.v.list[6].v.num = find_line_number(stack[i].prog,
						     (i == 0 ? root_vector
						      : MAIN_VECTOR),
						     stack[i].error_pc);
	    }
	}
	if (i != start && stack[i].bi_func_pc) {
	    v = r.v.list[j++] = new_list(line_numbers_too ? 6 : 5);
	    v.v.list[1].type = TYPE_OBJ;
	    v.v.list[1].v.obj = NOTHING;
	    v.v.list[2].type = TYPE_STR;
	    v.v.list[2].v.str = str_dup(name_func_by_num(stack[i].bi_func_id));
	    v.v.list[3].type = TYPE_OBJ;
	    v.v.list[3].v.obj = NOTHING;
	    v.v.list[4].type = TYPE_OBJ;
	    v.v.list[4].v.obj = NOTHING;
	    v.v.list[5].type = TYPE_OBJ;
	    v.v.list[5].v.obj = stack[i].player;
	    if (line_numbers_too) {
		v.v.list[6].type = TYPE_INT;
		v.v.list[6].v.num = stack[i].bi_func_pc;
	    }
	}
    }

    return r;
}

static void
save_handler_info(const char *vname, Var args)
{
    handler_verb_name = vname;
    free_var(handler_verb_args);
    handler_verb_args = args;
}

static int
raise_error(package p, enum outcome *outcome)
{
    /* ASSERT: p.kind == BI_RAISE */
    int handler_activ = find_handler_activ(p.u.raise.code);
    Finally_Reason why;
    Var value;

    if (handler_activ >= 0) {	/* handler found */
	why = FIN_RAISE;
	value = new_list(4);
    } else {			/* uncaught exception */
	why = FIN_UNCAUGHT;
	value = new_list(5);
	value.v.list[5] = error_backtrace_list(p.u.raise.msg);
	handler_activ = 0;	/* get entire stack in list */
    }
    value.v.list[1] = p.u.raise.code;
    value.v.list[2].type = TYPE_STR;
    value.v.list[2].v.str = p.u.raise.msg;
    value.v.list[3] = p.u.raise.value;
    value.v.list[4] = make_stack_list(activ_stack, handler_activ,
				      top_activ_stack, 1,
				      root_activ_vector, 1);

    if (why == FIN_UNCAUGHT) {
	save_handler_info("handle_uncaught_error", value);
	value = zero;
    }
    return unwind_stack(why, value, outcome);
}

static void
abort_task(int is_ticks)
{
    Var value;
    const char *msg = (is_ticks ? "Task ran out of ticks"
		       : "Task ran out of seconds");

    value = new_list(3);
    value.v.list[1].type = TYPE_STR;
    value.v.list[1].v.str = str_dup(is_ticks ? "ticks" : "seconds");
    value.v.list[2] = make_stack_list(activ_stack, 0, top_activ_stack, 1,
				      root_activ_vector, 1);
    value.v.list[3] = error_backtrace_list(msg);
    save_handler_info("handle_task_timeout", value);
    unwind_stack(FIN_ABORT, zero, 0);
}

/**** activation manipulation ****/

static int
push_activation(void)
{
    if (top_activ_stack < max_stack_size - 1) {
	top_activ_stack++;
	return 1;
    } else
	return 0;
}

void
free_activation(activation * ap, char data_too)
{
    Var *i;

    free_rt_env(ap->rt_env, ap->prog->num_var_names);

    for (i = ap->base_rt_stack; i < ap->top_rt_stack; i++)
	free_var(*i);
    free_rt_stack(ap);
    free_var(ap->THIS);
    free_var(ap->temp);
    free_str(ap->verb);
    free_str(ap->verbname);

    free_program(ap->prog);

    if (data_too && ap->bi_func_pc && ap->bi_func_data)
	free_data(ap->bi_func_data);
    /* else bi_func_state will be later freed by bi_function */
}


/** Set up another activation for calling a verb
  does not change the vm in case of any error **/

enum error call_verb2(Objid this, const char *vname, Var THIS, Var args, int do_pass);

/*
 * Historical interface for things which want to call with vname not
 * already in a moo-str.
 */
enum error
call_verb(Objid this, const char *vname_in, Var args, int do_pass)
{
    const char *vname = str_dup(vname_in);
    enum error result;
    Var THIS;

    THIS.type = TYPE_OBJ;
    THIS.v.obj = this;
    result = call_verb2(this, vname, THIS, args, do_pass);
    /* call_verb2 got any refs it wanted */
    free_str(vname);
    return result;
}

enum error
call_verb2(Objid this, const char *vname, Var THIS, Var args, int do_pass)
{
    /* if call succeeds, args will be consumed.  If call fails, args
       will NOT be consumed  -- it must therefore be freed by caller */
    /* vname will never be consumed */
    /* vname *must* already be a MOO-string (as in str_ref-able) */
    /* THIS will never be consumed */

    /* will only return E_MAXREC, E_INVIND, E_VERBNF, or E_NONE */
    /* returns an error if there is one, and does not change the vm in that
       case, else sets up the activ_stack for the verb call and then returns
       E_NONE */

    Objid where;
    db_verb_handle h;
    Program *program;
    Var *env;
    Var v;

    if (do_pass)
	if (!valid(RUN_ACTIV.vloc))
	    return E_INVIND;
	else
	    where = db_object_parent(RUN_ACTIV.vloc);
    else
	where = this;

    if (!valid(where))
	return E_INVIND;
    h = db_find_callable_verb(where, vname);
    if (!h.ptr)
	return E_VERBNF;
    else if (!push_activation())
	return E_MAXREC;

    program = db_verb_program(h);
    RUN_ACTIV.prog = program_ref(program);
    RUN_ACTIV.this = this;
    RUN_ACTIV.THIS = var_ref(THIS);
    RUN_ACTIV.progr = db_verb_owner(h);
    RUN_ACTIV.vloc = db_verb_definer(h);
    RUN_ACTIV.verb = str_ref(vname);
    RUN_ACTIV.verbname = str_ref(db_verb_names(h));
    RUN_ACTIV.debug = (db_verb_flags(h) & VF_DEBUG);

    alloc_rt_stack(&RUN_ACTIV, program->main_vector.max_stack);
    RUN_ACTIV.pc = 0;
    RUN_ACTIV.error_pc = 0;
    RUN_ACTIV.bi_func_pc = 0;
    RUN_ACTIV.temp.type = TYPE_NONE;

    RUN_ACTIV.rt_env = env = new_rt_env(RUN_ACTIV.prog->num_var_names);

    fill_in_rt_consts(env, program->version);

    set_rt_env_var(env, SLOT_THIS, var_ref(THIS));
    set_rt_env_var(env, SLOT_CALLER, var_ref(CALLER_ACTIV.THIS));

#define ENV_COPY(slot) \
    set_rt_env_var(env, slot, var_ref(CALLER_ACTIV.rt_env[slot]))

    ENV_COPY(SLOT_ARGSTR);
    ENV_COPY(SLOT_DOBJ);
    ENV_COPY(SLOT_DOBJSTR);
    ENV_COPY(SLOT_PREPSTR);
    ENV_COPY(SLOT_IOBJ);
    ENV_COPY(SLOT_IOBJSTR);

    if (is_wizard(CALLER_ACTIV.progr) &&
	(CALLER_ACTIV.rt_env[SLOT_PLAYER].type == TYPE_OBJ))
	ENV_COPY(SLOT_PLAYER);
    else
	set_rt_env_obj(env, SLOT_PLAYER, CALLER_ACTIV.player);
    RUN_ACTIV.player = env[SLOT_PLAYER].v.obj;

#undef ENV_COPY

    v.type = TYPE_STR;
    if (vname[0] == WAIF_VERB_PREFIX)
	v.v.str = str_dup(vname + 1);
    else
	v.v.str = str_ref(vname);
    set_rt_env_var(env, SLOT_VERB, v);	/* no var_dup */
    set_rt_env_var(env, SLOT_ARGS, args);	/* no var_dup */

    return E_NONE;
}

static int
rangeset_check(int end, int from, int to)
{
    if (from > end + 1 || to < 0)
	return 1;
    return 0;
}

#ifdef IGNORE_PROP_PROTECTED
#define bi_prop_protected(prop, progr) (0)
#else
static int
bi_prop_protected(enum bi_prop prop, Objid progr)
{
    const char *pname = 0;	/* silence warning */

    if (is_wizard(progr))
	return 0;

    switch (prop) {
    case BP_NAME:
	pname = "protect_name";
	break;
    case BP_OWNER:
	pname = "protect_owner";
	break;
    case BP_PROGRAMMER:
	pname = "protect_programmer";
	break;
    case BP_WIZARD:
	pname = "protect_wizard";
	break;
    case BP_R:
	pname = "protect_r";
	break;
    case BP_W:
	pname = "protect_w";
	break;
    case BP_F:
	pname = "protect_f";
	break;
    case BP_LOCATION:
	pname = "protect_location";
	break;
    case BP_CONTENTS:
	pname = "protect_contents";
	break;
    default:
	panic("Can't happen in BI_PROP_PROTECTED!");
    }

    return server_flag_option(pname);
}
#endif				/* IGNORE_PROP_PROTECTED */

/** 
  the main interpreter -- run()
  everything is just an entry point to it
**/

static enum outcome
run(char raise, enum error resumption_error, Var * result)
{				/* runs the_vm */
    /* If the returned value is OUTCOME_DONE and RESULT is non-NULL, then
     * *RESULT is the value returned by the top frame.
     */

    /* bc, bv, rts are distinguished as the state variables of run()
       their value capture the state of the running between OP_ cases */
    Bytecodes bc;
    Byte *bv, *error_bv;
    Var *rts;			/* next empty slot */
    enum Opcode op;
    Var error_var;
    enum outcome outcome;

/** a bunch of macros that work *ONLY* inside run() **/

/* helping macros about the runtime_stack. */
#define POP()         (*(--rts))
#define PUSH(v)       (*(rts++) = v)
#define PUSH_REF(v)   PUSH(var_ref(v))
#define TOP_RT_VALUE           (*(rts - 1))
#define NEXT_TOP_RT_VALUE      (*(rts - 2))

#define READ_BYTES(bv, nb)			\
    ( bv += nb,					\
      (nb == 1				        \
       ? bv[-1]					\
       : (nb == 2				\
	  ? ((unsigned) bv[-2] << 8) + bv[-1]	\
	  : (((unsigned) bv[-4] << 24)		\
	     + ((unsigned) bv[-3] << 16)     	\
	     + ((unsigned) bv[-2] << 8)      	\
	     + bv[-1]))))

#define SKIP_BYTES(bv, nb)	((void)(bv += nb))

#define LOAD_STATE_VARIABLES() 					\
do {  								\
    bc = ( (top_activ_stack != 0 || root_activ_vector == MAIN_VECTOR) \
	   ? RUN_ACTIV.prog->main_vector 			\
	   : RUN_ACTIV.prog->fork_vectors[root_activ_vector]); 	\
    bv = bc.vector + RUN_ACTIV.pc;  				\
    error_bv = bc.vector + RUN_ACTIV.error_pc;			\
    rts = RUN_ACTIV.top_rt_stack; /* next empty slot */        	\
} while (0)

#define STORE_STATE_VARIABLES()			\
do {						\
    RUN_ACTIV.pc = bv - bc.vector;		\
    RUN_ACTIV.error_pc = error_bv - bc.vector;	\
    RUN_ACTIV.top_rt_stack = rts;		\
} while (0)

#define RAISE_ERROR(the_err) 			\
do {						\
    if (RUN_ACTIV.debug) { 			\
	STORE_STATE_VARIABLES();		\
	if (raise_error(make_error_pack(the_err), 0)) \
	    return OUTCOME_ABORTED;		\
	else {					\
	    LOAD_STATE_VARIABLES();		\
	    goto next_opcode;			\
	}					\
    } 						\
} while (0)

#define PUSH_ERROR(the_err)                                     \
do {    						    	\
    RAISE_ERROR(the_err);	/* may not return */		\
    error_var.type = TYPE_ERR;					\
    error_var.v.err = the_err;					\
    PUSH(error_var);						\
} while (0)

#define JUMP(label)     (bv = bc.vector + label)

/* end of major run() macros */

    LOAD_STATE_VARIABLES();

    if (raise) {
	error_bv = bv;
	PUSH_ERROR(resumption_error);
    }
    for (;;) {
      next_opcode:
	error_bv = bv;
	op = *bv++;

	if (COUNT_TICK(op)) {
	    if (--ticks_remaining <= 0) {
		STORE_STATE_VARIABLES();
		abort_task(1);
		return OUTCOME_ABORTED;
	    }
	    if (task_timed_out) {
		STORE_STATE_VARIABLES();
		abort_task(0);
		return OUTCOME_ABORTED;
	    }
	}
	switch (op) {

	case OP_IF_QUES:
	case OP_IF:
	case OP_WHILE:
	case OP_EIF:
	  do_test:
	    {
		Var cond;

		cond = POP();
		if (!is_true(cond)) {	/* jump if false */
		    unsigned lab = READ_BYTES(bv, bc.numbytes_label);
		    JUMP(lab);
		}
		else {
		    SKIP_BYTES(bv, bc.numbytes_label);
		}
		free_var(cond);
	    }
	    break;

	case OP_JUMP:
	    {
		unsigned lab = READ_BYTES(bv, bc.numbytes_label);
		JUMP(lab);
	    }
	    break;

	case OP_FOR_LIST:
	    {
		unsigned id = READ_BYTES(bv, bc.numbytes_var_name);
		unsigned lab = READ_BYTES(bv, bc.numbytes_label);
		Var count, list;

		count = TOP_RT_VALUE;	/* will be a integer */
		list = NEXT_TOP_RT_VALUE;	/* should be a list */
		if (list.type != TYPE_LIST) {
		    RAISE_ERROR(E_TYPE);
		    free_var(POP());
		    free_var(POP());
		    JUMP(lab);
		} else if (count.v.num > list.v.list[0].v.num /* size */ ) {
		    free_var(POP());
		    free_var(POP());
		    JUMP(lab);
		} else {
		    free_var(RUN_ACTIV.rt_env[id]);
		    RUN_ACTIV.rt_env[id] = var_ref(list.v.list[count.v.num]);
		    count.v.num++;	/* increment count */
		    TOP_RT_VALUE = count;
		}
	    }
	    break;

	case OP_FOR_RANGE:
	    {
		unsigned id = READ_BYTES(bv, bc.numbytes_var_name);
		unsigned lab = READ_BYTES(bv, bc.numbytes_label);
		Var from, to;

		to = TOP_RT_VALUE;
		from = NEXT_TOP_RT_VALUE;
		if ((to.type != TYPE_INT && to.type != TYPE_OBJ)
		    || to.type != from.type) {
		    RAISE_ERROR(E_TYPE);
		    free_var(POP());
		    free_var(POP());
		    JUMP(lab);
		} else if (to.type == TYPE_INT
			   ? from.v.num > to.v.num
			   : from.v.obj > to.v.obj) {
		    free_var(POP());
		    free_var(POP());
		    JUMP(lab);
		} else {
		    free_var(RUN_ACTIV.rt_env[id]);
		    RUN_ACTIV.rt_env[id] = var_ref(from);
		    if (to.type == TYPE_INT) {
			if (from.v.num < MAXINT) {
			    from.v.num++;
			    NEXT_TOP_RT_VALUE = from;
			} else {
			    to.v.num--;
			    TOP_RT_VALUE = to;
			}
		    } else {
			if (from.v.obj < MAXOBJ) {
			    from.v.obj++;
			    NEXT_TOP_RT_VALUE = from;
			} else {
			    to.v.obj--;
			    TOP_RT_VALUE = to;
			}
		    }
		}
	    }
	    break;

	case OP_POP:
	    free_var(POP());
	    break;

	case OP_IMM:
	    {
		int slot;

		/* If we'd just throw it away anyway (eg verbdocs),
		   skip both OPs.  This accounts for most executions
		   of OP_IMM in my tests.
		 */
		if (bv[bc.numbytes_literal] == OP_POP) {
		    bv += bc.numbytes_literal + 1;
		    break;
		}
		slot = READ_BYTES(bv, bc.numbytes_literal);
		PUSH_REF(RUN_ACTIV.prog->literals[slot]);
	    }
	    break;

	case OP_MAKE_EMPTY_LIST:
	    {
		Var list;

		list = new_list(0);
		PUSH(list);
	    }
	    break;

	case OP_LIST_ADD_TAIL:
	    {
		Var tail, list;

		tail = POP();	/* whatever */
		list = POP();	/* should be list */
		if (list.type != TYPE_LIST) {
		    free_var(list);
		    free_var(tail);
		    PUSH_ERROR(E_TYPE);
		} else
		    PUSH(listappend(list, tail));
	    }
	    break;

	case OP_LIST_APPEND:
	    {
		Var tail, list;

		tail = POP();	/* second, should be list */
		list = POP();	/* first, should be list */
		if (tail.type != TYPE_LIST || list.type != TYPE_LIST) {
		    free_var(tail);
		    free_var(list);
		    PUSH_ERROR(E_TYPE);
		} else
		    PUSH(listconcat(list, tail));
	    }
	    break;

	case OP_INDEXSET:
	    {
		Var value, index, list;

		value = POP();	/* rhs value */
		index = POP();	/* index, should be integer */
		list = POP();	/* lhs except last index, should be list or str */
		/* whole thing should mean list[index] = value */

#ifdef WAIF_DICT
		if (list.type == TYPE_WAIF) {
		    Objid class;
		    Var args;
		    enum error err = E_NONE;

		    args = new_list(2);
		    args.v.list[1] = var_ref(index);
		    args.v.list[2] = var_ref(value);

		    class = list.v.waif->class;
		    if (!valid(class)) {
			err = E_INVIND;
		    } else if (!is_wizard(db_object_owner(class))) {
			err = E_TYPE;
		    } else {
			STORE_STATE_VARIABLES();
			err = call_verb2(class, waif_indexset_verb, list, args, 0);
			if (err == E_VERBNF) {
			    err = E_TYPE;
			}
			LOAD_STATE_VARIABLES();
		    }
		    free_var(index);
		    free_var(value);
		    free_var(list);
		    if (err != E_NONE) {
			free_var(args);
			PUSH_ERROR(err);
		    }
		} else
#endif				/* WAIF_DICT */
		    if ((list.type != TYPE_LIST && list.type != TYPE_STR)
			|| index.type != TYPE_INT
		  || (list.type == TYPE_STR && value.type != TYPE_STR)) {
		    free_var(value);
		    free_var(index);
		    free_var(list);
		    PUSH_ERROR(E_TYPE);
		} else if (index.v.num < 1
			   || (list.type == TYPE_LIST
		       && index.v.num > list.v.list[0].v.num /* size */ )
			   || (list.type == TYPE_STR
			    && index.v.num > (int) strlen_utf(list.v.str))) {
		    free_var(value);
		    free_var(index);
		    free_var(list);
		    PUSH_ERROR(E_RANGE);
		} else if (list.type == TYPE_STR
			   && strlen_utf(value.v.str) != 1) {
		    free_var(value);
		    free_var(index);
		    free_var(list);
		    PUSH_ERROR(E_INVARG);
		} else if (list.type == TYPE_LIST) {
		    Var res;

		    if (var_refcount(list) == 1)
			res = list;
		    else {
			res = var_dup(list);
			free_var(list);
		    }
		    PUSH(listset(res, value, index.v.num));
                } else if (1 || (memo_strlen(value.v.str) != 1)) {
                    /* always have to do this because even if the target
                     * character is not long the source might be and it'd
                     * take half the work of strrangeset just to check it
                     */
                    PUSH(strrangeset(list, index.v.num, index.v.num, value));
                    /* XXX is there a refcount problem here? */
                    /* XXX if so, what about the other strrangeset? */
		} else {	/* TYPE_STR */
		    char *tmp_str = str_dup(list.v.str);
		    free_str(list.v.str);
		    tmp_str[index.v.num - 1] = value.v.str[0];
		    list.v.str = tmp_str;
		    free_var(value);
		    PUSH(list);
		}
	    }
	    break;

	case OP_MAKE_SINGLETON_LIST:
	    {
		Var list;

		list = new_list(1);
		list.v.list[1] = POP();
		PUSH(list);
	    }
	    break;

	case OP_CHECK_LIST_FOR_SPLICE:
	    if (TOP_RT_VALUE.type != TYPE_LIST) {
		free_var(POP());
		PUSH_ERROR(E_TYPE);
	    }
	    /* no op if top-rt-stack is a list */
	    break;

	case OP_PUT_TEMP:
	    RUN_ACTIV.temp = var_ref(TOP_RT_VALUE);
	    break;

	case OP_PUSH_TEMP:
	    PUSH(RUN_ACTIV.temp);
	    RUN_ACTIV.temp.type = TYPE_NONE;
	    break;

	case OP_EQ:
	case OP_NE:
	    {
		Var rhs, lhs, ans;

		rhs = POP();
		lhs = POP();
		ans.type = TYPE_INT;
		ans.v.num = (op == OP_EQ
			     ? equality(rhs, lhs, 0)
			     : !equality(rhs, lhs, 0));
		PUSH(ans);
		free_var(rhs);
		free_var(lhs);
	    }
	    break;

	case OP_GT:
	case OP_LT:
	case OP_GE:
	case OP_LE:
	    {
		Var rhs, lhs, ans;
		int comparison;

		rhs = POP();
		lhs = POP();
		if ((lhs.type == TYPE_INT || lhs.type == TYPE_FLOAT)
		    && (rhs.type == TYPE_INT || rhs.type == TYPE_FLOAT)) {
		    ans = compare_numbers(lhs, rhs);
		    if (ans.type == TYPE_ERR) {
			free_var(rhs);
			free_var(lhs);
			PUSH_ERROR(ans.v.err);
		    } else {
			comparison = ans.v.num;
			goto finish_comparison;
		    }
		} else if (rhs.type != lhs.type || rhs.type == TYPE_LIST) {
		    free_var(rhs);
		    free_var(lhs);
		    PUSH_ERROR(E_TYPE);
		} else {
		    switch (rhs.type) {
		    case TYPE_INT:
			comparison = compare_integers(lhs.v.num, rhs.v.num);
			break;
		    case TYPE_OBJ:
			comparison = compare_integers(lhs.v.obj, rhs.v.obj);
			break;
		    case TYPE_ERR:
			comparison = ((int) lhs.v.err) - ((int) rhs.v.err);
			break;
		    case TYPE_STR:
			comparison = mystrcasecmp(lhs.v.str, rhs.v.str);
			break;
		    default:
			errlog("RUN: Impossible type in comparison: %d\n",
			       rhs.type);
			comparison = 0;
		    }

		  finish_comparison:
		    ans.type = TYPE_INT;
		    switch (op) {
		    case OP_LT:
			ans.v.num = (comparison < 0);
			break;
		    case OP_LE:
			ans.v.num = (comparison <= 0);
			break;
		    case OP_GT:
			ans.v.num = (comparison > 0);
			break;
		    case OP_GE:
			ans.v.num = (comparison >= 0);
			break;
		    default:
			errlog("RUN: Imposible opcode in comparison: %d\n", op);
			break;
		    }
		    PUSH(ans);
		    free_var(rhs);
		    free_var(lhs);
		}
	    }
	    break;

	case OP_IN:
	    {
		Var lhs, rhs, ans;

		rhs = POP();	/* should be list */
		lhs = POP();	/* lhs, any type */
		if (rhs.type != TYPE_LIST) {
		    free_var(rhs);
		    free_var(lhs);
		    PUSH_ERROR(E_TYPE);
		} else {
		    ans.type = TYPE_INT;
		    ans.v.num = ismember(lhs, rhs, 0);
		    PUSH(ans);
		    free_var(rhs);
		    free_var(lhs);
		}
	    }
	    break;

	case OP_MULT:
	case OP_MINUS:
	case OP_DIV:
	case OP_MOD:
	    {
		Var lhs, rhs, ans;

		rhs = POP();	/* should be number */
		lhs = POP();	/* should be number */
		if ((lhs.type == TYPE_INT || lhs.type == TYPE_FLOAT)
		    && (rhs.type == TYPE_INT || rhs.type == TYPE_FLOAT)) {
		    switch (op) {
		    case OP_MULT:
			ans = do_multiply(lhs, rhs);
			break;
		    case OP_MINUS:
			ans = do_subtract(lhs, rhs);
			break;
		    case OP_DIV:
			ans = do_divide(lhs, rhs);
			break;
		    case OP_MOD:
			ans = do_modulus(lhs, rhs);
			break;
		    default:
			errlog("RUN: Impossible opcode in arith ops: %d\n", op);
			break;
		    }
		} else {
		    ans.type = TYPE_ERR;
		    ans.v.err = E_TYPE;
		}
		free_var(rhs);
		free_var(lhs);
		if (ans.type == TYPE_ERR)
		    PUSH_ERROR(ans.v.err);
		else
		    PUSH(ans);
	    }
	    break;

	case OP_ADD:
	    {
		Var rhs, lhs, ans;

		rhs = POP();
		lhs = POP();
		if ((lhs.type == TYPE_INT || lhs.type == TYPE_FLOAT)
		    && (rhs.type == TYPE_INT || rhs.type == TYPE_FLOAT))
		    ans = do_add(lhs, rhs);
		else if (lhs.type == TYPE_STR && rhs.type == TYPE_STR) {
		    char *str;
		    int llen = memo_strlen(lhs.v.str);

		    str = mymalloc(llen + memo_strlen(rhs.v.str) + 1, M_STRING);
		    strcpy(str, lhs.v.str);
		    strcpy(str + llen, rhs.v.str);
		    ans.type = TYPE_STR;
		    ans.v.str = str;
		} else {
		    ans.type = TYPE_ERR;
		    ans.v.err = E_TYPE;
		}
		free_var(rhs);
		free_var(lhs);

		if (ans.type == TYPE_ERR)
		    PUSH_ERROR(ans.v.err);
		else
		    PUSH(ans);
	    }
	    break;

	case OP_AND:
	case OP_OR:
	    {
		Var lhs;
		unsigned lab = READ_BYTES(bv, bc.numbytes_label);

		lhs = TOP_RT_VALUE;
		if ((op == OP_AND && !is_true(lhs))
		    || (op == OP_OR && is_true(lhs)))	/* short-circuit */
		    JUMP(lab);
		else {
		    free_var(POP());
		}
	    }
	    break;

	case OP_NOT:
	    {
		Var arg, ans;

		arg = POP();
		ans.type = TYPE_INT;
		ans.v.num = !is_true(arg);
		PUSH(ans);
		free_var(arg);
	    }
	    break;

	case OP_UNARY_MINUS:
	    {
		Var arg, ans;

		arg = POP();
		if (arg.type == TYPE_INT) {
		    ans.type = TYPE_INT;
		    ans.v.num = -arg.v.num;
		} else if (arg.type == TYPE_FLOAT) {
		    ans.type = TYPE_FLOAT;
		    ans.v.fnum = -arg.v.fnum;
		} else {
		    free_var(arg);
		    PUSH_ERROR(E_TYPE);
		    break;
		}

		PUSH(ans);
		free_var(arg);
	    }
	    break;

	case OP_REF:
	    {
		Var index, list;

		index = POP();	/* should be integer */
		list = POP();	/* should be list or string */

#ifdef WAIF_DICT
		if (list.type == TYPE_WAIF) {
		    Objid class;
		    Var args;
		    enum error err = E_NONE;

		    args = new_list(1);
		    args.v.list[1] = var_ref(index);

		    class = list.v.waif->class;
		    if (!valid(class)) {
			err = E_INVIND;
		    } else if (!is_wizard(db_object_owner(class))) {
			err = E_TYPE;
		    } else {
			STORE_STATE_VARIABLES();
			err = call_verb2(class, waif_index_verb, list, args, 0);
			if (err == E_VERBNF) {
			    err = E_TYPE;
			}
			LOAD_STATE_VARIABLES();
		    }
		    free_var(index);
		    free_var(list);
		    if (err != E_NONE) {
			free_var(args);
			PUSH_ERROR(err);
		    }
		} else
#endif				/* WAIF_DICT */
		    if (index.type != TYPE_INT ||
		     (list.type != TYPE_LIST && list.type != TYPE_STR)) {
		    free_var(index);
		    free_var(list);
		    PUSH_ERROR(E_TYPE);
		} else if (list.type == TYPE_LIST) {
		    if (index.v.num <= 0 || index.v.num > list.v.list[0].v.num) {
			free_var(index);
			free_var(list);
			PUSH_ERROR(E_RANGE);
		    } else {
			PUSH(var_ref(list.v.list[index.v.num]));
			free_var(index);
			free_var(list);
		    }
		} else {	/* list.type == TYPE_STR */
		    if (index.v.num <= 0
			|| index.v.num > (int) strlen_utf(list.v.str)) {
			free_var(index);
			free_var(list);
			PUSH_ERROR(E_RANGE);
		    } else {
			PUSH(strget(list, index));
			free_var(index);
			free_var(list);
		    }
		}
	    }
	    break;

	case OP_PUSH_REF:
	    {
		Var index, list;

		index = TOP_RT_VALUE;
		list = NEXT_TOP_RT_VALUE;

		if (index.type != TYPE_INT || list.type != TYPE_LIST) {
		    PUSH_ERROR(E_TYPE);
		} else if (index.v.num <= 0 ||
			   index.v.num > list.v.list[0].v.num) {
		    PUSH_ERROR(E_RANGE);
		} else
		    PUSH(var_ref(list.v.list[index.v.num]));
	    }
	    break;

	case OP_RANGE_REF:
	    {
		Var base, from, to;

		to = POP();	/* should be integer */
		from = POP();	/* should be integer */
		base = POP();	/* should be list or string */

		if ((base.type != TYPE_LIST && base.type != TYPE_STR)
		    || to.type != TYPE_INT || from.type != TYPE_INT) {
		    free_var(to);
		    free_var(from);
		    PUSH_ERROR(E_TYPE);
		} else {
		    int len = (base.type == TYPE_STR ? strlen_utf(base.v.str)
			       : base.v.list[0].v.num);
		    if (from.v.num <= to.v.num
			&& (from.v.num <= 0 || from.v.num > len
			    || to.v.num <= 0 || to.v.num > len)) {
			free_var(to);
			free_var(from);
			free_var(base);
			PUSH_ERROR(E_RANGE);
		    } else {
			PUSH((base.type == TYPE_STR
			      ? substr(base, from.v.num, to.v.num)
			      : sublist(base, from.v.num, to.v.num)));
			/* base freed by substr/sublist */
			free_var(from);
			free_var(to);
		    }
		}
	    }
	    break;

	case OP_G_PUT:
	    {
		unsigned id = READ_BYTES(bv, bc.numbytes_var_name);
		free_var(RUN_ACTIV.rt_env[id]);
		RUN_ACTIV.rt_env[id] = var_ref(TOP_RT_VALUE);
	    }
	    break;

	case OP_G_PUSH:
	    {
		Var value;

		value = RUN_ACTIV.rt_env[READ_BYTES(bv, bc.numbytes_var_name)];
		if (value.type == TYPE_NONE)
		    PUSH_ERROR(E_VARNF);
		else
		    PUSH_REF(value);
	    }
	    break;

	case OP_GET_PROP:
	    {
		Var propname, obj, prop;

		propname = POP();	/* should be string */
		obj = POP();	/* should be objid */
		if (obj.type == TYPE_WAIF && propname.type == TYPE_STR) {
		    enum error err;

		    err = waif_get_prop(obj.v.waif, propname.v.str, &prop,
					RUN_ACTIV.progr);
		    free_var(propname);
		    free_var(obj);
		    if (err == E_NONE)
			PUSH(prop);
		    else
			PUSH_ERROR(err);
		} else if (propname.type != TYPE_STR || obj.type != TYPE_OBJ) {
		    free_var(propname);
		    free_var(obj);
		    PUSH_ERROR(E_TYPE);
		} else if (!valid(obj.v.obj)) {
		    free_var(propname);
		    free_var(obj);
		    PUSH_ERROR(E_INVIND);
		} else {
		    db_prop_handle h;

		    h = db_find_property(obj.v.obj, propname.v.str, &prop);
		    free_var(propname);
		    free_var(obj);
		    if (!h.ptr)
			PUSH_ERROR(E_PROPNF);
		    else if (h.built_in
			 ? bi_prop_protected(h.built_in, RUN_ACTIV.progr)
		      : !db_property_allows(h, RUN_ACTIV.progr, PF_READ))
			PUSH_ERROR(E_PERM);
		    else if (h.built_in)
			PUSH(prop);	/* it's already freshly allocated */
		    else
			PUSH_REF(prop);
		}
	    }
	    break;

	case OP_PUSH_GET_PROP:
	    {
		Var propname, obj, prop;

		propname = TOP_RT_VALUE;
		obj = NEXT_TOP_RT_VALUE;

		if (obj.type == TYPE_WAIF && propname.type == TYPE_STR) {
		    enum error err;

		    err = waif_get_prop(obj.v.waif, propname.v.str, &prop,
					RUN_ACTIV.progr);
		    if (err == E_NONE)
			PUSH(prop);
		    else
			PUSH_ERROR(err);
		} else if (propname.type != TYPE_STR || obj.type != TYPE_OBJ)
		    PUSH_ERROR(E_TYPE);
		else if (!valid(obj.v.obj))
		    PUSH_ERROR(E_INVIND);
		else {
		    db_prop_handle h;

		    h = db_find_property(obj.v.obj, propname.v.str, &prop);
		    if (!h.ptr)
			PUSH_ERROR(E_PROPNF);
		    else if (h.built_in
			 ? bi_prop_protected(h.built_in, RUN_ACTIV.progr)
		      : !db_property_allows(h, RUN_ACTIV.progr, PF_READ))
			PUSH_ERROR(E_PERM);
		    else if (h.built_in)
			PUSH(prop);
		    else
			PUSH_REF(prop);
		}
	    }
	    break;

	case OP_PUT_PROP:
	    {
		Var obj, propname, rhs;

		rhs = POP();	/* any type */
		propname = POP();	/* should be string */
		obj = POP();	/* should be objid */

		if (obj.type == TYPE_WAIF && propname.type == TYPE_STR) {
		    enum error err;

		    err = waif_put_prop(obj.v.waif, propname.v.str, rhs,
					RUN_ACTIV.progr);
		    free_var(propname);
		    free_var(obj);
		    if (err == E_NONE) {
			PUSH(rhs);
		    } else {
			free_var(rhs);
			PUSH_ERROR(err);
		    }
		} else if (obj.type != TYPE_OBJ || propname.type != TYPE_STR) {
		    free_var(rhs);
		    free_var(propname);
		    free_var(obj);
		    PUSH_ERROR(E_TYPE);
		} else if (!valid(obj.v.obj)) {
		    free_var(rhs);
		    free_var(propname);
		    free_var(obj);
		    PUSH_ERROR(E_INVIND);
		} else {
		    db_prop_handle h;
		    enum error err = E_NONE;
		    Objid progr = RUN_ACTIV.progr;

		    h = db_find_property(obj.v.obj, propname.v.str, 0);
		    if (!h.ptr)
			err = E_PROPNF;
		    else {
			switch (h.built_in) {
			case BP_NONE:	/* Not a built-in property */
			    if (!db_property_allows(h, progr, PF_WRITE))
				err = E_PERM;
			    break;
			case BP_NAME:
			    if (rhs.type != TYPE_STR)
				err = E_TYPE;
			    else if (!is_wizard(progr)
				     && (is_user(obj.v.obj)
				 || progr != db_object_owner(obj.v.obj)))
				err = E_PERM;
			    break;
			case BP_OWNER:
			    if (rhs.type != TYPE_OBJ)
				err = E_TYPE;
			    else if (!is_wizard(progr))
				err = E_PERM;
			    break;
			case BP_PROGRAMMER:
			case BP_WIZARD:
			    if (!is_wizard(progr))
				err = E_PERM;
			    else if (h.built_in == BP_WIZARD
			     && !is_true(rhs) != !is_wizard(obj.v.obj)) {
				/* Notify only on changes in state; the !'s above
				 * serve to canonicalize the truth values.
				 */
				/* First make sure traceback will be accurate. */
				STORE_STATE_VARIABLES();
				oklog("%sWIZARDED: #%"PRIdN" by programmer #%"PRIdN"\n",
				      is_wizard(obj.v.obj) ? "DE" : "",
				      obj.v.obj, progr);
				print_error_backtrace(is_wizard(obj.v.obj)
						    ? "Wizard bit unset."
						      : "Wizard bit set.",
						      output_to_log);
			    }
			    break;
			case BP_R:
			case BP_W:
			case BP_F:
			    if (progr != db_object_owner(obj.v.obj)
				&& !is_wizard(progr))
				err = E_PERM;
			    break;
			case BP_LOCATION:
			case BP_CONTENTS:
			    err = E_PERM;
			    break;
			default:
			    panic("Unknown built-in property in OP_PUT_PROP!");
			}
		    }

		    free_var(propname);
		    free_var(obj);
		    if (err == E_NONE) {
			db_set_property_value(h, var_ref(rhs));
			PUSH(rhs);
		    } else {
			free_var(rhs);
			PUSH_ERROR(err);
		    }
		}
	    }
	    break;

	case OP_FORK:
	case OP_FORK_WITH_ID:
	    {
		Var time;
		unsigned id = 0, f_index;

		time = POP();
		f_index = READ_BYTES(bv, bc.numbytes_fork);
		if (op == OP_FORK_WITH_ID)
		    id = READ_BYTES(bv, bc.numbytes_var_name);
		if (time.type != TYPE_INT) {
		    free_var(time);
		    RAISE_ERROR(E_TYPE);
		} else if (time.v.num < 0) {
		    free_var(time);
		    RAISE_ERROR(E_INVARG);
		} else {
		    enum error e;

		    e = enqueue_forked_task2(RUN_ACTIV, f_index, time.v.num,
					op == OP_FORK_WITH_ID ? id : -1);
		    if (e != E_NONE)
			RAISE_ERROR(e);
		}
	    }
	    break;

	case OP_CALL_VERB:
	    {
		enum error err = E_NONE;
		Var args, verb, obj;
		Objid class;

		args = POP();	/* args, should be list */
		verb = POP();	/* verbname, should be string */
		obj = POP();	/* objid, should be obj */

		if (verb.type != TYPE_STR || args.type != TYPE_LIST) {
		    err = E_TYPE;
		    class = NOTHING;	/* shut up gcc */
		} else if (obj.type == TYPE_WAIF) {
		    char *str = mymalloc(strlen(verb.v.str) + 2, M_STRING);

		    class = obj.v.waif->class;
		    str[0] = WAIF_VERB_PREFIX;
		    strcpy(str + 1, verb.v.str);
		    free_str(verb.v.str);
		    verb.v.str = str;
		} else if (obj.type == TYPE_OBJ) {
		    class = obj.v.obj;
		    if (verb.v.str[0] == WAIF_VERB_PREFIX)
			err = E_VERBNF;
		} else {
		    err = E_TYPE;
		    class = NOTHING;	/* shut up gcc */
		}

		if (err == E_NONE && !valid(class))
		    err = E_INVIND;

		if (err == E_NONE) {
		    STORE_STATE_VARIABLES();
		    err = call_verb2(class, verb.v.str, obj, args, 0);
		    /* if there is no error, RUN_ACTIV is now the CALLEE's.
		       args will be consumed in the new rt_env */
		    /* if there is an error, then RUN_ACTIV is unchanged, and
		       args is not consumed in this case */
		    LOAD_STATE_VARIABLES();
		}
		free_var(obj);
		free_var(verb);

		if (err != E_NONE) {	/* there is an error, RUN_ACTIV unchanged, 
					   args must be freed */
		    free_var(args);
		    PUSH_ERROR(err);
		}
	    }
	    break;

	case OP_RETURN:
	case OP_RETURN0:
	case OP_DONE:
	    {
		Var ret_val;

		if (op == OP_RETURN)
		    ret_val = POP();
		else
		    ret_val = zero;

		STORE_STATE_VARIABLES();
		if (unwind_stack(FIN_RETURN, ret_val, &outcome)) {
		    if (result && outcome == OUTCOME_DONE)
			*result = ret_val;
		    else
			free_var(ret_val);
		    return outcome;
		}
		LOAD_STATE_VARIABLES();
	    }
	    break;

	case OP_BI_FUNC_CALL:
	    {
		unsigned func_id;
		Var args;

		func_id = READ_BYTES(bv, 1);	/* 1 == numbytes of func_id */
		args = POP();	/* should be list */
		if (args.type != TYPE_LIST) {
		    free_var(args);
		    PUSH_ERROR(E_TYPE);
		} else {
		    package p;

		    STORE_STATE_VARIABLES();
		    p = call_bi_func(func_id, args, 1, RUN_ACTIV.progr, 0);
		    LOAD_STATE_VARIABLES();

		    switch (p.kind) {
		    case BI_RETURN:
			PUSH(p.u.ret);
			break;
		    case BI_RAISE:
			if (RUN_ACTIV.debug) {
			    if (raise_error(p, 0))
				return OUTCOME_ABORTED;
			    else
				LOAD_STATE_VARIABLES();
			} else {
			    PUSH(p.u.raise.code);
			    free_str(p.u.raise.msg);
			    free_var(p.u.raise.value);
			}
			break;
		    case BI_CALL:
			/* another activ has been pushed onto activ_stack */
			RUN_ACTIV.bi_func_id = func_id;
			RUN_ACTIV.bi_func_data = p.u.call.data;
			RUN_ACTIV.bi_func_pc = p.u.call.pc;
			break;
		    case BI_SUSPEND:
			{
			    enum error e = suspend_task(p);

			    if (e == E_NONE)
				return OUTCOME_BLOCKED;
			    else
				PUSH_ERROR(e);
			}
			break;
		    case BI_KILL:
			STORE_STATE_VARIABLES();
			unwind_stack(FIN_ABORT, zero, 0);
			return OUTCOME_ABORTED;
			/* NOTREACHED */
		    }
		}
	    }
	    break;

	case OP_EXTENDED:
	    {
		register enum Extended_Opcode eop = *bv;
		bv++;
		if (COUNT_EOP_TICK(eop))
		    ticks_remaining--;
		switch (eop) {
		case EOP_RANGESET:
		    {
			Var base, from, to, value;

			value = POP();	/* rhs value (list or string) */
			to = POP();	/* end of range (integer) */
			from = POP();	/* start of range (integer) */
			base = POP();	/* lhs (list or string) */
			/* base[from..to] = value */
			if (to.type != TYPE_INT || from.type != TYPE_INT
			    || (base.type != TYPE_LIST && base.type != TYPE_STR)
			    || (value.type != TYPE_LIST && value.type != TYPE_STR)
			    || (base.type != value.type)) {
			    free_var(base);
			    free_var(to);
			    free_var(from);
			    free_var(value);
			    PUSH_ERROR(E_TYPE);
			} else if (rangeset_check(base.type == TYPE_STR
						  ? memo_strlen(base.v.str)
						  : base.v.list[0].v.num,
						  from.v.num, to.v.num)) {
			    free_var(base);
			    free_var(to);
			    free_var(from);
			    free_var(value);
			    PUSH_ERROR(E_RANGE);
			} else if (base.type == TYPE_LIST)
			    PUSH(listrangeset(base, from.v.num, to.v.num, value));
			else	/* TYPE_STR */
			    PUSH(strrangeset(base, from.v.num, to.v.num, value));
		    }
		    break;

		case EOP_LENGTH:
		    {
			unsigned i = READ_BYTES(bv, bc.numbytes_stack);
			Var item, v;

			v.type = TYPE_INT;
			item = RUN_ACTIV.base_rt_stack[i];
			if (item.type == TYPE_STR) {
			    v.v.num = strlen_utf(item.v.str);
			    PUSH(v);
			} else if (item.type == TYPE_LIST) {
			    v.v.num = item.v.list[0].v.num;
			    PUSH(v);
			} else
			    PUSH_ERROR(E_TYPE);
		    }
		    break;

		case EOP_EXP:
		    {
			Var lhs, rhs, ans;

			rhs = POP();
			lhs = POP();
			ans = do_power(lhs, rhs);
			free_var(lhs);
			free_var(rhs);
			if (ans.type == TYPE_ERR)
			    PUSH_ERROR(ans.v.err);
			else
			    PUSH(ans);
		    }
		    break;

		case EOP_SCATTER:
		    {
			int nargs = READ_BYTES(bv, 1);
			int nreq = READ_BYTES(bv, 1);
			int rest = READ_BYTES(bv, 1);
			int have_rest = (rest > nargs ? 0 : 1);
			Var list;
			int len = 0, nopt_avail, nrest, i, offset;
			int done, where = 0;
			enum error e = E_NONE;

			list = TOP_RT_VALUE;
			if (list.type != TYPE_LIST)
			    e = E_TYPE;
			else if ((len = list.v.list[0].v.num) < nreq
				 || (!have_rest && len > nargs))
			    e = E_ARGS;

			if (e != E_NONE) {	/* skip rest of operands */
			    free_var(POP());	/* replace list with error code */
			    PUSH_ERROR(e);
			    for (i = 1; i <= nargs; i++) {
				SKIP_BYTES(bv, bc.numbytes_var_name);
				SKIP_BYTES(bv, bc.numbytes_label);
			    }
			} else {
			    nopt_avail = len - nreq;
			    nrest = (have_rest && len >= nargs ? len - nargs + 1
				     : 0);
			    for (offset = 0, i = 1; i <= nargs; i++) {
				int id = READ_BYTES(bv, bc.numbytes_var_name);
				int label = READ_BYTES(bv, bc.numbytes_label);

				if (i == rest) {	/* rest */
				    free_var(RUN_ACTIV.rt_env[id]);
				    RUN_ACTIV.rt_env[id] = sublist(var_ref(list),
								   i,
							  i + nrest - 1);
				    offset += nrest - 1;
				} else if (label == 0) {	/* required */
				    free_var(RUN_ACTIV.rt_env[id]);
				    RUN_ACTIV.rt_env[id] =
					var_ref(list.v.list[i + offset]);
				} else {	/* optional */
				    if (nopt_avail > 0) {
					nopt_avail--;
					free_var(RUN_ACTIV.rt_env[id]);
					RUN_ACTIV.rt_env[id] =
					    var_ref(list.v.list[i + offset]);
				    } else {
					offset--;
					if (where == 0 && label != 1)
					    where = label;
				    }
				}
			    }
			}

			done = READ_BYTES(bv, bc.numbytes_label);
			if (where == 0)
			    JUMP(done);
			else
			    JUMP(where);
		    }
		    break;

		case EOP_PUSH_LABEL:
		case EOP_TRY_FINALLY:
		    {
			Var v;

			v.type = (eop == EOP_PUSH_LABEL ? TYPE_INT : TYPE_FINALLY);
			v.v.num = READ_BYTES(bv, bc.numbytes_label);
			PUSH(v);
		    }
		    break;

		case EOP_CATCH:
		case EOP_TRY_EXCEPT:
		    {
			Var v;

			v.type = TYPE_CATCH;
			v.v.num = (eop == EOP_CATCH ? 1 : READ_BYTES(bv, 1));
			PUSH(v);
		    }
		    break;

		case EOP_END_CATCH:
		case EOP_END_EXCEPT:
		    {
			Var v, marker;
			int i;
			unsigned lab;

			if (eop == EOP_END_CATCH)
			    v = POP();

			marker = POP();
			if (marker.type != TYPE_CATCH)
			    panic("Stack marker is not TYPE_CATCH!");
			for (i = 0; i < marker.v.num; i++) {
			    (void) POP();	/* handler PC */
			    free_var(POP());	/* code list */
			}

			if (eop == EOP_END_CATCH)
			    PUSH(v);

			lab = READ_BYTES(bv, bc.numbytes_label);
			JUMP(lab);
		    }
		    break;

		case EOP_END_FINALLY:
		    {
			Var v, why;

			v = POP();
			if (v.type != TYPE_FINALLY)
			    panic("Stack marker is not TYPE_FINALLY!");
			why.type = TYPE_INT;
			why.v.num = FIN_FALL_THRU;
			PUSH(why);
			PUSH(zero);
		    }
		    break;

		case EOP_CONTINUE:
		    {
			Var v, why;

			v = POP();
			why = POP();
			switch (why.type == TYPE_INT ? why.v.num : -1) {
			case FIN_FALL_THRU:
			    /* Do nothing; normal case. */
			    break;
			case FIN_EXIT:
			case FIN_RAISE:
			case FIN_RETURN:
			case FIN_UNCAUGHT:
			    STORE_STATE_VARIABLES();
			    if (unwind_stack(why.v.num, v, &outcome))
				return outcome;
			    LOAD_STATE_VARIABLES();
			    break;
			default:
			    panic("Unknown FINALLY reason!");
			}
		    }
		    break;

		case EOP_WHILE_ID:
		    {
			unsigned id = READ_BYTES(bv, bc.numbytes_var_name);
			free_var(RUN_ACTIV.rt_env[id]);
			RUN_ACTIV.rt_env[id] = var_ref(TOP_RT_VALUE);
		    }
		    goto do_test;

		case EOP_EXIT_ID:
		    SKIP_BYTES(bv, bc.numbytes_var_name);	/* ignore id */
		    /* fall thru */
		case EOP_EXIT:
		    {
			Var v;

			v = new_list(2);
			v.v.list[1].type = TYPE_INT;
			v.v.list[1].v.num = READ_BYTES(bv, bc.numbytes_stack);
			v.v.list[2].type = TYPE_INT;
			v.v.list[2].v.num = READ_BYTES(bv, bc.numbytes_label);
			STORE_STATE_VARIABLES();
			unwind_stack(FIN_EXIT, v, 0);
			LOAD_STATE_VARIABLES();
		    }
		    break;

		case EOP_BITAND:
		case EOP_BITXOR:
		case EOP_BITOR:
		    {
			Var rhs, lhs, ans;

			rhs = POP();
			lhs = POP();
			if (lhs.type == TYPE_INT && rhs.type == TYPE_INT) {
			    ans.type = TYPE_INT;
			    if (eop == EOP_BITAND)
				ans.v.num = lhs.v.num & rhs.v.num;
			    else if (eop == EOP_BITXOR)
				ans.v.num = lhs.v.num ^ rhs.v.num;
			    else if (eop == EOP_BITOR)
				ans.v.num = lhs.v.num | rhs.v.num;
			    else
				panic("Can't happen in EOP bitwise operators!");
			} else {
			    ans.type = TYPE_ERR;
			    ans.v.err = E_TYPE;
			}

			free_var(lhs);
			free_var(rhs);
			if (ans.type == TYPE_ERR)
			    PUSH_ERROR(ans.v.err);
			else
			    PUSH(ans);
		    }
		    break;

		case EOP_SHL:
		case EOP_SHR:
		case EOP_LSHR:
		    {
			Var rhs, lhs, ans;

			rhs = POP();
			lhs = POP();
			if (lhs.type == TYPE_INT && rhs.type == TYPE_INT) {
			    if (rhs.v.num < 0
				|| rhs.v.num >= sizeof(Num) * CHAR_BIT) {
				ans.type = TYPE_ERR;
				ans.v.err = E_INVARG;
			    } else {

/*
 * Defines logical and arithmetic right shift behavior. Needed because
 * ANSI C doesn't define what happens when you right shift a negative
 * number.
 */
#define HIGHONES(c)	((Num)(~(UNum)0 << sizeof(Num) * CHAR_BIT - (c)))
#define LOWONES(c)	(~HIGHONES(c))
#define LOGSHIFTR(a,b)	((Num)((UNum)a >> b) & LOWONES(b))
#define SHIFTR(a,b)	(LOGSHIFTR(a,b) ^ (a < 0 ? HIGHONES(b) : 0))

				ans.type = TYPE_INT;
				if (eop == EOP_SHL)
				    ans.v.num = lhs.v.num << rhs.v.num;
				else if (eop == EOP_SHR)
				    ans.v.num = SHIFTR(lhs.v.num, rhs.v.num);
				else if (eop == EOP_LSHR)
				    ans.v.num = LOGSHIFTR(lhs.v.num, rhs.v.num);
				else
				    panic("Can't happen in EOP bitwise operators!");
			    }
			} else {
			    ans.type = TYPE_ERR;
			    ans.v.err = E_TYPE;
			}

			free_var(lhs);
			free_var(rhs);
			if (ans.type == TYPE_ERR)
			    PUSH_ERROR(ans.v.err);
			else
			    PUSH(ans);
		    }
		    break;

		case EOP_COMPLEMENT:
		    {
			Var arg, ans;

			arg = POP();
			if (arg.type == TYPE_INT) {
			    ans.type = TYPE_INT;
			    ans.v.num = ~arg.v.num;
			} else {
			    free_var(arg);
			    PUSH_ERROR(E_TYPE);
			    break;
			}

			PUSH(ans);
			free_var(arg);
		    }
		    break;

		default:
		    panic("Unknown extended opcode!");
		}
	    }
	    break;

	    /* These opcodes account for about 20% of all opcodes executed, so
	       let's split out the case stmt so the compiler can help us out.
	       If you're here because the #error below got tripped, just change
	       the set of case stmts below for OP_PUSH and OP_PUT to
	       be 0..NUM_READY_VARS-1.
	     */
#if NUM_READY_VARS != 32
#error NUM_READY_VARS expected to be 32
#endif
	case OP_PUSH:
	case OP_PUSH + 1:
	case OP_PUSH + 2:
	case OP_PUSH + 3:
	case OP_PUSH + 4:
	case OP_PUSH + 5:
	case OP_PUSH + 6:
	case OP_PUSH + 7:
	case OP_PUSH + 8:
	case OP_PUSH + 9:
	case OP_PUSH + 10:
	case OP_PUSH + 11:
	case OP_PUSH + 12:
	case OP_PUSH + 13:
	case OP_PUSH + 14:
	case OP_PUSH + 15:
	case OP_PUSH + 16:
	case OP_PUSH + 17:
	case OP_PUSH + 18:
	case OP_PUSH + 19:
	case OP_PUSH + 20:
	case OP_PUSH + 21:
	case OP_PUSH + 22:
	case OP_PUSH + 23:
	case OP_PUSH + 24:
	case OP_PUSH + 25:
	case OP_PUSH + 26:
	case OP_PUSH + 27:
	case OP_PUSH + 28:
	case OP_PUSH + 29:
	case OP_PUSH + 30:
	case OP_PUSH + 31:
	    {
		Var value;
		value = RUN_ACTIV.rt_env[PUSH_n_INDEX(op)];
		if (value.type == TYPE_NONE) {
		    free_var(value);
		    PUSH_ERROR(E_VARNF);
		} else
		    PUSH_REF(value);
	    }
	    break;

#ifdef BYTECODE_REDUCE_REF
	case OP_PUSH_CLEAR:
	case OP_PUSH_CLEAR + 1:
	case OP_PUSH_CLEAR + 2:
	case OP_PUSH_CLEAR + 3:
	case OP_PUSH_CLEAR + 4:
	case OP_PUSH_CLEAR + 5:
	case OP_PUSH_CLEAR + 6:
	case OP_PUSH_CLEAR + 7:
	case OP_PUSH_CLEAR + 8:
	case OP_PUSH_CLEAR + 9:
	case OP_PUSH_CLEAR + 10:
	case OP_PUSH_CLEAR + 11:
	case OP_PUSH_CLEAR + 12:
	case OP_PUSH_CLEAR + 13:
	case OP_PUSH_CLEAR + 14:
	case OP_PUSH_CLEAR + 15:
	case OP_PUSH_CLEAR + 16:
	case OP_PUSH_CLEAR + 17:
	case OP_PUSH_CLEAR + 18:
	case OP_PUSH_CLEAR + 19:
	case OP_PUSH_CLEAR + 20:
	case OP_PUSH_CLEAR + 21:
	case OP_PUSH_CLEAR + 22:
	case OP_PUSH_CLEAR + 23:
	case OP_PUSH_CLEAR + 24:
	case OP_PUSH_CLEAR + 25:
	case OP_PUSH_CLEAR + 26:
	case OP_PUSH_CLEAR + 27:
	case OP_PUSH_CLEAR + 28:
	case OP_PUSH_CLEAR + 29:
	case OP_PUSH_CLEAR + 30:
	case OP_PUSH_CLEAR + 31:
	    {
		Var *vp;
		vp = &RUN_ACTIV.rt_env[PUSH_CLEAR_n_INDEX(op)];
		if (vp->type == TYPE_NONE) {
		    PUSH_ERROR(E_VARNF);
		} else {
		    PUSH(*vp);
		    vp->type = TYPE_NONE;
		}
	    }
	    break;
#endif				/* BYTECODE_REDUCE_REF */

	case OP_PUT:
	case OP_PUT + 1:
	case OP_PUT + 2:
	case OP_PUT + 3:
	case OP_PUT + 4:
	case OP_PUT + 5:
	case OP_PUT + 6:
	case OP_PUT + 7:
	case OP_PUT + 8:
	case OP_PUT + 9:
	case OP_PUT + 10:
	case OP_PUT + 11:
	case OP_PUT + 12:
	case OP_PUT + 13:
	case OP_PUT + 14:
	case OP_PUT + 15:
	case OP_PUT + 16:
	case OP_PUT + 17:
	case OP_PUT + 18:
	case OP_PUT + 19:
	case OP_PUT + 20:
	case OP_PUT + 21:
	case OP_PUT + 22:
	case OP_PUT + 23:
	case OP_PUT + 24:
	case OP_PUT + 25:
	case OP_PUT + 26:
	case OP_PUT + 27:
	case OP_PUT + 28:
	case OP_PUT + 29:
	case OP_PUT + 30:
	case OP_PUT + 31:
	    {
		Var *varp = &RUN_ACTIV.rt_env[PUT_n_INDEX(op)];
		free_var(*varp);
		if (bv[0] == OP_POP) {
		    *varp = POP();
		    ++bv;
		} else
		    *varp = var_ref(TOP_RT_VALUE);
	    }
	    break;

	default:
	    if (IS_OPTIM_NUM_OPCODE(op)) {
		Var value;
		value.type = TYPE_INT;
		value.v.num = OPCODE_TO_OPTIM_NUM(op);
		PUSH(value);
	    } else
		panic("Unknown opcode!");
	    break;
	}
    }
}


/**** manipulating data of task ****/

static int timeouts_enabled = 1;	/* set to 0 in debugger to disable
					   timeouts */

static void
task_timeout(Timer_ID id, Timer_Data data)
{
    task_timed_out = timeouts_enabled;
}

static Timer_ID
setup_task_execution_limits(int seconds, int ticks)
{
    task_alarm_id = set_virtual_timer(seconds < 1 ? 1 : seconds,
				      task_timeout, 0);
    task_timed_out = 0;
    ticks_remaining = (ticks < 100 ? 100 : ticks);
    return task_alarm_id;
}

enum outcome
run_interpreter(char raise, enum error e,
		Var * result, int is_fg, int do_db_tracebacks)
    /* raise is boolean, true iff an error should be raised.
       e is the specific error to be raised if so.
       (in earlier versions, an error was raised iff e != E_NONE,
       but now it's possible to raise E_NONE on resumption from
       suspend().) */
{
    enum outcome ret;

    setup_task_execution_limits(is_fg ? server_int_option("fg_seconds",
						      DEFAULT_FG_SECONDS)
				: server_int_option("bg_seconds",
						    DEFAULT_BG_SECONDS),
				is_fg ? server_int_option("fg_ticks",
							DEFAULT_FG_TICKS)
				: server_int_option("bg_ticks",
						    DEFAULT_BG_TICKS));

    handler_verb_args = zero;
    handler_verb_name = 0;
    interpreter_is_running = 1;
    ret = run(raise, e, result);
    interpreter_is_running = 0;
    task_timed_out = 0;
    cancel_timer(task_alarm_id);

    if (ret == OUTCOME_ABORTED && handler_verb_name) {
	db_verb_handle h;
        enum outcome hret;
	Var args, handled, traceback;
	int i;

	args = handler_verb_args;
	h = db_find_callable_verb(SYSTEM_OBJECT, handler_verb_name);
	if (do_db_tracebacks && h.ptr) {
	    hret = do_server_verb_task(SYSTEM_OBJECT, handler_verb_name,
				       var_ref(handler_verb_args), h,
				       activ_stack[0].player, "", &handled,
				       0/*no-traceback*/);
	    if ((hret == OUTCOME_DONE && is_true(handled))
		|| hret == OUTCOME_BLOCKED) {
		/* Assume the in-DB code handled it */
		free_var(args);
		return OUTCOME_ABORTED;		/* original ret value */
	    }
	}
	i = args.v.list[0].v.num;
	traceback = args.v.list[i];	/* traceback is always the last argument */
	for (i = 1; i <= traceback.v.list[0].v.num; i++)
	    notify(activ_stack[0].player, traceback.v.list[i].v.str);
	free_var(args);
    }
    return ret;
}


Objid
caller()
{
    return RUN_ACTIV.this;	/* XXX waifs?! */
}

static void
check_activ_stack_size(int max)
{
    if (max_stack_size != max) {
	if (activ_stack)
	    myfree(activ_stack, M_VM);

	activ_stack = mymalloc(sizeof(activation) * max, M_VM);
	max_stack_size = max;
    }
}

static int
current_max_stack_size(void)
{
    int max = server_int_option("max_stack_depth", DEFAULT_MAX_STACK_DEPTH);

    if (max < DEFAULT_MAX_STACK_DEPTH)
	max = DEFAULT_MAX_STACK_DEPTH;

    return max;
}

/**** There are two methods of starting a new task:
   (1) Create a new one
   (2) Resume an old one  */

/* procedure to create a new task */

static enum outcome
do_task(Program * prog, int which_vector, Var * result, int is_fg, int do_db_tracebacks)
{				/* which vector determines the vector for the root_activ.
				   a forked task can also have which_vector == MAIN_VECTOR.
				   this happens iff it is recovered from a read from disk,
				   because in that case the forked statement is parsed as 
				   the main vector */

    RUN_ACTIV.prog = program_ref(prog);

    root_activ_vector = which_vector;	/* main or which of the forked */
    alloc_rt_stack(&RUN_ACTIV, (which_vector == MAIN_VECTOR
				? prog->main_vector.max_stack
			  : prog->fork_vectors[which_vector].max_stack));

    RUN_ACTIV.pc = 0;
    RUN_ACTIV.error_pc = 0;
    RUN_ACTIV.bi_func_pc = 0;
    RUN_ACTIV.temp.type = TYPE_NONE;

    return run_interpreter(0, E_NONE, result, is_fg, do_db_tracebacks);
}

/* procedure to resume an old task */

enum outcome
resume_from_previous_vm(vm the_vm, Var v)
{
    int i;

    check_activ_stack_size(the_vm->max_stack_size);
    top_activ_stack = the_vm->top_activ_stack;
    root_activ_vector = the_vm->root_activ_vector;
    for (i = 0; i <= top_activ_stack; i++)
	activ_stack[i] = the_vm->activ_stack[i];

    free_vm(the_vm, 0);

    if (v.type == TYPE_ERR)
	return run_interpreter(1, v.v.err, 0, 0/*bg*/, 1/*traceback*/);
    else {
	/* PUSH_REF(v) */
	*(RUN_ACTIV.top_rt_stack++) = var_ref(v);

	return run_interpreter(0, E_NONE, 0, 0/*bg*/, 1/*traceback*/);
    }
}


/*** external functions ***/

enum outcome
do_server_verb_task(Objid this, const char *verb, Var args, db_verb_handle h,
		    Objid player, const char *argstr, Var * result,
		    int do_db_tracebacks)
{
    return do_server_program_task(this, verb, args, db_verb_definer(h),
				  db_verb_names(h), db_verb_program(h),
				  db_verb_owner(h),
				  db_verb_flags(h) & VF_DEBUG,
			       player, argstr, result, do_db_tracebacks);
}

enum outcome
do_server_program_task(Objid this, const char *verb, Var args, Objid vloc,
		    const char *verbname, Program * program, Objid progr,
		       int debug, Objid player, const char *argstr,
		       Var * result, int do_db_tracebacks)
{
    Var *env;

    check_activ_stack_size(current_max_stack_size());
    top_activ_stack = 0;

    RUN_ACTIV.rt_env = env = new_rt_env(program->num_var_names);
    RUN_ACTIV.this = this;
    RUN_ACTIV.THIS.type = TYPE_OBJ;
    RUN_ACTIV.THIS.v.obj = this;
    RUN_ACTIV.player = player;
    RUN_ACTIV.progr = progr;
    RUN_ACTIV.vloc = vloc;
    RUN_ACTIV.verb = str_dup(verb);
    RUN_ACTIV.verbname = str_dup(verbname);
    RUN_ACTIV.debug = debug;
    fill_in_rt_consts(env, program->version);
    set_rt_env_obj(env, SLOT_PLAYER, player);
    set_rt_env_obj(env, SLOT_CALLER, -1);
    set_rt_env_obj(env, SLOT_THIS, this);
    set_rt_env_obj(env, SLOT_DOBJ, NOTHING);
    set_rt_env_obj(env, SLOT_IOBJ, NOTHING);
    set_rt_env_str(env, SLOT_DOBJSTR, str_dup(""));
    set_rt_env_str(env, SLOT_IOBJSTR, str_dup(""));
    set_rt_env_str(env, SLOT_ARGSTR, str_dup(argstr));
    set_rt_env_str(env, SLOT_PREPSTR, str_dup(""));
    set_rt_env_str(env, SLOT_VERB, str_ref(RUN_ACTIV.verb));
    set_rt_env_var(env, SLOT_ARGS, args);

    return do_task(program, MAIN_VECTOR, result, 1/*fg*/, do_db_tracebacks);
}

enum outcome
do_input_task(Objid user, Parsed_Command * pc, Objid this, db_verb_handle vh)
{
    Program *prog = db_verb_program(vh);
    Var *env;

    check_activ_stack_size(current_max_stack_size());
    top_activ_stack = 0;

    RUN_ACTIV.rt_env = env = new_rt_env(prog->num_var_names);
    RUN_ACTIV.this = this;
    RUN_ACTIV.THIS.type = TYPE_OBJ;
    RUN_ACTIV.THIS.v.obj = this;
    RUN_ACTIV.player = user;
    RUN_ACTIV.progr = db_verb_owner(vh);
    RUN_ACTIV.vloc = db_verb_definer(vh);
    RUN_ACTIV.verb = str_ref(pc->verb);
    RUN_ACTIV.verbname = str_ref(db_verb_names(vh));
    RUN_ACTIV.debug = (db_verb_flags(vh) & VF_DEBUG);
    fill_in_rt_consts(env, prog->version);
    set_rt_env_obj(env, SLOT_PLAYER, user);
    set_rt_env_obj(env, SLOT_CALLER, user);
    set_rt_env_obj(env, SLOT_THIS, this);
    set_rt_env_obj(env, SLOT_DOBJ, pc->dobj);
    set_rt_env_obj(env, SLOT_IOBJ, pc->iobj);
    set_rt_env_str(env, SLOT_DOBJSTR, str_ref(pc->dobjstr));
    set_rt_env_str(env, SLOT_IOBJSTR, str_ref(pc->iobjstr));
    set_rt_env_str(env, SLOT_ARGSTR, str_ref(pc->argstr));
    set_rt_env_str(env, SLOT_PREPSTR, str_ref(pc->prepstr));
    set_rt_env_str(env, SLOT_VERB, str_ref(pc->verb));
    set_rt_env_var(env, SLOT_ARGS, var_ref(pc->args));

    return do_task(prog, MAIN_VECTOR, 0, 1/*fg*/, 1/*traceback*/);
}

enum outcome
do_forked_task(Program * prog, Var * rt_env, activation a, int f_id)
{
    check_activ_stack_size(current_max_stack_size());
    top_activ_stack = 0;

    RUN_ACTIV = a;
    RUN_ACTIV.rt_env = rt_env;

    return do_task(prog, f_id, 0, 0/*bg*/, 1/*traceback*/);
}

/* this is called from bf_eval to set up stack for an eval call */

int
setup_activ_for_eval(Program * prog)
{
    Var *env;
    if (!push_activation())
	return 0;

    RUN_ACTIV.prog = prog;

    RUN_ACTIV.rt_env = env = new_rt_env(prog->num_var_names);
    fill_in_rt_consts(env, prog->version);
    set_rt_env_obj(env, SLOT_PLAYER, CALLER_ACTIV.player);
    set_rt_env_obj(env, SLOT_CALLER, CALLER_ACTIV.this);
    set_rt_env_obj(env, SLOT_THIS, NOTHING);
    set_rt_env_obj(env, SLOT_DOBJ, NOTHING);
    set_rt_env_obj(env, SLOT_IOBJ, NOTHING);
    set_rt_env_str(env, SLOT_DOBJSTR, str_dup(""));
    set_rt_env_str(env, SLOT_IOBJSTR, str_dup(""));
    set_rt_env_str(env, SLOT_ARGSTR, str_dup(""));
    set_rt_env_str(env, SLOT_PREPSTR, str_dup(""));
    set_rt_env_str(env, SLOT_VERB, str_dup(""));
    set_rt_env_var(env, SLOT_ARGS, new_list(0));

    RUN_ACTIV.this = NOTHING;
    RUN_ACTIV.THIS.type = TYPE_OBJ;
    RUN_ACTIV.THIS.v.obj = NOTHING;
    RUN_ACTIV.player = CALLER_ACTIV.player;
    RUN_ACTIV.progr = CALLER_ACTIV.progr;
    RUN_ACTIV.vloc = NOTHING;
    RUN_ACTIV.verb = str_dup("");
    RUN_ACTIV.verbname = str_dup("Input to EVAL");
    RUN_ACTIV.debug = 1;
    alloc_rt_stack(&RUN_ACTIV, RUN_ACTIV.prog->main_vector.max_stack);
    RUN_ACTIV.pc = 0;
    RUN_ACTIV.error_pc = 0;
    RUN_ACTIV.temp.type = TYPE_NONE;

    return 1;
}

/**** built in functions ****/

struct cf_state {
    unsigned fnum;
    void *data;
};

static package
bf_call_function(Var arglist, Byte next, void *vdata, Objid progr)
{
    package p;
    unsigned fnum;
    struct cf_state *s;

    if (next == 1) {		/* first call */
	const char *fname = arglist.v.list[1].v.str;

	fnum = number_func_by_name(fname);
	if (fnum == FUNC_NOT_FOUND) {
	    p = make_raise_pack(E_INVARG, "Unknown built-in function",
				var_ref(arglist.v.list[1]));
	    free_var(arglist);
	} else {
	    arglist = listdelete(arglist, 1);
	    p = call_bi_func(fnum, arglist, next, progr, vdata);
	}
    } else {			/* return to function */
	s = vdata;
	fnum = s->fnum;
	p = call_bi_func(fnum, arglist, next, progr, s->data);
	free_data(s);
    }

    if (p.kind == BI_CALL) {
	s = alloc_data(sizeof(struct cf_state));
	s->fnum = fnum;
	s->data = p.u.call.data;
	p.u.call.data = s;
    }
    return p;
}

static void
bf_call_function_write(void *data)
{
    struct cf_state *s = data;

    dbio_printf("bf_call_function data: fname = %s\n",
		name_func_by_num(s->fnum));
    write_bi_func_data(s->data, s->fnum);
}

static void *
bf_call_function_read(void)
{
    struct cf_state *s = alloc_data(sizeof(struct cf_state));
    const char *line = dbio_read_string();
    const char *hdr = "bf_call_function data: fname = ";
    int hlen = strlen(hdr);

    if (!strncmp(line, hdr, hlen)) {
	line += hlen;
	if ((s->fnum = number_func_by_name(line)) == FUNC_NOT_FOUND)
	    errlog("CALL_FUNCTION: Unknown built-in function: %s\n", line);
	else if (read_bi_func_data(s->fnum, &s->data, pc_for_bi_func_data()))
	    return s;
    }
    return 0;
}

static package
bf_raise(Var arglist, Byte next, void *vdata, Objid progr)
{
    package p;
    int nargs = arglist.v.list[0].v.num;
    Var code = var_ref(arglist.v.list[1]);
    const char *msg = (nargs >= 2
		       ? str_ref(arglist.v.list[2].v.str)
		       : str_dup(value2str(code)));
    Var value;

    value = (nargs >= 3 ? var_ref(arglist.v.list[3]) : zero);
    free_var(arglist);
    p.kind = BI_RAISE;
    p.u.raise.code = code;
    p.u.raise.msg = msg;
    p.u.raise.value = value;

    return p;
}

static package
bf_suspend(Var arglist, Byte next, void *vdata, Objid progr)
{
    static int seconds;
    int nargs = arglist.v.list[0].v.num;

    if (nargs >= 1)
	seconds = arglist.v.list[1].v.num;
    else
	seconds = -1;
    free_var(arglist);

    if (nargs >= 1 && seconds < 0)
	return make_error_pack(E_INVARG);
    else
	return make_suspend_pack(enqueue_suspended_task, &seconds);
}

static package
bf_read(Var arglist, Byte next, void *vdata, Objid progr)
{
    int argc = arglist.v.list[0].v.num;
    static Objid connection;
    int non_blocking = (argc >= 2
			&& is_true(arglist.v.list[2]));

    if (argc >= 1)
	connection = arglist.v.list[1].v.obj;
    else
	connection = activ_stack[0].player;
    free_var(arglist);

    /* Permissions checking */
    if (argc >= 1) {
	if (!is_wizard(progr)
	    && (!valid(connection)
		|| progr != db_object_owner(connection)))
	    return make_error_pack(E_PERM);
    } else {
	if (!is_wizard(progr)
	    || last_input_task_id(connection) != current_task_id)
	    return make_error_pack(E_PERM);
    }

    if (non_blocking) {
	Var r;

	r = read_input_now(connection);
	if (r.type == TYPE_ERR)
	    return make_error_pack(r.v.err);
	else
	    return make_var_pack(r);
    }
    return make_suspend_pack(make_reading_task, &connection);
}

static package
bf_seconds_left(Var arglist, Byte next, void *vdata, Objid progr)
{
    Var r;
    r.type = TYPE_INT;
    r.v.num = timer_wakeup_interval(task_alarm_id);
    free_var(arglist);
    return make_var_pack(r);
}

static package
bf_ticks_left(Var arglist, Byte next, void *vdata, Objid progr)
{
    Var r;
    r.type = TYPE_INT;
    r.v.num = ticks_remaining;
    free_var(arglist);
    return make_var_pack(r);
}

static package
bf_pass(Var arglist, Byte next, void *vdata, Objid progr)
{
    enum error e = call_verb2(RUN_ACTIV.this, RUN_ACTIV.verb, RUN_ACTIV.THIS,
			      arglist, 1);

    if (e == E_NONE)
	return tail_call_pack();

    free_var(arglist);
    return make_error_pack(e);
}

static package
bf_set_task_perms(Var arglist, Byte next, void *vdata, Objid progr)
{				/* (player) */
    /* warning!!  modifies top activation */
    Objid oid = arglist.v.list[1].v.obj;

    free_var(arglist);

    if (progr != oid && !is_wizard(progr))
	return make_error_pack(E_PERM);

    RUN_ACTIV.progr = oid;
    return no_var_pack();
}

static package
bf_caller_perms(Var arglist, Byte next, void *vdata, Objid progr)
{				/* () */
    Var r;
    r.type = TYPE_OBJ;
    if (top_activ_stack == 0)
	r.v.obj = NOTHING;
    else
	r.v.obj = activ_stack[top_activ_stack - 1].progr;
    free_var(arglist);
    return make_var_pack(r);
}

static package
bf_callers(Var arglist, Byte next, void *vdata, Objid progr)
{
    int line_numbers_too = 0;

    if (arglist.v.list[0].v.num >= 1)
	line_numbers_too = is_true(arglist.v.list[1]);
    free_var(arglist);

    return make_var_pack(make_stack_list(activ_stack, 0, top_activ_stack, 0,
				   root_activ_vector, line_numbers_too));
}

static package
bf_task_stack(Var arglist, Byte next, void *vdata, Objid progr)
{
    int nargs = arglist.v.list[0].v.num;
    int id = arglist.v.list[1].v.num;
    int line_numbers_too = (nargs >= 2 && is_true(arglist.v.list[2]));
    vm the_vm = find_suspended_task(id);
    Objid owner = (the_vm ? progr_of_cur_verb(the_vm) : NOTHING);

    free_var(arglist);
    if (!the_vm)
	return make_error_pack(E_INVARG);
    if (!is_wizard(progr) && progr != owner)
	return make_error_pack(E_PERM);

    return make_var_pack(make_stack_list(the_vm->activ_stack, 0,
					 the_vm->top_activ_stack, 1,
					 the_vm->root_activ_vector,
					 line_numbers_too));
}

void
register_execute(void)
{
    register_function_with_read_write("call_function", 1, -1, bf_call_function,
				      bf_call_function_read,
				      bf_call_function_write,
				      TYPE_STR);
    register_function("raise", 1, 3, bf_raise, TYPE_ANY, TYPE_STR, TYPE_ANY);
    register_function("suspend", 0, 1, bf_suspend, TYPE_INT);
    register_function("read", 0, 2, bf_read, TYPE_OBJ, TYPE_ANY);

    register_function("seconds_left", 0, 0, bf_seconds_left);
    register_function("ticks_left", 0, 0, bf_ticks_left);
    register_function("pass", 0, -1, bf_pass);
    register_function("set_task_perms", 1, 1, bf_set_task_perms, TYPE_OBJ);
    register_function("caller_perms", 0, 0, bf_caller_perms);
    register_function("callers", 0, 1, bf_callers, TYPE_ANY);
    register_function("task_stack", 1, 2, bf_task_stack, TYPE_INT, TYPE_ANY);

#ifdef WAIF_DICT
    waif_index_verb = str_dup(WAIF_INDEX_VERB);
    waif_indexset_verb = str_dup(WAIF_INDEXSET_VERB);
#endif				/* WAIF_DICT */
}


/**** storing to/loading from database ****/

void
write_activ_as_pi(activation a)
{
    dbio_write_var(a.THIS);

    dbio_printf("%"PRIdN" -7 -8 %"PRIdN" -9 %"PRIdN" %"PRIdN" -10 %d\n",
		a.this, a.player, a.progr, a.vloc, a.debug);
    dbio_write_string("No");
    dbio_write_string("More");
    dbio_write_string("Parse");
    dbio_write_string("Infos");
    dbio_write_string(a.verb);
    dbio_write_string(a.verbname);
}

int
read_activ_as_pi(activation * a)
{
    Objid dummy;
    Var T;
    char c;

    T = dbio_read_var();

    /* I use a `dummy' variable here and elsewhere instead of the `*'
     * assignment-suppression syntax of `scanf' because it allows more
     * straightforward error checking; unfortunately, the standard says that
     * suppressed assignments are not counted in determining the returned value
     * of `scanf'...
     */
    if (dbio_scanf("%"SCNdN" %"SCNdN" %"SCNdN" %"SCNdN" %"SCNdN" %"SCNdN" %"SCNdN" %"SCNdN" %d%c",
		 &a->this, &dummy, &dummy, &a->player, &dummy, &a->progr,
		   &a->vloc, &dummy, &a->debug, &c) != 10
	|| c != '\n') {
	errlog("READ_A: Bad numbers.\n");
	return 0;
    }
    switch (T.type) {
    case TYPE_WAIF:
    case TYPE_OBJ:
	break;
    default:
	T.type = TYPE_OBJ;
	T.v.obj = a->this;
	break;
    }
    a->THIS = T;

    dbio_read_string();		/* was argstr */
    dbio_read_string();		/* was dobjstr */
    dbio_read_string();		/* was iobjstr */
    dbio_read_string();		/* was prepstr */
    a->verb = dbio_read_string_intern();
    a->verbname = dbio_read_string_intern();
    return 1;
}

void
write_rt_env(const char **var_names, Var * rt_env, unsigned size)
{
    unsigned i;

    dbio_printf("%d variables\n", size);
    for (i = 0; i < size; i++) {
	dbio_write_string(var_names[i]);
	dbio_write_var(rt_env[i]);
    }
}

int
read_rt_env(const char ***old_names, Var ** rt_env, int *old_size)
{
    unsigned i;

    if (dbio_scanf("%d variables\n", old_size) != 1) {
	errlog("READ_RT_ENV: Bad count.\n");
	return 0;
    }
    *old_names = (const char **) mymalloc((*old_size) * sizeof(char *),
					  M_NAMES);
    *rt_env = new_rt_env(*old_size);

    for (i = 0; i < *old_size; i++) {
	(*old_names)[i] = dbio_read_string_intern();
	(*rt_env)[i] = dbio_read_var();
    }
    return 1;
}

Var *
reorder_rt_env(Var * old_rt_env, const char **old_names,
	       int old_size, Program * prog)
{
    /* reorder old_rt_env, which is aligned according to old_names, 
       to align to prog->var_names -- return the new rt_env
       after freeing old_rt_env and old_names */

    unsigned size = prog->num_var_names;
    Var *rt_env = new_rt_env(size);

    unsigned i;

    for (i = 0; i < size; i++) {
	int slot;

	for (slot = 0; slot < old_size; slot++) {
	    if (mystrcasecmp(old_names[slot], prog->var_names[i]) == 0)
		break;
	}

	if (slot < old_size)
	    rt_env[i] = var_ref(old_rt_env[slot]);
    }

    free_rt_env(old_rt_env, old_size);
    for (i = 0; i < old_size; i++)
	free_str(old_names[i]);
    myfree((void *) old_names, M_NAMES);

    return rt_env;
}

void
write_activ(activation a)
{
    register Var *v;

    dbio_printf("language version %u\n", a.prog->version);
    dbio_write_program(a.prog);
    write_rt_env(a.prog->var_names, a.rt_env, a.prog->num_var_names);

    dbio_printf("%d rt_stack slots in use\n",
		a.top_rt_stack - a.base_rt_stack);

    for (v = a.base_rt_stack; v != a.top_rt_stack; v++)
	dbio_write_var(*v);

    write_activ_as_pi(a);
    dbio_write_var(a.temp);

    dbio_printf("%u %u %u\n", a.pc, a.bi_func_pc, a.error_pc);
    if (a.bi_func_pc != 0) {
	dbio_write_string(name_func_by_num(a.bi_func_id));
	write_bi_func_data(a.bi_func_data, a.bi_func_id);
    }
}

static int
check_pc_validity(Program * prog, int which_vector, unsigned pc)
{
    Bytecodes *bc = (which_vector == -1
		     ? &prog->main_vector
		     : &prog->fork_vectors[which_vector]);

    /* Current insn must be call to verb or built-in function like eval(),
     * move(), pass(), or suspend().
     */
    return (pc < bc->size
	    && (bc->vector[pc - 1] == OP_CALL_VERB
		|| bc->vector[pc - 2] == OP_BI_FUNC_CALL));
}

int
read_activ(activation * a, int which_vector)
{
    DB_Version version;
    unsigned int v;
    Var *old_rt_env;
    const char **old_names;
    int old_size, stack_in_use;
    unsigned i;
    const char *func_name;
    int max_stack;
    char c;

    if (dbio_input_version < DBV_Float)
	version = dbio_input_version;
    else if (dbio_scanf("language version %u\n", &v) != 1) {
	errlog("READ_ACTIV: Malformed language version\n");
	return 0;
    } else if (version = v, !check_version(version)) {
	errlog("READ_ACTIV: Unrecognized language version: %d\n",
	       version);
	return 0;
    }
    if (!(a->prog = dbio_read_program(version,
				      0, (void *) "suspended task"))) {
	errlog("READ_ACTIV: Malformed program\n");
	return 0;
    }
    if (!read_rt_env(&old_names, &old_rt_env, &old_size)) {
	errlog("READ_ACTIV: Malformed runtime environment\n");
	return 0;
    }
    a->rt_env = reorder_rt_env(old_rt_env, old_names, old_size, a->prog);

    max_stack = (which_vector == MAIN_VECTOR
		 ? a->prog->main_vector.max_stack
		 : a->prog->fork_vectors[which_vector].max_stack);
    alloc_rt_stack(a, max_stack);

    if (dbio_scanf("%d rt_stack slots in use\n", &stack_in_use) != 1) {
	errlog("READ_ACTIV: Bad stack_in_use number\n");
	return 0;
    }
    a->top_rt_stack = a->base_rt_stack;
    for (i = 0; i < stack_in_use; i++)
	*(a->top_rt_stack++) = dbio_read_var();

    if (!read_activ_as_pi(a)) {
	errlog("READ_ACTIV: Bad activ.  stack_in_use = %d\n", stack_in_use);
	return 0;
    }
    a->temp = dbio_read_var();

    if (dbio_scanf("%u %u%c", &a->pc, &i, &c) != 3) {
	errlog("READ_ACTIV: bad pc, next. stack_in_use = %d\n", stack_in_use);
	return 0;
    }
    a->bi_func_pc = i;

    if (c == '\n')
	a->error_pc = a->pc;
    else if (dbio_scanf("%u\n", &a->error_pc) != 1) {
	errlog("READ_ACTIV: no error pc.\n");
	return 0;
    }
    if (!check_pc_validity(a->prog, which_vector, a->pc)) {
	errlog("READ_ACTIV: Bad PC for suspended task.\n");
	return 0;
    }
    if (a->bi_func_pc != 0) {
	func_name = dbio_read_string();
	if ((i = number_func_by_name(func_name)) == FUNC_NOT_FOUND) {
	    errlog("READ_ACTIV: Unknown built-in function `%s'\n", func_name);
	    return 0;
	}
	a->bi_func_id = i;
	if (!read_bi_func_data(a->bi_func_id, &a->bi_func_data,
			       &a->bi_func_pc)) {
	    errlog("READ_ACTIV: Bad saved state for built-in function `%s'\n",
		   func_name);
	    return 0;
	}
    }
    return 1;
}


char rcsid_execute[] = "$Id$";

/* 
 * $Log$
 * Revision 1.13.2.6  2008/04/24 23:28:59  bjj
 * Merge HEAD onto WAIF, bringing it approximately to 1.8.3
 *
 *
 * Revision 1.13.2.5  2006/04/05 00:49:29  bjj
 * Critical fix for WAIF_DICT to correct a merge mistake.
 *
 * Revision 1.13.2.4  2005/10/03 05:50:29  bjj
 * Add Jay Carlson's WAIF DICT as build option.
 *
 * Revision 1.13.2.3  2005/09/29 06:56:18  bjj
 * Merge HEAD onto WAIF, bringing it approximately to 1.8.2
 *
 * Revision 1.13.2.2  2002/08/29 06:03:40  bjj
 * Quiet GCC in run(), toint/tofloat(waif) raises E_TYPE and waif.wizard=0
 *
 * Revision 1.13.2.1  2002/08/29 05:44:23  bjj
 * Add WAIF type as distributed in version 0.95 (one small merge).
 *
 * Revision 1.19  2006/12/06 23:54:53  wrog
 * Fix compiler warnings about undefined behavior (bv assigned twice in JUMP(READ_BYTES(...))) and unused values
 *
 * Revision 1.18  2006/09/26 02:03:59  pschwan
 * b=1552816
 * r=ben
 *
 * execute.c:run_interpreter() sometimes clobbers the real return code with that
 * of the traceback handler.  If |result| is non-NULL, this can lead to it being
 * used later on without ever having been initialized, causing "Unknown Var type"
 * errors.
 *
 * In practice -- because |result| is almost always NULL or (in one case)
 * initialized before calling run_interpreter() -- this situation wasn't
 * encountered execept in Emergency Mode.
 *
 * Revision 1.17  2006/09/07 00:55:02  bjj
 * Add new MEMO_STRLEN option which uses the refcounting mechanism to
 * store strlen with strings.  This is basically free, since most string
 * allocations are rounded up by malloc anyway.  This saves lots of cycles
 * computing strlen.  (The change is originally from jitmoo, where I wanted
 * inline range checks for string ops).
 *
 * Revision 1.16  2004/05/22 01:25:43  wrog
 * merging in WROGUE changes (W_SRCIP, W_STARTUP, W_OOB)
 *
 * Revision 1.15  2004/03/03 23:06:57  bjj
 * Luke-Jr's patch for read_activ FUNC_NOT_FOUND
 *
 * Revision 1.14.2.1  2003/06/04 21:28:58  wrog
 * removed useless arguments from resume_from_previous_vm(), do_forked_task(); 
 * replaced current_task_kind with is_fg argument for do_task(); 
 * made enum task_kind internal to tasks.c
 *
 * Revision 1.14  2002/09/15 23:21:01  xplat
 * GNU indent normalization.
 *
 * Revision 1.13  2002/08/18 09:47:26  bjj
 * Finally made free_activation() take a pointer after noticing how !$%^&
 * much time it was taking in a particular profiling run.
 *
 * Revision 1.12  2001/03/12 05:10:54  bjj
 * Split out call_verb and call_verb2.  The latter must only be called with
 * strings that are already MOO strings (str_ref-able).
 *
 * Revision 1.11  2001/03/12 03:25:16  bjj
 * Added new package type BI_KILL which kills the task calling the builtin.
 * Removed the static int task_killed in execute.c which wa tested on every
 * loop through the interpreter to see if the task had been killed.
 *
 * Revision 1.10  1998/12/14 13:17:50  nop
 * Merge UNSAFE_OPTS (ref fixups); fix Log tag placement to fit CVS whims
 *
 * Revision 1.9  1998/02/19 07:36:17  nop
 * Initial string interning during db load.
 *
 * Revision 1.8  1997/07/07 03:24:54  nop
 * Merge UNSAFE_OPTS (r5) after extensive testing.
 *
 * Revision 1.7  1997/03/21 13:23:23  bjj
 * Reorganize the top of run() slightly to make it slightly more efficient
 * (we do execute it billions of times, after all).  Later we'll want to
 * get rid of if (task_killed) by introducing BI_KILL or by moving it into
 * the BI_FUNC_CALL case, at least.
 *
 * Revision 1.6.2.4  1998/12/06 07:13:21  bjj
 * Rationalize enqueue_forked_task interface and fix program_ref leak in
 * the case where fork fails with E_QUOTA.  Make .queued_task_limit=0 really
 * enforce a limit of zero tasks (for old behavior set it to 1, that's the
 * effect it used to have).
 *
 * Revision 1.6.2.3  1997/09/09 07:01:17  bjj
 * Change bytecode generation so that x=f(x) calls f() without holding a ref
 * to the value of x in the variable slot.  See the options.h comment for
 * BYTECODE_REDUCE_REF for more details.
 *
 * This checkin also makes x[y]=z (OP_INDEXSET) take advantage of that (that
 * new code is not conditional and still works either way).
 *
 * Revision 1.6.2.2  1997/05/24 07:08:37  bjj
 * Cleanup of Jay's last checkin to avoid some code duplication.
 *
 * Revision 1.6.2.1  1997/05/23 07:03:44  nop
 * Failure during property lookups/stores sometimes fails to free the string
 * containing the property name.  (PUSH_ERROR() may return immediately.)
 *
 * Revision 1.6  1997/03/08 06:25:39  nop
 * 1.8.0p6 merge by hand.
 *
 * Revision 1.5  1997/03/05 08:41:47  bjj
 * A few malloc-friendly changes:  rt_stacks are now centrally allocated/freed
 * so that we can keep a pool of them handy.  rt_envs are similarly pooled.
 * Both revert to malloc/free for large requests.
 *
 * Revision 1.4  1997/03/03 09:03:31  bjj
 * 3 opcode optimizations:
 *
 * 1)  OP_IMM+OP_POP is "peephole optimized" away at runtime.  This makes
 * verbdocs and other comments cheaper.
 *
 * 2)  OP_PUT_n+OP_POP is similarly optimized (PUT doesn't consume the
 * top value on the stack but it is often used that way in statements like
 * `var = expr;').  OP_G_PUT could use the same change but is rarely
 * executed.
 *
 * 3)  OP_PUT_n, OP_PUSH_n which used to be in an if/else in the default
 * case are split out into 32 cases each so the compiler can optimize it
 * for us.  These ops account for a large percentage of those executed.
 *
 * Revision 1.3  1997/03/03 06:14:44  nop
 * Nobody actually uses protected properties.  Make IGNORE_PROP_PROTECTED
 * the default.
 *
 * Revision 1.2  1997/03/03 04:18:38  nop
 * GNU Indent normalization
 *
 * Revision 1.1.1.1  1997/03/03 03:44:59  nop
 * LambdaMOO 1.8.0p5
 *
 * Revision 2.11  1997/03/04 04:31:48  eostrom
 * Modified run() and run_interpreter() to take a separate argument
 * indicating whether to raise an exception, rather than assuming E_NONE
 * means no and anything else means yes.
 *
 * Revision 2.10  1996/04/19  01:24:40  pavel
 * Added support for built-in functions making tail calls to MOO verbs and
 * changed pass() to use the new feature.  Added patches to allow generation
 * of the new warning in read_bi_func_data().  Release 1.8.0p4.
 *
 * Revision 2.9  1996/03/19  07:12:21  pavel
 * Fixed call_verb() to return E_INVIND when appropriate even when pass==0.
 * Removed is_user() test for setting .programmer and .wizard properties.
 * Reordered error tests in bf_task_stack() to check for an invalid argument
 * first.  Release 1.8.0p2.
 *
 * Revision 2.8  1996/03/10  01:18:22  pavel
 * Added new `caller()' entry point, for use by built-in fns.  Release 1.8.0.
 *
 * Revision 2.7  1996/02/11  00:44:01  pavel
 * Fixed handling of `kill_task(task_id())'.  Release 1.8.0beta2.
 *
 * Revision 2.6  1996/02/08  07:11:17  pavel
 * Added support for in-DB traceback handling, named WHILE loop, BREAK and
 * CONTINUE statement, exponentiation expression, and floating-point
 * arithmetic.  Fixed logging of wiz-bit setting to happen on any change in
 * value in either direction.  Added tick-counting for EOPs.  Fixed stack bug
 * in `$' expression.  Fixed horrible bugs in scattering assignment.  Added
 * version numbers on each frame of suspended tasks.  Renamed err/logf() to
 * errlog/oklog() and TYPE_NUM to TYPE_INT.  Updated copyright notice for
 * 1996.  Release 1.8.0beta1.
 *
 * Revision 2.5  1996/01/16  07:19:34  pavel
 * Fixed bug concerning which frame built-in function return data is stored
 * into.  Fixed tracebacks for wizarding to be accurate and only generated for
 * setting .wizard to true.  Added support for EOP_SCATTER.
 * Release 1.8.0alpha6.
 *
 * Revision 2.4  1996/01/11  07:28:04  pavel
 * Fixed bug in value of `progr' when MOO code returns to a built-in.  Added
 * support for getting the value of a resumed task.  Release 1.8.0alpha5.
 *
 * Revision 2.3  1995/12/31  03:12:19  pavel
 * Implemented the EOP_LENGTH opcode.  Release 1.8.0alpha4.
 *
 * Revision 2.2  1995/12/28  00:23:15  pavel
 * Fixed bug in unwinding through handlers that don't cover the current error.
 * Fixed bug in not squelching all errors raised by built-ins called from !d
 * verbs.  Commented conventions for errors vs. built-ins.  Fixed memory leaks
 * in built-in property reference, errors raised in !d verbs, and verbnames
 * read from suspended tasks in DB files.  Added call_function() built-in.
 * Fixed bug in registration of suspend().  Added support for better error
 * messages during DB loading of suspended task programs.
 * Release 1.8.0alpha3.
 *
 * Revision 2.1  1995/12/11  07:51:30  pavel
 * Added built-in function entries to stack traceback lists.  Accounted for
 * verb programs never being NULL any more.  Added support for built-in
 * properties being wiz-only.  Removed one more silly use of `unsigned'.
 * Added support for suspending forever.  Fixed registration of `read()' to
 * once again allow non-blocking mode.  Added `task_stack()' built-in
 * function.
 *
 * Release 1.8.0alpha2.
 *
 * Revision 2.0  1995/11/30  04:23:34  pavel
 * New baseline version, corresponding to release 1.8.0alpha1.
 *
 * Revision 1.27  1992/10/27  06:19:22  pavel
 * Fixed a memory leak that occurred when a read() call was rejected for
 * E_INVARG reasons.
 *
 * Revision 1.26  1992/10/23  23:03:47  pavel
 * Added copyright notice.
 *
 * Revision 1.25  1992/10/23  19:25:00  pavel
 * Eliminated all uses of the useless macro NULL..
 *
 * Revision 1.24  1992/10/21  03:02:35  pavel
 * Converted to use new automatic configuration system.
 *
 * Revision 1.23  1992/10/17  20:28:48  pavel
 * Global rename of strdup->str_dup, strref->str_ref, vardup->var_dup, and
 * varref->var_ref.
 * Added some (int) casts to placate over-protective compilers.
 * Changed return-type of read_activ() from char to int, for systems that use
 * unsigned chars.
 *
 * Revision 1.22  1992/09/25  21:11:36  pjames
 * Made use of the error_pc field in an activation to report correct
 * error tracebacks from verbs called by builtin verbs.
 *
 * Revision 1.21  1992/09/24  16:43:10  pavel
 * Exported `task_timed_out' for use by long-running built-in functions that
 * should abort if the timer goes off.
 *
 * Revision 1.20  1992/09/14  18:40:02  pjames
 * Updated #includes.  Moved rcsid to bottom.
 *
 * Revision 1.19  1992/09/14  17:45:17  pjames
 * Moved db_modification code to db modules.
 *
 * Revision 1.18  1992/09/08  22:07:06  pjames
 * Changed `register_bf_execute()' to `register_execute()'.
 * Changed range checking for subrange assigments.
 *
 * Revision 1.17  1992/09/04  22:42:05  pavel
 * Fixed some picky ANSI C problems with (const char *)'s.
 *
 * Revision 1.16  1992/09/03  16:29:44  pjames
 * Minor change.
 *
 * Revision 1.15  1992/09/02  18:41:17  pavel
 * Added mechanism for resuming tasks with errors.
 *
 * Revision 1.14  1992/09/01  06:24:01  pavel
 * Fixed minor storage leak just introduced.
 *
 * Revision 1.13  1992/09/01  05:30:57  pavel
 * Added a call to vardup() for first argument to listset().
 *
 * Revision 1.12  1992/08/31  22:29:01  pjames
 * Changed some `char *'s to `const char *' and fixed code accordingly.
 *
 * Revision 1.11  1992/08/28  23:23:03  pjames
 * Added support for EXTENDED instructions.
 * Added OP_RANGESET interpreting.
 * Changed OP_LISTSET to OP_INDEXSET, and added code for indexed string
 * assigments.
 *
 * Revision 1.10  1992/08/28  16:30:45  pjames
 * Changed myfree(*, M_STRING) to free_str(*).
 * Changed vardup to varref.
 * Changed some strref's to strdup.
 *
 * Revision 1.9  1992/08/12  02:01:46  pjames
 * Gave a variable an initial value to get rid on a bogus compiler
 * warning.
 *
 * Revision 1.8  1992/08/12  01:48:03  pjames
 * Fixed string freeing/copying to/from activation/forked_tasks.
 *
 * Revision 1.7  1992/08/11  17:30:44  pjames
 * Removed last read/write of Parse_Info, fixed a bug in a macro
 * (commented back in a line), and fixed call_verb (to not run the
 * program if it doesn't exist).
 *
 * Revision 1.6  1992/08/10  17:47:00  pjames
 * Moved several functions to eval_env.c and eval_vm.c.  Moved built in
 * functions which modified vm to this module.  Move property functions
 * to property.c.  Updated #includes.  Modified run() to be cleaner.
 * Used new built in function registration methods.  Removed uses of
 * Parse_Info field in activations.
 *
 * Revision 1.5  1992/08/01  01:14:52  pavel
 * Minor fixes...
 *
 * Revision 1.4  1992/07/30  21:18:48  pjames
 * Updated print_error_backtrace to print line numbers for each frame on
 * the stack.
 *
 * Revision 1.3  1992/07/27  18:14:17  pjames
 * Changed name of ct_env to var_names, const_env to literals, and
 * f_vectors to fork_vectors.
 *
 * Revision 1.2  1992/07/21  00:02:07  pavel
 * Added rcsid_<filename-root> declaration to hold the RCS ident. string.
 *
 * Revision 1.1  1992/07/20  23:23:12  pavel
 * Initial RCS-controlled version.
 */