mmo-ref/lambdamoo
1
0
Fork 0
mirror of https://github.com/wrog/lambdamoo synced 2026-08-13 00:26:05 -04:00
Code Issues Projects Releases Packages Wiki Activity
lambdamoo/execute.c
Roger Crew 324cf46237 WAIF_CORE ifdef festival
2025-09-30 23:04:53 -07:00

3441 lines
86 KiB
C
Raw Permalink Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

/******************************************************************************
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 "execute.h"
#include "bf_register.h"
#include "config.h"
#include "options.h"
#include "my-string.h"
#include "db.h"
#include "db_io.h"
#include "decompile.h"
#include "eval_env.h"
#include "eval_vm.h"
#include "exceptions.h"
#include "functions.h"
#include "list.h"
#include "log.h"
#include "numbers.h"
#include "opcode.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 "version.h"
#include "waif.h"
/* the following globals are the guts of the virtual machine: */
static activation *activ_stack = 0;
static UNum 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 ****/
/*
* Compendium of all of the possible ways in which the stack
* may be unwound to some specific place (loop exit, return,
* EXCEPT/FINALLY handler) or all of the way out (uncaught
* exception, kill_task(), or ticks/seconds exhaustion)
*
* WARNING: These constants show up in DB files,
* so do *NOT* change their order/values...
*/
typedef enum {
FIN_FALL_THRU, /* (none) TRY body finished normally */
FIN_RAISE, /* (partial) handled exception */
FIN_UNCAUGHT, /* (full unless finally) uncaught exception */
FIN_RETURN, /* (partial) did a RETURN */
FIN_ABORT, /* (full + skip handlers) ticks/seconds */
FIN_EXIT /* (partial) did a BREAK / CONTINUE */
} 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 *))
{
unsigned t;
Stream *str;
if (!interpreter_is_running)
return;
str = new_stream(100);
t = top_activ_stack;
for (;;) {
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 %u",
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));
}
if (!t--)
break;
stream_add_string(str, "... called from ");
}
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);
unsigned 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 void abort_task(enum abort_reason reason);
static int
unwind_stack(Finally_Reason why, Var value, enum outcome *outcome)
{
/*
* Unwind the activation and rt stacks in accordance with 'why'.
* Return true iff the interpreter should stop, in which case
* *outcome is set. Interpreter stops either because it was
* blocked (OUTCOME_BLOCKED) or the entire stack was unwound
* (OUTCOME_DONE/OUTCOME_ABORTED)
*
* Return value may be safely ignored in the following cases:
* why==FIN_EXIT always returns false
* why==FIN_ABORT always returns true/OUTCOME_ABORTED
*/
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;
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;
}
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_ABORT:
abort_task(p.u.why);
if (outcome)
*outcome = OUTCOME_ABORTED;
return 1;
}
} 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_ABORT:
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);
#ifdef WAIF_CORE
v.v.list[1] = var_ref(stack[i].THIS);
#else
v.v.list[1].type = TYPE_OBJ;
v.v.list[1].v.obj = stack[i].this;
#endif
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(enum abort_reason reason)
{
Var value;
const char *msg;
const char *htag;
switch(reason) {
default:
panic("Bad abort_reason");
case ABORT_TICKS:
msg = "Task ran out of ticks";
htag = "ticks";
goto save_hinfo;
case ABORT_SECONDS:
msg = "Task ran out of seconds";
htag = "seconds";
save_hinfo:
value = new_list(3);
value.v.list[1].type = TYPE_STR;
value.v.list[1].v.str = str_dup(htag);
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);
/* FALLS THROUGH */
case ABORT_KILL:
(void) 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);
#ifdef WAIF_CORE
free_var(ap->THIS);
#endif
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
WAIF_COMMA_ARG(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 =
call_verb2(this, vname
WAIF_COMMA_ARG(((Var){ .type = TYPE_OBJ,
.v.obj = 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
WAIF_COMMA_ARG(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;
#ifdef WAIF_CORE
RUN_ACTIV.THIS = var_ref(THIS);
#endif
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);
#ifdef WAIF_CORE
set_rt_env_var(env, SLOT_THIS, var_ref(THIS));
set_rt_env_var(env, SLOT_CALLER, var_ref(CALLER_ACTIV.THIS));
#else
set_rt_env_obj(env, SLOT_THIS, this);
set_rt_env_obj(env, SLOT_CALLER, CALLER_ACTIV.this);
#endif
#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;
#ifdef WAIF_CORE
if (vname[0] == WAIF_VERB_PREFIX)
v.v.str = str_dup(vname + 1);
else
#endif
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 inline int
int_or_float(Var v)
{
return v.type == TYPE_INT || v.type == TYPE_FLOAT;
}
static inline int
list_or_string(Var v)
{
return v.type == TYPE_LIST || v.type == TYPE_STR;
}
static int
rangeref_fails(Num length, Num from, Num after)
{
return !(from >= after
|| (1 <= from && after <= length + 1));
}
static enum error
rangeset_error(UNum max, size_t blen, size_t ilen, Num from, Num after)
{
if (!(1 <= after && (from <= 0 || ((UNum)from <= blen + 1))))
return E_RANGE;
if (max < (((from > 1) ? (size_t)(from - 1) : 0)
+ ilen
+ ((blen >= (size_t)after) ? (blen - (size_t)after) + 1 : 0)))
return E_QUOTA;
return E_NONE;
}
#ifdef IGNORE_PROP_PROTECTED
#define bi_prop_protected(prop, progr) (0)
#else
#define bi_prop_protected(prop, progr) ((!is_wizard(progr)) && server_flag_option_cached(prop))
#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 PUSH_ERROR_UNLESS_QUOTA(the_err) \
do { \
if (E_QUOTA == (the_err) && \
!server_flag_option_cached(SVO_MAX_CONCAT_CATCHABLE)) \
{ \
/* simulate out-of-seconds abort resulting */ \
/* from monster malloc+copy taking too long */ \
STORE_STATE_VARIABLES(); \
abort_task(ABORT_SECONDS); \
return OUTCOME_ABORTED; \
} \
else \
PUSH_ERROR(the_err); \
} 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(ABORT_TICKS);
return OUTCOME_ABORTED;
}
if (task_timed_out) {
STORE_STATE_VARIABLES();
abort_task(ABORT_SECONDS);
return OUTCOME_ABORTED;
}
}
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Wswitch"
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 < NUM_MAX) {
from.v.num++;
NEXT_TOP_RT_VALUE = from;
} else {
to.v.num--;
TOP_RT_VALUE = to;
}
} else {
if (from.v.obj < OBJ_MAX) {
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;
enum error e = E_NONE;
tail = POP(); /* whatever */
list = POP(); /* should be list */
if (list.type != TYPE_LIST)
e = E_TYPE;
else if (server_int_option_cached(SVO_MAX_LIST_CONCAT)
<= list.v.list[0].v.num)
e = E_QUOTA;
if (e != E_NONE) {
free_var(list);
free_var(tail);
PUSH_ERROR_UNLESS_QUOTA(e);
} else
PUSH(listappend(list, tail));
}
break;
case OP_LIST_APPEND:
{
Var tail, list;
enum error e = E_NONE;
tail = POP(); /* second, should be list */
list = POP(); /* first, should be list */
if (tail.type != TYPE_LIST || list.type != TYPE_LIST)
e = E_TYPE;
else if (server_int_option_cached(SVO_MAX_LIST_CONCAT)
< list.v.list[0].v.num + tail.v.list[0].v.num)
e = E_QUOTA;
if (e != E_NONE) {
free_var(tail);
free_var(list);
PUSH_ERROR_UNLESS_QUOTA(e);
} else
PUSH(listconcat(list, tail));
}
break;
case OP_INDEXSET:
{
enum error e = E_NONE;
Var value = POP(); /* rhs value */
Var index = POP(); /* index, should be integer */
Var list = POP(); /* lhs except last index, should be list or str */
/** list[index] = value **/
#ifdef WAIF_DICT
if (list.type == TYPE_WAIF) {
Var args = new_list(2);
args.v.list[1] = var_ref(index);
args.v.list[2] = var_ref(value);
Objid class = list.v.waif->class;
if (!valid(class))
e = E_INVIND;
else if (!is_wizard(db_object_owner(class)))
e = E_TYPE;
else {
STORE_STATE_VARIABLES();
e = call_verb2(class, waif_indexset_verb,
list, args, 0/* not pass */);
if (e == E_VERBNF) {
e = E_TYPE;
}
LOAD_STATE_VARIABLES();
}
if (e != E_NONE)
free_var(args);
else {
free_var(value);
free_var(list);
}
}
else
#endif /* WAIF_DICT */
if (index.type != TYPE_INT || !list_or_string(list))
e = E_TYPE;
else if (index.v.num < 1)
e = E_RANGE;
else if (list.type == TYPE_LIST) {
if (index.v.num > list.v.list[0].v.num)
e = E_RANGE;
else {
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 { /* list.type == TYPE_STR */
Num bfromafter[] = { index.v.num, index.v.num + 1 };
utf_byte_range(list.v.str, bfromafter);
if (value.type != TYPE_STR)
e = E_TYPE;
else if ((UNum)bfromafter[0] > memo_strlen(list.v.str))
e = E_RANGE;
else if (memo_strlen(value.v.str) != clearance_utf(value.v.str[0]))
e = E_INVARG; /* not a single character */
else
PUSH(strrangeset(list, bfromafter[0], bfromafter[1], value));
}
/* listset() uses both list and value; strrangeset frees both */
free_var(index);
if (e != E_NONE) {
free_var(value);
free_var(list);
PUSH_ERROR(e);
}
}
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_LE:
case OP_GT:
{
Var a, b;
int not;
b = POP();
a = POP();
not = op != OP_LE;
goto finish_comparison;
case OP_LT:
case OP_GE:
/* yes, these are supposed to be reversed */
a = POP();
b = POP();
not = op != OP_GE;
finish_comparison: ;
Var ans;
if (int_or_float(a) && int_or_float(b))
ans = numeric_lt_or_eq(not, a, b);
else if (a.type != b.type || b.type == TYPE_LIST) {
ans.type = TYPE_ERR;
ans.v.err = E_TYPE;
}
else {
ans.type = TYPE_INT;
switch (b.type) {
case TYPE_OBJ:
ans.v.num = a.v.obj <= b.v.obj;
break;
case TYPE_ERR:
ans.v.num = a.v.err <= b.v.err;
break;
case TYPE_STR:
ans.v.num = mystrcasecmp(a.v.str, b.v.str) <= 0;
break;
default:
panic("RUN: Impossible type in comparison");
}
if (not)
ans.v.num = !ans.v.num;
}
if (ans.type == TYPE_ERR)
PUSH_ERROR(ans.v.err);
else
PUSH(ans);
free_var(a);
free_var(b);
}
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);
int flen = llen + memo_strlen(rhs.v.str);
if (server_int_option_cached(SVO_MAX_STRING_CONCAT)
< flen) {
ans.type = TYPE_ERR;
ans.v.err = E_QUOTA;
} else {
str = mymalloc(flen + 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_UNLESS_QUOTA(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 = box_fl(-fl_unbox(arg.v.fnum));
} else {
free_var(arg);
PUSH_ERROR(E_TYPE);
break;
}
PUSH(ans);
free_var(arg);
}
break;
case OP_REF:
{
enum error e = E_NONE;
Var index = POP(); /* should be integer */
Var list = POP(); /* should be list or string */
/** list[index] **/
#ifdef WAIF_DICT
if (list.type == TYPE_WAIF) {
Var args = new_list(1);
args.v.list[1] = var_ref(index);
Objid class = list.v.waif->class;
if (!valid(class))
e = E_INVIND;
else if (!is_wizard(db_object_owner(class)))
e = E_TYPE;
else {
STORE_STATE_VARIABLES();
e = call_verb2(class, waif_index_verb,
list, args, 0/* not pass */);
if (e == E_VERBNF)
e = E_TYPE;
LOAD_STATE_VARIABLES();
}
if (e != E_NONE)
free_var(args);
else
free_var(list);
}
else
#endif /* WAIF_DICT */
if (index.type != TYPE_INT || !list_or_string(list))
e = E_TYPE;
else if (index.v.num < 1)
e = E_RANGE;
else if (list.type == TYPE_LIST) {
if (index.v.num > list.v.list[0].v.num)
e = E_RANGE;
else {
PUSH(var_ref(list.v.list[index.v.num]));
free_var(list);
}
}
else { /* list.type == TYPE_STR */
Num bindex = utf_byte_index(list.v.str, index.v.num);
if ((UNum)bindex > memo_strlen(list.v.str))
e = E_RANGE;
else
/* substr frees list */
PUSH(substr(list, bindex,
bindex +
clearance_utf(list.v.str[bindex - 1])));
}
free_var(index);
if (e != E_NONE) {
free_var(list);
PUSH_ERROR(e);
}
}
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:
{
enum error e = E_NONE;
Var to = POP(); /* should be integer */
Var from = POP(); /* should be integer */
Var base = POP(); /* should be list or string */
/** base[from..to] **/
if (to.type != TYPE_INT || from.type != TYPE_INT
|| !list_or_string(base))
e = E_TYPE;
else if (base.type == TYPE_LIST) {
if (rangeref_fails(base.v.list[0].v.num,
from.v.num, to.v.num + 1))
e = E_RANGE;
else
PUSH(sublist(base, from.v.num, to.v.num + 1));
}
else { /* base.type == TYPE_STR */
Num bfromafter[] = { from.v.num, to.v.num + 1 };
utf_byte_range(base.v.str, bfromafter);
if (rangeref_fails(memo_strlen(base.v.str),
bfromafter[0], bfromafter[1]))
e = E_RANGE;
else
PUSH(substr(base, bfromafter[0], bfromafter[1]));
}
free_var(to);
free_var(from);
/* base freed by substr/sublist */
if (e != E_NONE) {
free_var(base);
PUSH_ERROR(e);
}
}
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 */
#ifdef WAIF_CORE
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
#endif /* WAIF_CORE */
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;
#ifdef WAIF_CORE
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
#endif /* WAIF_CORE */
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 */
#ifdef WAIF_CORE
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
#endif /* WAIF_CORE */
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) ||
bi_prop_protected(h.built_in, progr) ||
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 (!is_wizard(progr) &&
(bi_prop_protected(h.built_in, progr) ||
progr != db_object_owner(obj.v.obj)))
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 ? (int)id : -1);
if (e != E_NONE)
RAISE_ERROR(e);
}
}
break;
case OP_CALL_VERB:
{
enum error err = E_NONE;
Var args = POP(); /* args, should be list */
Var verb = POP(); /* verbname, should be string */
Var obj = POP(); /* objid, should be obj */
Objid class;
if (args.type != TYPE_LIST || verb.type != TYPE_STR)
err = E_TYPE;
#ifdef WAIF_CORE
else if (obj.type == TYPE_WAIF) {
if (!valid(class = obj.v.waif->class))
goto op_call_verb_invalid_class;
char *str = mymalloc(strlen(verb.v.str) + 2, M_STRING);
str[0] = WAIF_VERB_PREFIX;
strcpy(str + 1, verb.v.str);
free_str(verb.v.str);
verb.v.str = str;
goto op_call_verb_do_call;
}
#endif
else if (obj.type != TYPE_OBJ)
err = E_TYPE;
#ifdef WAIF_CORE
else if (verb.v.str[0] == WAIF_VERB_PREFIX)
err = E_VERBNF;
#endif
else if (!valid(class = obj.v.obj)) {
op_call_verb_invalid_class: UNUSED_;
err = E_INVIND;
}
else {
op_call_verb_do_call: UNUSED_;
STORE_STATE_VARIABLES();
err = call_verb2(class, verb.v.str
WAIF_COMMA_ARG(obj),
args, 0/* not pass */);
/* args is consumed iff err==E_NONE */
LOAD_STATE_VARIABLES();
}
free_var(obj);
free_var(verb);
if (err != E_NONE) {
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_ABORT:
STORE_STATE_VARIABLES();
abort_task(p.u.why);
return OUTCOME_ABORTED;
}
}
}
break;
case OP_EXTENDED:
{
register enum Extended_Opcode eop = *bv;
bv++;
if (COUNT_EOP_TICK(eop))
ticks_remaining--;
switch (eop) {
case EOP_RANGESET:
{
enum error e = E_NONE;
Var value = POP(); /* rhs value (list or string) */
Var to = POP(); /* end of range (integer) */
Var from = POP(); /* start of range (integer) */
Var base = POP(); /* lhs (list or string) */
/** base[from..to] = value **/
if ( to.type != TYPE_INT
|| from.type != TYPE_INT
|| !list_or_string(base)
|| value.type != base.type)
e = E_TYPE;
else if (base.type == TYPE_LIST) {
e = rangeset_error(server_int_option_cached(SVO_MAX_LIST_CONCAT),
base.v.list[0].v.num,
value.v.list[0].v.num,
from.v.num, to.v.num + 1);
if (e == E_NONE)
PUSH(listrangeset(base, from.v.num,
to.v.num + 1, value));
}
else { /* base.type == TYPE_STR */
Num bfromafter[] = { from.v.num, to.v.num + 1 };
utf_byte_range(base.v.str, bfromafter);
e = rangeset_error(server_int_option_cached(SVO_MAX_STRING_CONCAT),
memo_strlen(base.v.str),
memo_strlen(value.v.str),
bfromafter[0], bfromafter[1]);
if (e == E_NONE)
PUSH(strrangeset(base, bfromafter[0],
bfromafter[1], value));
}
/* listrangeset/strrangeset free base and value */
free_var(to);
free_var(from);
if (e != E_NONE) {
free_var(base);
free_var(value);
PUSH_ERROR_UNLESS_QUOTA(e);
}
}
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 = memo_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 */
/* FALLS THROUGH */
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();
(void) 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
|| (UNum)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;
}
#pragma GCC diagnostic pop
}
}
/**** manipulating data of task ****/
static int timeouts_enabled = 1; /* set to 0 in debugger to disable
timeouts */
static void
task_timeout(Timer_ID id UNUSED_, Timer_Data data UNUSED_)
{
task_timed_out = timeouts_enabled;
}
static Timer_ID
setup_task_execution_limits(int is_fg)
{
int seconds;
int ticks;
if (is_fg) {
seconds = server_int_option("fg_seconds", DEFAULT_FG_SECONDS);
ticks = server_int_option("fg_ticks", DEFAULT_FG_TICKS);
}
else {
seconds = server_int_option("bg_seconds", DEFAULT_BG_SECONDS);
ticks = server_int_option("bg_ticks", DEFAULT_BG_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;
}
static 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;
Var args;
setup_task_execution_limits(is_fg);
/* handler_verb_* is garbage/unreferenced outside of run()
* and this is the only place run() is called. */
handler_verb_args = zero;
handler_verb_name = 0;
interpreter_is_running = 1;
ret = run(raise, e, result);
interpreter_is_running = 0;
args = handler_verb_args;
cancel_timer(task_alarm_id);
task_timed_out = 0;
if (ret == OUTCOME_ABORTED && handler_verb_name) {
db_verb_handle h = {};
if (do_db_tracebacks)
h = db_find_callable_verb(SYSTEM_OBJECT, handler_verb_name);
if (h.ptr) {
Var handled;
enum outcome hret =
do_server_verb_task(SYSTEM_OBJECT, handler_verb_name,
var_ref(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 */
}
}
int i = args.v.list[0].v.num;
Var 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(void)
{
return RUN_ACTIV.this; /* XXX waifs?! */
}
static void
check_activ_stack_size(UNum 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 UNum
current_max_stack_size(void)
{
UNum 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)
{
unsigned 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;
#ifdef WAIF_CORE
RUN_ACTIV.THIS.type = TYPE_OBJ;
RUN_ACTIV.THIS.v.obj = this;
#endif
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;
#ifdef WAIF_CORE
RUN_ACTIV.THIS.type = TYPE_OBJ;
RUN_ACTIV.THIS.v.obj = this;
#endif
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;
#ifdef WAIF_CORE
RUN_ACTIV.THIS.type = TYPE_OBJ;
RUN_ACTIV.THIS.v.obj = NOTHING;
#endif
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)
{
const char *fname;
if (!dbio_scxnf("bf_call_function data: fname = %ms", &fname))
return 0;
unsigned fnum = number_func_by_name(fname);
if (fnum == FUNC_NOT_FOUND) {
errlog("CALL_FUNCTION: Unknown built-in function: %s\n", fname);
}
else {
struct cf_state *s = alloc_data(sizeof(struct cf_state));
if (read_bi_func_data(s->fnum = fnum, &s->data, pc_for_bi_func_data())) {
return s;
}
free_data(s);
}
return 0;
}
static package
bf_raise(Var arglist, Byte next UNUSED_, void *vdata UNUSED_, Objid progr UNUSED_)
{
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)
: 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 UNUSED_, void *vdata UNUSED_, Objid progr UNUSED_)
{
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 UNUSED_, void *vdata UNUSED_, 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 UNUSED_, void *vdata UNUSED_, Objid progr UNUSED_)
{
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 UNUSED_, void *vdata UNUSED_, Objid progr UNUSED_)
{
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 UNUSED_, void *vdata UNUSED_, Objid progr UNUSED_)
{
enum error e = call_verb2(RUN_ACTIV.this, RUN_ACTIV.verb
WAIF_COMMA_ARG(RUN_ACTIV.THIS),
arglist, 1/* pass */);
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 UNUSED_, void *vdata UNUSED_, 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 UNUSED_, void *vdata UNUSED_, Objid progr UNUSED_)
{ /* () */
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 UNUSED_, void *vdata UNUSED_, Objid progr UNUSED_)
{
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 UNUSED_, void *vdata UNUSED_, Objid progr)
{
int nargs = arglist.v.list[0].v.num;
TaskID id = task_id_from_num(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)
{
#ifdef WAIF_CORE
dbio_write_var(a.THIS);
#else
dbio_write_var((Var){ .type=TYPE_INT, .v.num=-111 }/*dummy*/);
#endif
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)
{
Var T;
if (!dbio_read_var(&T))
return 0;
if (!dbio_scxnf("%"SCNdN" %*d %*d %"SCNdN" %*d %"SCNdN" %"SCNdN" %*d %d",
&a->this, &a->player, &a->progr, &a->vloc, &a->debug)) {
errlog("READ_A: Bad numbers.\n");
return 0;
}
#ifdef WAIF_CORE
switch (T.type) {
case TYPE_WAIF:
case TYPE_OBJ:
break;
default:
T.type = TYPE_OBJ;
T.v.obj = a->this;
break;
}
a->THIS = T;
#else
free_var(T);
#endif
return
dbio_skip_lines(4, "READ_A") &&
/* was: argstr, dobjstr, iobjstr, prepstr */
dbio_read_string_intern(&a->verb) &&
dbio_read_string_intern(&a->verbname);
}
void
write_rt_env(const char **var_names, Var * rt_env, unsigned size)
{
unsigned i;
dbio_printf("%u 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, unsigned *old_size)
{
unsigned i;
if (!dbio_scxnf("%u variables", old_size)) {
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++)
if (!(dbio_read_string_intern(&(*old_names)[i]) &&
dbio_read_var(&(*rt_env)[i])))
return 0;
return 1;
}
Var *
reorder_rt_env(Var * old_rt_env, const char **old_names,
unsigned 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++) {
unsigned 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);
if (a.top_rt_stack < a.base_rt_stack)
panic("rt_stack smash");
dbio_printf("%tu 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;
unsigned old_size, stack_in_use;
unsigned i;
int max_stack;
if (dbio_input_version < DBV_Float)
version = dbio_input_version;
else if (!dbio_scxnf("language version %u", &v)) {
errlog("READ_ACTIV: Malformed language version\n");
return 0;
} else if (version = v, !check_db_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_scxnf("%u rt_stack slots in use", &stack_in_use)) {
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++)
if (!dbio_read_var(a->top_rt_stack++))
return 0;
if (!read_activ_as_pi(a)) {
errlog("READ_ACTIV: Bad activ. stack_in_use = %u\n", stack_in_use);
return 0;
}
if (!dbio_read_var(&a->temp))
return 0;
int pcscan = dbio_scxnf("%u %u\v %u", &a->pc, &i, &a->error_pc);
if (!pcscan) {
errlog("READ_ACTIV: bad pc, next, error_pc. stack_in_use = %u\n", stack_in_use);
return 0;
}
a->bi_func_pc = i;
if (pcscan < 2)
a->error_pc = a->pc;
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) {
const char *func_name;
unsigned fnum;
if (!dbio_scxnf("%ms", &func_name)) {
errlog("READ_ACTIV: Built-in function name expected.\n");
return 0;
}
if ((fnum = 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 = fnum;
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",
/* read_bi_func_data() may do dbio_*() and
* may thus overwrite func_name, but we know
* func_name was found, so this has to work:
*/
name_func_by_num(fnum));
return 0;
}
}
return 1;
}
/*
* $Log$
* 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.
*/
Reference in a new issue View git blame Copy permalink