#define SUPPRESS_COMPILER_INLINES
#include "std.h"
#include "lpc_incl.h"
#include "efuns_incl.h"
#include "file.h"
#include "patchlevel.h"
#include "backend.h"
#include "simul_efun.h"
#include "debug.h"
#include "eoperators.h"
#include "efunctions.h"
#include "lex.h"
#include "functab_tree.h"
#include "sprintf.h"
#include "swap.h"
#include "comm.h"
#include "port.h"
#include "qsort.h"
#include "compiler.h"
#include "regexp.h"
#ifdef OPCPROF
#include "opc.h"
static int opc_eoper[BASE];
#endif
#ifdef OPCPROF_2D
/* warning, this is typically 4 * 100 * 100 = 40k */
static int opc_eoper_2d[BASE+1][BASE+1];
static int last_eop = 0;
#endif
#if defined(RUSAGE) && !defined(LATTICE) && !defined(WIN32)
#include <sys/resource.h>
#ifdef SunOS_FOO
#include <sys/rusage.h>
#endif
#ifdef sun
extern int getpagesize();
#endif
#ifndef RUSAGE_SELF
#define RUSAGE_SELF 0
#endif
#endif
static char *type_names[] = {
"int",
"string",
"array",
"object",
"mapping",
"function",
"float",
"buffer",
"class"
};
#define TYPE_CODES_END 0x400
#define TYPE_CODES_START 0x2
#ifdef PACKAGE_UIDS
extern userid_t *backbone_uid;
#endif
extern int max_cost;
extern int call_origin;
INLINE void push_indexed_lvalue PROT((int));
static svalue_t *find_value PROT((int));
#ifdef TRACE
static void do_trace_call PROT((function_t *));
#endif
void break_point PROT((void));
static INLINE void do_loop_cond_number PROT((void));
static INLINE void do_loop_cond_local PROT((void));
static void do_catch PROT((char *, unsigned short));
#ifdef DEBUG
int last_instructions PROT((void));
#endif
static float _strtof PROT((char *, char **));
#ifdef TRACE_CODE
static char *get_arg PROT((int, int));
#endif
#ifdef DEBUG
int foreach_in_progress = 0;
#endif
int inter_sscanf PROT((svalue_t *, svalue_t *, svalue_t *, int));
program_t *current_prog;
short int caller_type;
static int tracedepth;
int num_varargs;
/*
* Inheritance:
* An object X can inherit from another object Y. This is done with
* the statement 'inherit "file";'
* The inherit statement will clone a copy of that file, call reset
* in it, and set a pointer to Y from X.
* Y has to be removed from the linked list of all objects.
* All variables declared by Y will be copied to X, so that X has access
* to them.
*
* If Y isn't loaded when it is needed, X will be discarded, and Y will be
* loaded separately. X will then be reloaded again.
*/
/*
* These are the registers used at runtime.
* The control stack saves registers to be restored when a function
* will return. That means that control_stack[0] will have almost no
* interesting values, as it will terminate execution.
*/
char *pc; /* Program pointer. */
svalue_t *fp; /* Pointer to first argument. */
svalue_t *sp;
int function_index_offset; /* Needed for inheritance */
int variable_index_offset; /* Needed for inheritance */
int st_num_arg;
static svalue_t start_of_stack[EVALUATOR_STACK_SIZE];
svalue_t *end_of_stack = start_of_stack + EVALUATOR_STACK_SIZE - 5;
/* Used to throw an error to a catch */
svalue_t catch_value = {T_NUMBER};
/* used by routines that want to return a pointer to an svalue */
svalue_t apply_ret_value = {T_NUMBER};
control_stack_t control_stack[MAX_TRACE];
control_stack_t *csp; /* Points to last element pushed */
int too_deep_error = 0, max_eval_error = 0;
#define STACK_CHECK if (++sp >= end_of_stack) do { \
too_deep_error = 1; error("stack overflow\n"); } \
while (0)
void get_version P1(char *, buff)
{
sprintf(buff, "MudOS %s", PATCH_LEVEL);
}
/*
* Information about assignments of values:
*
* There are three types of l-values: Local variables, global variables
* and array elements.
*
* The local variables are allocated on the stack together with the arguments.
* the register 'frame_pointer' points to the first argument.
*
* The global variables must keep their values between executions, and
* have space allocated at the creation of the object.
*
* Elements in arrays are similar to global variables. There is a reference
* count to the whole array, that states when to deallocate the array.
* The elements consists of 'svalue_t's, and will thus have to be freed
* immediately when over written.
*/
/*
* Push an object pointer on the stack. Note that the reference count is
* incremented.
* A destructed object must never be pushed onto the stack.
*/
INLINE
void push_object P1(object_t *, ob)
{
STACK_CHECK;
sp->type = T_OBJECT;
sp->u.ob = ob;
add_ref(ob, "push_object");
}
char * type_name P1(int, c) {
int j = 0;
int limit = TYPE_CODES_START;
do {
if (c & limit) return type_names[j];
j++;
} while (!((limit <<= 1) & TYPE_CODES_END));
/* Oh crap. Take some time and figure out what we have. */
switch (c) {
case T_INVALID: return "*invalid*";
case T_LVALUE: return "*lvalue*";
case T_LVALUE_BYTE: return "*lvalue_byte*";
case T_LVALUE_RANGE: return "*lvalue_range*";
case T_ERROR_HANDLER: return "*error_handler*";
IF_DEBUG(case T_FREED: return "*freed*");
}
return "*unknown*";
}
/*
* May current_object shadow object 'ob' ? We rely heavily on the fact that
* function names are pointers to shared strings, which means that equality
* can be tested simply through pointer comparison.
*/
#ifndef NO_SHADOWS
int validate_shadowing P1(object_t *, ob)
{
int i, j;
program_t *shadow = current_object->prog, *victim = ob->prog;
svalue_t *ret;
if (current_object->shadowing)
error("shadow: Already shadowing.\n");
if (current_object->shadowed)
error("shadow: Can't shadow when shadowed.\n");
#ifndef NO_ENVIRONMENT
if (current_object->super)
error("shadow: The shadow must not reside inside another object.\n");
#endif
if (ob == master_ob)
error("shadow: cannot shadow the master object.\n");
if (ob->shadowing)
error("shadow: Can't shadow a shadow.\n");
#ifdef OPTIMIZE_FUNCTION_TABLE_SEARCH
/*
* Want to iterate over the smaller function table, and use binary search
* on the larger one for faster operation, ie O(m lg n), where m < n,
* versus O(m n)
*/
if ((int) shadow->num_functions < (int) victim->num_functions) {
for (i = 0; i < (int) shadow->num_functions; i++) {
j = lookup_function(victim->functions, victim->tree_r,
shadow->functions[i].name);
if (j != -1 && victim->functions[j].type & TYPE_MOD_NO_MASK)
error("Illegal to shadow 'nomask' function \"%s\".\n",
victim->functions[j].name);
}
} else {
for (i = 0; i < (int) victim->num_functions; i++) {
j = lookup_function(shadow->functions, shadow->tree_r,
victim->functions[i].name);
if (j != -1 && victim->functions[i].type & TYPE_MOD_NO_MASK)
error("Illegal to shadow 'nomask' function \"%s\".\n",
victim->functions[i].name);
}
}
#else
for (i = 0; i < (int) shadow->num_functions; i++) {
for (j = 0; j < (int) victim->num_functions; j++) {
if (shadow->functions[i].name != victim->functions[j].name)
continue;
if (victim->functions[j].type & TYPE_MOD_NO_MASK)
error("Illegal to shadow 'nomask' function \"%s\".\n",
victim->functions[j].name);
}
}
#endif
push_object(ob);
ret = apply_master_ob(APPLY_VALID_SHADOW, 1);
if (!(ob->flags & O_DESTRUCTED) && MASTER_APPROVED(ret)) {
return 1;
}
return 0;
}
#endif
/*
* Push a number on the value stack.
*/
INLINE void
push_number P1(int, n)
{
STACK_CHECK;
sp->type = T_NUMBER;
sp->subtype = 0;
sp->u.number = n;
}
INLINE void
push_real P1(double, n)
{
STACK_CHECK;
sp->type = T_REAL;
sp->u.real = n;
}
/*
* Push undefined (const0u) onto the value stack.
*/
INLINE
void push_undefined()
{
STACK_CHECK;
*sp = const0u;
}
/*
* Push null (const0n) onto the value stack.
*/
INLINE
void push_null()
{
STACK_CHECK;
*sp = const0n;
}
INLINE void push_nulls P1(int, num)
{
if (sp + num >= end_of_stack) { too_deep_error = 1; error("stack overflow\n"); }
while (num--) *++sp = const0n;
}
/*
* Push a string on the value stack.
*/
INLINE
void push_string P2(char *, p, int, type)
{
STACK_CHECK;
sp->type = T_STRING;
sp->subtype = type;
switch (type) {
case STRING_MALLOC:
sp->u.string = string_copy(p, "push_string");
break;
case STRING_SHARED:
sp->u.string = make_shared_string(p);
break;
case STRING_CONSTANT:
sp->u.string = p;
break;
}
}
/*
* Get address to a valid global variable.
*/
#ifdef DEBUG
static INLINE svalue_t *find_value P1(int, num)
{
DEBUG_CHECK2(num >= (int) current_object->prog->num_variables,
"Illegal variable access %d(%d).\n",
num, current_object->prog->num_variables);
return ¤t_object->variables[num];
}
#else
#define find_value(num) (¤t_object->variables[num])
#endif
INLINE void
free_string_svalue P1(svalue_t *, v)
{
char *str = v->u.string;
if (v->subtype & STRING_COUNTED) {
#ifdef STRING_STATS
int size = MSTR_SIZE(str);
#endif
SUB_STRING(size);
if (!(--(COUNTED_REF(str)))) {
NDBG(BLOCK(str));
if (v->subtype & STRING_HASHED) {
SUB_NEW_STRING(size, sizeof(block_t));
deallocate_string(str);
CHECK_STRING_STATS;
} else {
SUB_NEW_STRING(size, sizeof(malloc_block_t));
FREE(MSTR_BLOCK(str));
CHECK_STRING_STATS;
}
} else {
NDBG(BLOCK(str));
}
}
}
void unlink_string_svalue P1(svalue_t *, s) {
char *str;
switch (s->subtype) {
case STRING_MALLOC:
if (MSTR_REF(s->u.string) > 1)
s->u.string = string_unlink(s->u.string, "unlink_string_svalue");
break;
case STRING_SHARED:
{
int l = SHARED_STRLEN(s->u.string);
str = new_string(l, "unlink_string_svalue");
strncpy(str, s->u.string, l + 1);
free_string(s->u.string);
s->subtype = STRING_MALLOC;
s->u.string = str;
break;
}
case STRING_CONSTANT:
s->u.string = string_copy(sp->u.string, "unlink_string_svalue");
s->subtype = STRING_MALLOC;
break;
}
}
/*
* Free the data that an svalue is pointing to. Not the svalue
* itself.
* Use the free_svalue() define to call this
*/
#ifdef DEBUG
INLINE void int_free_svalue P2(svalue_t *, v, char *, tag)
#else
INLINE void int_free_svalue P1(svalue_t *, v)
#endif
{
if (v->type == T_STRING) {
char *str = v->u.string;
if (v->subtype & STRING_COUNTED) {
#ifdef STRING_STATS
int size = MSTR_SIZE(str);
#endif
SUB_STRING(size);
if (!(--(COUNTED_REF(str)))) {
NDBG(BLOCK(str));
if (v->subtype & STRING_HASHED) {
SUB_NEW_STRING(size, sizeof(block_t));
deallocate_string(str);
CHECK_STRING_STATS;
} else {
SUB_NEW_STRING(size, sizeof(malloc_block_t));
FREE(MSTR_BLOCK(str));
CHECK_STRING_STATS;
}
} else {
NDBG(BLOCK(str));
}
}
} else if (v->type & T_REFED) {
if (!(--v->u.refed->ref)) {
switch (v->type) {
case T_OBJECT:
dealloc_object(v->u.ob, "free_svalue");
break;
case T_CLASS:
dealloc_class(v->u.arr);
break;
case T_ARRAY:
dealloc_array(v->u.arr);
break;
case T_BUFFER:
if (v->u.buf != &null_buf)
FREE((char *)v->u.buf);
break;
case T_MAPPING:
dealloc_mapping(v->u.map);
break;
case T_FUNCTION:
dealloc_funp(v->u.fp);
break;
}
}
} else if (v->type == T_ERROR_HANDLER) {
(*v->u.error_handler)();
}
#ifdef DEBUG
else if (v->type == T_FREED) {
fatal("T_FREED svalue freed. Previously freed by %s.\n", v->u.string);
}
v->type = T_FREED;
v->u.string = tag;
#endif
}
/*
* Free several svalues, and free up the space used by the svalues.
* The svalues must be sequentially located.
*/
INLINE void free_some_svalues P2(svalue_t *, v, int, num)
{
while (num--)
free_svalue(v + num, "free_some_svalues");
FREE(v);
}
/*
* Prepend a slash in front of a string.
*/
char *add_slash P1(char *, str)
{
char *tmp;
tmp = new_string(strlen(str) + 1, "add_slash");
*tmp = '/';
strcpy(tmp + 1, str);
return tmp;
}
/*
* Assign to a svalue.
* This is done either when element in array, or when to an identifier
* (as all identifiers are kept in a array pointed to by the object).
*/
INLINE void assign_svalue_no_free P2(svalue_t *, to, svalue_t *, from)
{
DEBUG_CHECK(from == 0, "Attempt to assign_svalue() from a null ptr.\n");
DEBUG_CHECK(to == 0, "Attempt to assign_svalue() to a null ptr.\n");
*to = *from;
if (from->type == T_STRING) {
if (from->subtype & STRING_COUNTED) {
ADD_STRING(COUNTED_STRLEN(to->u.string));
COUNTED_REF(to->u.string)++;
NDBG(BLOCK(to->u.string));
}
} else if (from->type & T_REFED) {
from->u.refed->ref++;
}
}
INLINE void assign_svalue P2(svalue_t *, dest, svalue_t *, v)
{
/* First deallocate the previous value. */
free_svalue(dest, "assign_svalue");
assign_svalue_no_free(dest, v);
}
INLINE void push_some_svalues P2(svalue_t *, v, int, num)
{
if (sp + num >= end_of_stack) { too_deep_error = 1; error("stack overflow\n"); }
while (num--) push_svalue(v++);
}
/*
* Copies an array of svalues to another location, which should be
* free space.
*/
INLINE void copy_some_svalues P3(svalue_t *, dest, svalue_t *, v, int, num)
{
while (num--)
assign_svalue_no_free(dest+num, v+num);
}
INLINE void transfer_push_some_svalues P2(svalue_t *, v, int, num)
{
if (sp + num >= end_of_stack) { too_deep_error = 1; error("stack overflow\n"); }
memcpy(sp + 1, v, num * sizeof(svalue_t));
sp += num;
}
/*
* Pop the top-most value of the stack.
* Don't do this if it is a value that will be used afterwards, as the
* data may be sent to FREE(), and destroyed.
*/
INLINE void pop_stack()
{
DEBUG_CHECK(sp < start_of_stack, "Stack underflow.\n");
free_svalue(sp--, "pop_stack");
}
svalue_t global_lvalue_byte = { T_LVALUE_BYTE };
/*
* Compute the address of an array element.
*/
INLINE void push_indexed_lvalue P1(int, code)
{
int ind;
svalue_t *lv;
if (sp->type == T_LVALUE) {
lv = sp->u.lvalue;
if (!code && lv->type == T_MAPPING) {
sp--;
if (!(lv = find_for_insert(lv->u.map, sp, 0)))
mapping_too_large();
free_svalue(sp, "push_indexed_lvalue: 1");
sp->type = T_LVALUE;
sp->u.lvalue = lv;
return;
}
if (!((--sp)->type == T_NUMBER))
error("Illegal type of index\n");
ind = sp->u.number;
switch(lv->type){
case T_STRING:
{
int len = SVALUE_STRLEN(lv);
if (code) ind = len - ind;
if (ind >= len || ind < 0)
error("Index out of bounds in string index lvalue.\n");
unlink_string_svalue(lv);
sp->type = T_LVALUE;
sp->u.lvalue = &global_lvalue_byte;
global_lvalue_byte.u.lvalue_byte = (unsigned char *)&lv->u.string[ind];
break;
}
case T_BUFFER:
{
if (code) ind = lv->u.buf->size - ind;
if (ind >= lv->u.buf->size || ind < 0)
error("Buffer index out of bounds.\n");
sp->type = T_LVALUE;
sp->u.lvalue = &global_lvalue_byte;
global_lvalue_byte.u.lvalue_byte = &lv->u.buf->item[ind];
break;
}
case T_ARRAY:
{
if (code) ind = lv->u.arr->size - ind;
if (ind >= lv->u.arr->size || ind < 0)
error("Array index out of bounds\n");
sp->type = T_LVALUE;
sp->u.lvalue = lv->u.arr->item + ind;
break;
}
default:
error("Indexing on illegal type.\n");
}
} else {
/* It is now coming from (x <assign_type> y)[index]... = rhs */
/* Where x is a _valid_ lvalue */
/* Hence the reference to sp is at least 2 :) */
if (!code && (sp->type == T_MAPPING)){
if (!(lv = find_for_insert(sp->u.map, sp-1, 0)))
mapping_too_large();
sp->u.map->ref--;
free_svalue(--sp, "push_indexed_lvalue: 2");
sp->type = T_LVALUE;
sp->u.lvalue = lv;
return;
}
if (!((sp-1)->type == T_NUMBER))
error("Illegal type of index\n");
ind = (sp-1)->u.number;
switch (sp->type){
case T_STRING:
{
error("Illegal to make char lvalue from assigned string\n");
break;
}
case T_BUFFER:
{
if (code) ind = sp->u.buf->size - ind;
if (ind >= sp->u.buf->size || ind < 0)
error("Buffer index out of bounds.\n");
sp->u.buf->ref--;
(--sp)->type = T_LVALUE;
sp->u.lvalue = &global_lvalue_byte;
global_lvalue_byte.u.lvalue_byte = (sp+1)->u.buf->item + ind;
break;
}
case T_ARRAY:
{
if (code) ind = sp->u.arr->size - ind;
if (ind >= sp->u.arr->size || ind < 0)
error("Array index out of bounds.\n");
sp->u.arr->ref--;
(--sp)->type = T_LVALUE;
sp->u.lvalue = (sp+1)->u.arr->item + ind;
break;
}
default:
error("Indexing on illegal type.\n");
}
}
}
static struct lvalue_range {
int ind1, ind2, size;
svalue_t *owner;
} global_lvalue_range;
static svalue_t global_lvalue_range_sv = { T_LVALUE_RANGE };
INLINE void push_lvalue_range P1(int, code)
{
int ind1, ind2, size;
svalue_t *lv;
if (sp->type == T_LVALUE){
switch((lv = global_lvalue_range.owner = sp->u.lvalue)->type){
case T_ARRAY:
size = lv->u.arr->size;
break;
case T_STRING: {
size = SVALUE_STRLEN(lv);
unlink_string_svalue(lv);
break;
}
case T_BUFFER:
size = lv->u.buf->size;
break;
default:
error("Range lvalue on illegal type\n");
IF_DEBUG(size = 0);
}
} else
error("Range lvalue on illegal type\n");
if (!((--sp)->type == T_NUMBER)) error("Illegal 2nd index type to range lvalue\n");
ind2 = (code & 0x01) ? (size - sp->u.number) : sp->u.number;
if (++ind2 < 0 || (ind2 > size))
error("The 2nd index to range lvalue must be >= -1 and < sizeof(indexed value)\n");
if (!((--sp)->type == T_NUMBER)) error("Illegal 1st index type to range lvalue\n");
ind1 = (code & 0x10) ? (size - sp->u.number) : sp->u.number;
if (ind1 < 0 || ind1 > size)
error("The 1st index to range lvalue must be >= 0 and <= sizeof(indexed value)\n");
global_lvalue_range.ind1 = ind1;
global_lvalue_range.ind2 = ind2;
global_lvalue_range.size = size;
sp->type = T_LVALUE;
sp->u.lvalue = &global_lvalue_range_sv;
}
INLINE void copy_lvalue_range P1(svalue_t *, from)
{
int ind1, ind2, size, fsize;
svalue_t *owner;
ind1 = global_lvalue_range.ind1;
ind2 = global_lvalue_range.ind2;
size = global_lvalue_range.size;
owner = global_lvalue_range.owner;
switch(owner->type){
case T_ARRAY:
{
array_t *fv, *dv;
svalue_t *fptr, *dptr;
if (from->type != T_ARRAY) error("Illegal rhs to array range lvalue\n");
fv = from->u.arr;
fptr = fv->item;
if ((fsize = fv->size) == ind2 - ind1){
dptr = (owner->u.arr)->item + ind1;
if (fv->ref == 1){
/* Transfer the svalues */
while (fsize--){
free_svalue(dptr, "copy_lvalue_range : 1");
*dptr++ = *fptr++;
}
free_empty_array(fv);
} else {
while (fsize--) assign_svalue(dptr++, fptr++);
fv->ref--;
}
} else {
array_t *old_dv = owner->u.arr;
svalue_t *old_dptr = old_dv->item;
/* Need to reallocate the array */
dv = allocate_empty_array(size - ind2 + ind1 + fsize);
dptr = dv->item;
/* ind1 can range from 0 to sizeof(old_dv) */
while (ind1--) assign_svalue_no_free(dptr++, old_dptr++);
if (fv->ref == 1){
while (fsize--) *dptr++ = *fptr++;
free_empty_array(fv);
} else {
while (fsize--) assign_svalue_no_free(dptr++, fptr++);
fv->ref--;
}
/* ind2 can range from 0 to sizeof(old_dv) */
old_dptr = old_dv->item + ind2;
size -= ind2;
while (size--) assign_svalue_no_free(dptr++, old_dptr++);
free_array(old_dv);
owner->u.arr = dv;
}
break;
}
case T_STRING:
{
if (from->type != T_STRING) error("Illegal rhs to string range lvalue.\n");
if ((fsize = SVALUE_STRLEN(from)) == ind2 - ind1){
/* since fsize >= 0, ind2 - ind1 <= strlen(orig string) */
/* because both of them can only range from 0 to len */
strncpy(owner->u.string + ind1, from->u.string, fsize);
} else {
char *tmp, *dstr = owner->u.string;
owner->u.string = tmp = new_string(size - ind2 + ind1 + fsize, "copy_lvalue_range");
if (ind1 >= 1){
strncpy(tmp, dstr, ind1);
tmp += ind1;
}
strcpy(tmp, from->u.string);
tmp += fsize;
size -= ind2;
if (size >= 1){
strncpy(tmp, dstr + ind2, size);
*(tmp + size) = 0;
}
FREE_MSTR(dstr);
}
free_string_svalue(from);
break;
}
case T_BUFFER:
{
if (from->type != T_BUFFER) error("Illegal rhs to buffer range lvalue.\n");
if ((fsize = from->u.buf->size) == ind2 - ind1){
memcpy((owner->u.buf)->item + ind1, from->u.buf->item, fsize);
} else {
buffer_t *b;
unsigned char *old_item = (owner->u.buf)->item;
unsigned char *new_item;
b = allocate_buffer(size - ind2 + ind1 + fsize);
new_item = b->item;
if (ind1 >= 1){
memcpy(b->item, old_item, ind1);
new_item += ind1;
}
memcpy(new_item, from->u.buf, fsize);
new_item += fsize;
if ((size -= ind2) >= 1)
memcpy(new_item, old_item + ind2, size);
free_buffer(owner->u.buf);
owner->u.buf = b;
}
free_buffer(from->u.buf);
break;
}
}
}
INLINE void assign_lvalue_range P1(svalue_t *, from)
{
int ind1, ind2, size, fsize;
svalue_t *owner;
ind1 = global_lvalue_range.ind1;
ind2 = global_lvalue_range.ind2;
size = global_lvalue_range.size;
owner = global_lvalue_range.owner;
switch(owner->type){
case T_ARRAY:
{
array_t *fv, *dv;
svalue_t *fptr, *dptr;
if (from->type != T_ARRAY) error("Illegal rhs to array range lvalue\n");
fv = from->u.arr;
fptr = fv->item;
if ((fsize = fv->size) == ind2 - ind1){
dptr = (owner->u.arr)->item + ind1;
while (fsize--) assign_svalue(dptr++, fptr++);
} else {
array_t *old_dv = owner->u.arr;
svalue_t *old_dptr = old_dv->item;
/* Need to reallocate the array */
dv = allocate_empty_array(size - ind2 + ind1 + fsize);
dptr = dv->item;
/* ind1 can range from 0 to sizeof(old_dv) */
while (ind1--) assign_svalue_no_free(dptr++, old_dptr++);
while (fsize--) assign_svalue_no_free(dptr++, fptr++);
/* ind2 can range from 0 to sizeof(old_dv) */
old_dptr = old_dv->item + ind2;
size -= ind2;
while (size--) assign_svalue_no_free(dptr++, old_dptr++);
free_array(old_dv);
owner->u.arr = dv;
}
break;
}
case T_STRING:
{
if (from->type != T_STRING) error("Illegal rhs to string range lvalue.\n");
if ((fsize = SVALUE_STRLEN(from)) == ind2 - ind1){
/* since fsize >= 0, ind2 - ind1 <= strlen(orig string) */
/* because both of them can only range from 0 to len */
strncpy(owner->u.string + ind1, from->u.string, fsize);
} else {
char *tmp, *dstr = owner->u.string;
owner->u.string = tmp = new_string(size - ind2 + ind1 + fsize, "assign_lvalue_range");
if (ind1 >= 1){
strncpy(tmp, dstr, ind1);
tmp += ind1;
}
strcpy(tmp, from->u.string);
tmp += fsize;
size -= ind2;
if (size >= 1){
strncpy(tmp, dstr + ind2, size);
*(tmp + size) = 0;
}
FREE_MSTR(dstr);
}
break;
}
case T_BUFFER:
{
if (from->type != T_BUFFER) error("Illegal rhs to buffer range lvalue.\n");
if ((fsize = from->u.buf->size) == ind2 - ind1){
memcpy((owner->u.buf)->item + ind1, from->u.buf->item, fsize);
} else {
buffer_t *b;
unsigned char *old_item = (owner->u.buf)->item;
unsigned char *new_item;
b = allocate_buffer(size - ind2 + ind1 + fsize);
new_item = b->item;
if (ind1 >= 1){
memcpy(b->item, old_item, ind1);
new_item += ind1;
}
memcpy(new_item, from->u.buf, fsize);
new_item += fsize;
if ((size -= ind2) >= 1)
memcpy(new_item, old_item + ind2, size);
free_buffer(owner->u.buf);
owner->u.buf = b;
}
break;
}
}
}
/*
* Deallocate 'n' values from the stack.
*/
INLINE void
pop_n_elems P1(int, n)
{
DEBUG_CHECK1(n < 0, "pop_n_elems: %d elements.\n", n);
while (n--) {
pop_stack();
}
}
/*
* Deallocate 2 values from the stack.
*/
INLINE void
pop_2_elems()
{
free_svalue(sp--, "pop_2_elems");
DEBUG_CHECK(sp < start_of_stack, "Stack underflow.\n");
free_svalue(sp--, "pop_2_elems");
}
/*
* Deallocate 3 values from the stack.
*/
INLINE void
pop_3_elems()
{
free_svalue(sp--, "pop_3_elems");
free_svalue(sp--, "pop_3_elems");
DEBUG_CHECK(sp < start_of_stack, "Stack underflow.\n");
free_svalue(sp--, "pop_3_elems");
}
void bad_arg P2(int, arg, int, instr)
{
error("Bad argument %d to %s()\n", arg, get_f_name(instr));
}
void bad_argument P4(svalue_t *, val, int, type, int, arg, int, instr)
{
outbuffer_t outbuf;
int flag = 0;
int j = TYPE_CODES_START;
int k = 0;
outbuf_zero(&outbuf);
outbuf_addv(&outbuf, "Bad argument %d to %s%s\nExpected: ", arg,
get_f_name(instr), (instr < BASE ? "" : "()"));
do {
if (type & j) {
if (flag) outbuf_add(&outbuf, " or ");
else flag = 1;
outbuf_add(&outbuf, type_names[k]);
}
k++;
} while (!((j <<= 1) & TYPE_CODES_END));
outbuf_add(&outbuf, " Got: ");
svalue_to_string(val, &outbuf, 0, 0, 0);
outbuf_add(&outbuf, ".\n");
outbuf_fix(&outbuf);
error_needs_free(outbuf.buffer);
}
INLINE void
push_control_stack P2(int, frkind, void *, funp)
{
if (csp == &control_stack[MAX_TRACE - 1]) {
too_deep_error = 1;
error("Too deep recursion.\n");
}
csp++;
csp->caller_type = caller_type;
csp->ob = current_object;
csp->framekind = frkind;
csp->fr.func = (function_t *)funp;
csp->prev_ob = previous_ob;
csp->fp = fp;
csp->prog = current_prog;
csp->pc = pc;
csp->function_index_offset = function_index_offset;
csp->variable_index_offset = variable_index_offset;
#ifdef PROFILE_FUNCTIONS
if ((frkind & FRAME_MASK) == FRAME_FUNCTION) {
get_cpu_times(&(csp->entry_secs), &(csp->entry_usecs));
((function_t *)funp)->calls++;
}
#endif
}
/*
* Pop the control stack one element, and restore registers.
* extern_call must not be modified here, as it is used imediately after pop.
*/
void pop_control_stack()
{
DEBUG_CHECK(csp == (control_stack - 1),
"Popped out of the control stack\n");
#ifdef PROFILE_FUNCTIONS
if ((csp->framekind & FRAME_MASK) == FRAME_FUNCTION) {
long secs, usecs, dsecs;
get_cpu_times((unsigned long *) &secs, (unsigned long *) &usecs);
dsecs = (((secs - csp->entry_secs) * 1000000)
+ (usecs - csp->entry_usecs));
csp->fr.func->self += dsecs;
if (csp != control_stack) {
if (((csp - 1)->framekind & FRAME_MASK) == FRAME_FUNCTION) {
(csp - 1)->fr.func->children += dsecs;
}
}
}
#endif
current_object = csp->ob;
current_prog = csp->prog;
previous_ob = csp->prev_ob;
caller_type = csp->caller_type;
pc = csp->pc;
fp = csp->fp;
function_index_offset = csp->function_index_offset;
variable_index_offset = csp->variable_index_offset;
csp--;
}
/*
* Push a pointer to a array on the stack. Note that the reference count
* is incremented. Newly created arrays normally have a reference count
* initialized to 1.
*/
INLINE void push_array P1(array_t *, v)
{
v->ref++;
sp++;
sp->type = T_ARRAY;
sp->u.arr = v;
}
INLINE void push_refed_array P1(array_t *, v)
{
sp++;
sp->type = T_ARRAY;
sp->u.arr = v;
}
INLINE void
push_buffer P1(buffer_t *, b)
{
b->ref++;
sp++;
sp->type = T_BUFFER;
sp->u.buf = b;
}
INLINE void
push_refed_buffer P1(buffer_t *, b)
{
sp++;
sp->type = T_BUFFER;
sp->u.buf = b;
}
/*
* Push a mapping on the stack. See push_array(), above.
*/
INLINE void
push_mapping P1(mapping_t *, m)
{
m->ref++;
sp++;
sp->type = T_MAPPING;
sp->u.map = m;
}
INLINE void
push_refed_mapping P1(mapping_t *, m)
{
sp++;
sp->type = T_MAPPING;
sp->u.map = m;
}
/*
* Push a class on the stack. See push_array(), above.
*/
INLINE void
push_class P1(array_t *, v)
{
v->ref++;
sp++;
sp->type = T_CLASS;
sp->u.arr = v;
}
INLINE void
push_refed_class P1(array_t *, v)
{
sp++;
sp->type = T_CLASS;
sp->u.arr = v;
}
/*
* Push a string on the stack that is already malloced.
*/
INLINE void push_malloced_string P1(char *, p)
{
sp++;
sp->type = T_STRING;
sp->u.string = p;
sp->subtype = STRING_MALLOC;
}
/*
* Push a string on the stack that is already constant.
* um. yeah. Name for historical reasons.
* See push_string(..., STRING_CONSTANT) for stuff that is really constant.
*/
INLINE
void push_constant_string P1(char *, p)
{
sp++;
sp->type = T_STRING;
sp->u.string = make_shared_string(p);
sp->subtype = STRING_SHARED;
}
#ifdef TRACE
static void do_trace_call P1(function_t *, funp)
{
do_trace("Call direct ", funp->name, " ");
if (TRACEHB) {
if (TRACETST(TRACE_ARGS)) {
int i;
add_vmessage(command_giver, " with %d arguments: ", funp->num_arg);
for (i = funp->num_arg - 1; i >= 0; i--) {
print_svalue(&sp[-i]);
add_message(command_giver, " ");
}
}
add_message(command_giver, "\n");
}
}
#endif
/*
* Argument is the function to execute. If it is defined by inheritance,
* then search for the real definition, and return it.
* There is a number of arguments on the stack. Normalize them and initialize
* local variables, so that the called function is pleased.
*/
INLINE void setup_variables P3(int, actual, int, local, int, num_arg) {
int tmp;
if ((tmp = actual - num_arg) > 0) {
/* Remove excessive arguments */
pop_n_elems(tmp);
push_nulls(local);
} else {
/* Correct number of arguments and local variables */
push_nulls(local - tmp);
}
fp = sp - (csp->num_local_variables = local + num_arg) + 1;
}
INLINE void setup_varargs_variables P3(int, actual, int, local, int, num_arg) {
array_t *arr;
if (actual >= num_arg) {
int n = actual - num_arg + 1;
/* Aggregate excessive arguments */
arr = allocate_empty_array(n);
while (n--)
arr->item[n] = *sp--;
} else {
/* Correct number of arguments and local variables */
push_nulls(num_arg - 1 - actual);
arr = null_array();
}
push_refed_array(arr);
push_nulls(local);
fp = sp - (csp->num_local_variables = local + num_arg) + 1;
}
INLINE function_t *
setup_new_frame P1(function_t *, funp)
{
function_index_offset = variable_index_offset = 0;
while (funp->flags & NAME_INHERITED) {
function_index_offset +=
current_prog->inherit[funp->offset].function_index_offset;
variable_index_offset +=
current_prog->inherit[funp->offset].variable_index_offset;
current_prog = current_prog->inherit[funp->offset].prog;
funp = ¤t_prog->functions[funp->function_index_offset];
}
/* Remove excessive arguments */
if (funp->flags & NAME_TRUE_VARARGS)
setup_varargs_variables(csp->num_local_variables, funp->num_local,
funp->num_arg);
else
setup_variables(csp->num_local_variables, funp->num_local,
funp->num_arg);
#ifdef TRACE
tracedepth++;
if (TRACEP(TRACE_CALL)) {
do_trace_call(funp);
}
#endif
return funp;
}
INLINE function_t *setup_inherited_frame P1(function_t *, funp)
{
while (funp->flags & NAME_INHERITED) {
function_index_offset +=
current_prog->inherit[funp->offset].function_index_offset;
variable_index_offset +=
current_prog->inherit[funp->offset].variable_index_offset;
current_prog = current_prog->inherit[funp->offset].prog;
funp = ¤t_prog->functions[funp->function_index_offset];
}
/* Remove excessive arguments */
if (funp->flags & NAME_TRUE_VARARGS)
setup_varargs_variables(csp->num_local_variables, funp->num_local,
funp->num_arg);
else
setup_variables(csp->num_local_variables, funp->num_local,
funp->num_arg);
#ifdef TRACE
tracedepth++;
if (TRACEP(TRACE_CALL)) {
do_trace_call(funp);
}
#endif
return funp;
}
#ifdef DEBUG
void break_point()
{
/* The current implementation of foreach leaves some stuff lying on the
stack */
if (!foreach_in_progress && sp - fp - csp->num_local_variables + 1 != 0)
fatal("Bad stack pointer.\n");
}
#endif
program_t fake_prog = { "<function>" };
unsigned char fake_program = F_RETURN;
void setup_fake_frame P1(funptr_t *, fun) {
if (csp == &control_stack[MAX_TRACE-1]) {
too_deep_error = 1;
error("Too deep recursion.\n");
}
csp++;
csp->caller_type = caller_type;
csp->framekind = FRAME_FAKE | FRAME_OB_CHANGE;
csp->fr.funp = fun;
csp->ob = current_object;
csp->prev_ob = previous_ob;
csp->fp = fp;
csp->prog = current_prog;
csp->pc = pc;
pc = (char *)&fake_program;
csp->function_index_offset = function_index_offset;
csp->variable_index_offset = variable_index_offset;
caller_type = ORIGIN_FUNCTION_POINTER;
csp->num_local_variables = 0;
current_prog = &fake_prog;
previous_ob = current_object;
current_object = fun->hdr.owner;
}
void remove_fake_frame() {
DEBUG_CHECK(csp == (control_stack - 1),
"Popped out of the control stack\n");
current_object = csp->ob;
current_prog = csp->prog;
previous_ob = csp->prev_ob;
caller_type = csp->caller_type;
pc = csp->pc;
fp = csp->fp;
function_index_offset = csp->function_index_offset;
variable_index_offset = csp->variable_index_offset;
csp--;
}
/* num_arg args are on the stack, and the args from the array vec should be
* put in front of them. This is so that the order of arguments is logical.
*
* evaluate( (: f, a :), b) -> f(a,b) and not f(b, a) which would happen
* if we simply pushed the args from vec at this point. (Note that the
* old function pointers are broken in this regard)
*/
int merge_arg_lists P3(int, num_arg, array_t *, arr, int, start) {
int num_arr_arg = arr->size - start;
svalue_t *sptr;
if (num_arr_arg) {
sptr = (sp += num_arr_arg);
if (num_arg) {
/* We need to do some stack movement so that the order
of arguments is logical */
while (num_arg--) {
*sptr = *(sptr - num_arr_arg);
sptr--;
}
}
num_arg = arr->size;
while (--num_arg >= start)
assign_svalue_no_free(sptr--, &arr->item[num_arg]);
return (sp - sptr); /* could just return num_arr_arg if num_arg is 0 but .... -Sym */
}
return num_arg;
}
void cfp_error P1(char *, s) {
remove_fake_frame();
error(s);
}
svalue_t *
call_function_pointer P2(funptr_t *, funp, int, num_arg)
{
static func_t *oefun_table = efun_table - BASE;
function_t *func;
if (funp->hdr.owner->flags & O_DESTRUCTED)
error("Owner (/%s) of function pointer is destructed.\n",
funp->hdr.owner->name);
setup_fake_frame(funp);
if (current_object->flags & O_SWAPPED)
load_ob_from_swap(current_object);
switch (funp->hdr.type) {
case FP_SIMUL:
if (funp->hdr.args) {
check_for_destr(funp->hdr.args);
num_arg = merge_arg_lists(num_arg, funp->hdr.args, 0);
}
call_simul_efun(funp->f.simul.index, num_arg);
break;
case FP_EFUN:
{
int i, def;
fp = sp - num_arg + 1;
if (funp->hdr.args) {
check_for_destr(funp->hdr.args);
num_arg = merge_arg_lists(num_arg, funp->hdr.args, 0);
}
i = funp->f.efun.index;
if (num_arg == instrs[i].min_arg - 1 &&
((def = instrs[i].Default) != DEFAULT_NONE)) {
if (def == DEFAULT_THIS_OBJECT) {
if (current_object && !(current_object->flags & O_DESTRUCTED))
push_object(current_object);
else
*(++sp)=const0;
} else {
(++sp)->type = T_NUMBER;
sp->u.number = def;
}
num_arg++;
} else
if (num_arg < instrs[i].min_arg) {
error("Too few arguments to efun %s in efun pointer.\n", instrs[i].name);
} else if (num_arg > instrs[i].max_arg && instrs[i].max_arg != -1) {
error("Too many arguments to efun %s in efun pointer.\n", instrs[i].name);
}
/* possibly we should add TRACE, OPC, etc here;
also on eval_cost here, which is ok for just 1 efun */
{
int j, n = instrs[i].min_arg;
st_num_arg = num_arg;
for (j = 0; j < n; j++) {
CHECK_TYPES(sp - num_arg + j + 1, instrs[i].type[j], j + 1, i);
}
(*oefun_table[i])();
free_svalue(&apply_ret_value, "call_function_pointer");
if (instrs[i].ret_type == TYPE_NOVALUE)
apply_ret_value = const0;
else
apply_ret_value = *sp--;
remove_fake_frame();
return &apply_ret_value;
}
}
case FP_LOCAL | FP_NOT_BINDABLE: {
fp = sp - num_arg + 1;
/* After the fake frame, current_object is funp->hdr.owner - Sym */
func = ¤t_object->prog->functions[funp->f.local.index];
if (func->flags & NAME_UNDEFINED)
error("Undefined function: %s\n", func->name);
push_control_stack(FRAME_FUNCTION, func);
caller_type = ORIGIN_LOCAL;
current_prog = funp->hdr.owner->prog;
if (funp->hdr.args) {
array_t *v = funp->hdr.args;
check_for_destr(v);
num_arg = merge_arg_lists(num_arg, v, 0);
}
csp->num_local_variables = num_arg;
func = setup_new_frame(func);
call_program(current_prog, func->offset);
break;
}
case FP_FUNCTIONAL:
case FP_FUNCTIONAL | FP_NOT_BINDABLE: {
fp = sp - num_arg + 1;
push_control_stack(FRAME_FUNP, funp);
caller_type = ORIGIN_FUNCTIONAL;
current_prog = funp->f.functional.prog;
if (funp->hdr.args) {
array_t *v = funp->hdr.args;
check_for_destr(v);
num_arg = merge_arg_lists(num_arg, v, 0);
}
setup_variables(num_arg, funp->f.functional.num_local,
funp->f.functional.num_arg);
function_index_offset = funp->f.functional.fio;
variable_index_offset = funp->f.functional.vio;
call_program(funp->f.functional.prog, funp->f.functional.offset);
break;
}
default:
error("Unsupported function pointer type.\n");
}
free_svalue(&apply_ret_value, "call_function_pointer");
apply_ret_value = *sp--;
remove_fake_frame();
return &apply_ret_value;
}
svalue_t *
safe_call_function_pointer P2(funptr_t *, funp, int, num_arg)
{
error_context_t econ;
svalue_t *ret;
save_context(&econ);
if (!SETJMP(econ.context)) {
ret = call_function_pointer(funp, num_arg);
} else {
restore_context(&econ);
/* condition was restored to where it was when we came in */
pop_n_elems(num_arg);
ret = NULL;
}
pop_context(&econ);
return ret;
}
/*
* When a array is given as argument to an efun, all items have to be
* checked if there would be a destructed object.
* A bad problem currently is that a array can contain another array, so this
* should be tested too. But, there is currently no prevention against
* recursive arrays, which means that this can not be tested. Thus, MudOS
* may crash if a array contains a array that contains a destructed object
* and this top-most array is used as an argument to an efun.
*/
/* MudOS won't crash when doing simple operations like assign_svalue
* on a destructed object. You have to watch out, of course, that you don't
* apply a function to it.
* to save space it is preferable that destructed objects are freed soon.
* amylaar
*/
void check_for_destr P1(array_t *, v)
{
int i = v->size;
while (i--) {
if ((v->item[i].type == T_OBJECT) && (v->item[i].u.ob->flags & O_DESTRUCTED)) {
free_svalue(&v->item[i], "check_for_destr");
v->item[i] = const0;
}
}
}
/* do_loop_cond() coded by John Garnett, 1993/06/01
Optimizes these four cases (with 'int i'):
1) for (expr0; i < integer_variable; expr2) statement;
2) for (expr0; i < integer_constant; expr2) statement;
3) while (i < integer_variable) statement;
4) while (i < integer_constant) statement;
*/
static INLINE void do_loop_cond_local()
{
svalue_t *s1, *s2;
int i;
s1 = fp + EXTRACT_UCHAR(pc++); /* a from (a < b) */
s2 = fp + EXTRACT_UCHAR(pc++);
switch(s1->type | s2->type){
case T_NUMBER:
i = s1->u.number < s2->u.number;
break;
case T_REAL:
i = s1->u.real < s2->u.real;
break;
case T_STRING:
i = (strcmp(s1->u.string, s2->u.string) < 0);
break;
case T_NUMBER|T_REAL:
if (s1->type == T_NUMBER) i = s1->u.number < s2->u.real;
else i = s1->u.real < s2->u.number;
break;
default:
if (s1->type == T_OBJECT && (s1->u.ob->flags & O_DESTRUCTED)) {
free_object(s1->u.ob, "do_loop_cond:1");
*s1 = const0;
}
if (s2->type == T_OBJECT && (s2->u.ob->flags & O_DESTRUCTED)) {
free_object(s2->u.ob, "do_loop_cond:2");
*s2 = const0;
}
if (s1->type == T_NUMBER && s2->type == T_NUMBER) {
i = s1->u.number < s2->u.number;
break;
}
switch(s1->type){
case T_NUMBER:
case T_REAL:
error("2nd argument to < is not numeric when the 1st is.\n");
case T_STRING:
error("2nd argument to < is not string when the 1st is.\n");
default:
error("Bad 1st argument to <.\n");
}
i = 0;
}
if (i) {
unsigned short offset;
COPY_SHORT(&offset, pc);
pc -= offset;
} else pc += 2;
}
static INLINE void do_loop_cond_number()
{
svalue_t *s1;
int i;
s1 = fp + EXTRACT_UCHAR(pc++); /* a from (a < b) */
LOAD_INT(i, pc);
if (s1->type == T_NUMBER) {
if (s1->u.number < i){
unsigned short offset;
COPY_SHORT(&offset, pc);
pc -= offset;
} else pc += 2;
} else if (s1->type == T_REAL) {
if (s1->u.real < i){
unsigned short offset;
COPY_SHORT(&offset, pc);
pc -= offset;
} else pc += 2;
} else error("Right side of < is a number, left side is not.\n");
}
#ifdef LPC_TO_C
void
call_program P2(program_t *, prog, POINTER_INT, offset) {
if (prog->program_size)
eval_instruction(prog->program + offset);
else {
DEBUG_CHECK(!offset, "Null function pointer in jump_table.\n");
(*
( void (*) PROT((void)) ) offset /* cast to a function pointer */
)();
}
}
#endif
/*
* Evaluate instructions at address 'p'. All program offsets are
* to current_prog->program. 'current_prog' must be setup before
* call of this function.
*
* There must not be destructed objects on the stack. The destruct_object()
* function will automatically remove all occurences. The effect is that
* all called efuns knows that they won't have destructed objects as
* arguments.
*/
#ifdef TRACE_CODE
static int previous_instruction[60];
static int stack_size[60];
static char *previous_pc[60];
static int last;
#endif
void
eval_instruction P1(char *, p)
{
#ifdef DEBUG
int num_arg;
#endif
int i, n;
float real;
svalue_t *lval;
int instruction;
#if defined(TRACE_CODE) || defined(TRACE) || defined(OPCPROF) || defined(OPCPROF_2D)
int real_instruction;
#endif
unsigned short offset;
static func_t *oefun_table = efun_table - BASE + ONEARG_MAX;
#ifndef DEBUG
static func_t *ooefun_table = efun_table - BASE;
#endif
static instr_t *instrs2 = instrs + ONEARG_MAX;
IF_DEBUG(svalue_t *expected_stack);
/* Next F_RETURN at this level will return out of eval_instruction() */
csp->framekind |= FRAME_EXTERNAL;
pc = p;
while (1) {
instruction = EXTRACT_UCHAR(pc++);
#if defined(TRACE_CODE) || defined(TRACE) || defined(OPCPROF) || defined(OPCPROF_2D)
if (instruction >= F_EFUN0 && instruction <= F_EFUNV)
real_instruction = EXTRACT_UCHAR(pc) + ONEARG_MAX;
else
real_instruction = instruction;
# ifdef TRACE_CODE
previous_instruction[last] = real_instruction;
previous_pc[last] = pc - 1;
stack_size[last] = sp - fp - csp->num_local_variables;
last = (last + 1) % (sizeof previous_instruction / sizeof(int));
# endif
# ifdef TRACE
if (TRACEP(TRACE_EXEC)) {
do_trace("Exec ", get_f_name(real_instruction), "\n");
}
# endif
# ifdef OPCPROF
if (real_instruction < BASE)
opc_eoper[real_instruction]++;
else
opc_efun[real_instruction-BASE].count++;
# endif
# ifdef OPCPROF_2D
if (real_instruction < BASE) {
if (last_eop) opc_eoper_2d[last_eop][real_instruction]++;
last_eop = real_instruction;
} else {
if (last_eop) opc_eoper_2d[last_eop][BASE]++;
last_eop = BASE;
}
# endif
#endif
if (!--eval_cost) {
debug_message("object /%s: eval_cost too big %d\n",
current_object->name, max_cost);
eval_cost = max_cost;
max_eval_error = 1;
error("Too long evaluation. Execution aborted.\n");
}
/*
* Execute current instruction. Note that all functions callable from
* LPC must return a value. This does not apply to control
* instructions, like F_JUMP.
*/
switch (instruction) {
case F_PUSH: /* Push a number of things onto the stack */
n = EXTRACT_UCHAR(pc++);
while (n--) {
i = EXTRACT_UCHAR(pc++);
switch (i & PUSH_WHAT) {
case PUSH_STRING:
DEBUG_CHECK1((i & PUSH_MASK) >= current_prog->num_strings,
"string %d out of range in F_STRING!\n",
i & PUSH_MASK);
(++sp)->type = T_STRING;
sp->subtype = STRING_SHARED;
sp->u.string = ref_string(current_prog->strings[i & PUSH_MASK]);
break;
case PUSH_LOCAL:
lval = fp + (i & PUSH_MASK);
DEBUG_CHECK((fp - lval) >= csp->num_local_variables,
"Tried to push non-existent local\n");
if ((lval->type == T_OBJECT) && (lval->u.ob->flags & O_DESTRUCTED)) {
*++sp = const0;
assign_svalue(lval, &const0);
} else {
push_svalue(lval);
}
break;
case PUSH_GLOBAL:
lval = find_value((int)((i & PUSH_MASK) + variable_index_offset));
if ((lval->type == T_OBJECT) && (lval->u.ob->flags & O_DESTRUCTED)) {
*++sp = const0;
assign_svalue(lval, &const0);
} else {
push_svalue(lval);
}
break;
case PUSH_NUMBER:
push_number(i & PUSH_MASK);
break;
}
}
break;
case F_INC:
DEBUG_CHECK(sp->type != T_LVALUE,
"non-lvalue argument to ++\n");
lval = (sp--)->u.lvalue;
switch (lval->type) {
case T_NUMBER:
lval->u.number++;
break;
case T_REAL:
lval->u.real++;
break;
case T_LVALUE_BYTE:
++*global_lvalue_byte.u.lvalue_byte;
break;
default:
error("++ of non-numeric argument\n");
}
break;
case F_WHILE_DEC:
{
svalue_t *s;
s = fp + EXTRACT_UCHAR(pc++);
if (s->type == T_NUMBER) {
i = s->u.number--;
} else if (s->type == T_REAL) {
i = s->u.real--;
} else {
error("-- of non-numeric argument\n");
}
if (i) {
COPY_SHORT(&offset, pc);
pc -= offset;
} else {
pc += 2;
}
}
break;
case F_LOCAL_LVALUE:
(++sp)->type = T_LVALUE;
sp->u.lvalue = fp + EXTRACT_UCHAR(pc++);
break;
case F_NUMBER:
LOAD_INT(i, pc);
push_number(i);
break;
case F_REAL:
LOAD_FLOAT(real, pc);
push_real(real);
break;
case F_BYTE:
push_number(EXTRACT_UCHAR(pc++));
break;
case F_NBYTE:
push_number(-((int)EXTRACT_UCHAR(pc++)));
break;
#ifdef F_JUMP_WHEN_NON_ZERO
case F_JUMP_WHEN_NON_ZERO:
if ((i = (sp->type == T_NUMBER)) && (sp->u.number == 0))
pc += 2;
else {
COPY_SHORT(&offset, pc);
pc = current_prog->program + offset;
}
if (i) {
sp--; /* when sp is an integer svalue, its cheaper
* to do this */
} else {
pop_stack();
}
break;
#endif
case F_BRANCH: /* relative offset */
COPY_SHORT(&offset, pc);
pc += offset;
break;
case F_BBRANCH: /* relative offset */
COPY_SHORT(&offset, pc);
pc -= offset;
break;
case F_BRANCH_NE:
f_ne();
if ((sp--)->u.number) {
COPY_SHORT(&offset, pc);
pc += offset;
} else
pc += 2;
break;
case F_BRANCH_GE:
f_ge();
if ((sp--)->u.number) {
COPY_SHORT(&offset, pc);
pc += offset;
} else
pc += 2;
break;
case F_BRANCH_LE:
f_le();
if ((sp--)->u.number) {
COPY_SHORT(&offset, pc);
pc += offset;
} else
pc += 2;
break;
case F_BRANCH_EQ:
f_eq();
if ((sp--)->u.number) {
COPY_SHORT(&offset, pc);
pc += offset;
} else
pc += 2;
break;
case F_BBRANCH_LT:
f_lt();
if ((sp--)->u.number) {
COPY_SHORT(&offset, pc);
pc -= offset;
} else
pc += 2;
break;
case F_BRANCH_WHEN_ZERO: /* relative offset */
if (sp->type == T_NUMBER) {
if (!((sp--)->u.number)) {
COPY_SHORT(&offset, pc);
pc += offset;
break;
}
} else pop_stack();
pc += 2; /* skip over the offset */
break;
case F_BRANCH_WHEN_NON_ZERO: /* relative offset */
if (sp->type == T_NUMBER) {
if (!((sp--)->u.number)) {
pc += 2;
break;
}
} else pop_stack();
COPY_SHORT(&offset, pc);
pc += offset;
break;
case F_BBRANCH_WHEN_ZERO: /* relative backwards offset */
if (sp->type == T_NUMBER) {
if (!((sp--)->u.number)) {
COPY_SHORT(&offset, pc);
pc -= offset;
break;
}
} else pop_stack();
pc += 2;
break;
case F_BBRANCH_WHEN_NON_ZERO: /* relative backwards offset */
if (sp->type == T_NUMBER) {
if (!((sp--)->u.number)) {
pc += 2;
break;
}
} else pop_stack();
COPY_SHORT(&offset, pc);
pc -= offset;
break;
case F_LOR:
/* replaces F_DUP; F_BRANCH_WHEN_NON_ZERO; F_POP */
if (sp->type == T_NUMBER) {
if (!sp->u.number) {
pc += 2;
sp--;
break;
}
}
COPY_SHORT(&offset, pc);
pc += offset;
break;
case F_LAND:
/* replaces F_DUP; F_BRANCH_WHEN_ZERO; F_POP */
if (sp->type == T_NUMBER) {
if (!sp->u.number) {
COPY_SHORT(&offset, pc);
pc += offset;
break;
}
sp--;
} else pop_stack();
pc += 2;
break;
case F_LOOP_INCR: /* this case must be just prior to
* F_LOOP_COND */
{
svalue_t *s;
s = fp + EXTRACT_UCHAR(pc++);
if (s->type == T_NUMBER) {
s->u.number++;
} else if (s->type == T_REAL) {
s->u.real++;
} else {
error("++ of non-numeric argument\n");
}
}
if (*pc == F_LOOP_COND_LOCAL) {
pc++;
do_loop_cond_local();
} else if (*pc == F_LOOP_COND_NUMBER) {
pc++;
do_loop_cond_number();
}
break;
case F_LOOP_COND_LOCAL:
do_loop_cond_local();
break;
case F_LOOP_COND_NUMBER:
do_loop_cond_number();
break;
case F_TRANSFER_LOCAL:
{
svalue_t *s;
s = fp + EXTRACT_UCHAR(pc++);
DEBUG_CHECK((fp-s) >= csp->num_local_variables,
"Tried to push non-existent local\n");
if ((s->type == T_OBJECT) && (s->u.ob->flags & O_DESTRUCTED))
*++sp = const0;
else
*++sp = *s;
/* The optimizer has asserted this won't be used again. Make
* it look like a number to avoid double frees. */
s->type = T_NUMBER;
break;
}
case F_LOCAL:
{
svalue_t *s;
s = fp + EXTRACT_UCHAR(pc++);
DEBUG_CHECK((fp-s) >= csp->num_local_variables,
"Tried to push non-existent local\n");
/*
* If variable points to a destructed object, replace it
* with 0, otherwise, fetch value of variable.
*/
if ((s->type == T_OBJECT) && (s->u.ob->flags & O_DESTRUCTED)) {
*++sp = const0;
assign_svalue(s, &const0);
} else {
assign_svalue_no_free(++sp, s);
}
break;
}
case F_LT:
f_lt();
break;
case F_ADD:
{
switch (sp->type) {
case T_BUFFER:
{
if (!((sp-1)->type == T_BUFFER)) {
error("Bad type argument to +. Had %s and %s.\n",
type_name((sp - 1)->type), type_name(sp->type));
} else {
buffer_t *b;
b = allocate_buffer(sp->u.buf->size + (sp - 1)->u.buf->size);
memcpy(b->item, (sp - 1)->u.buf->item, (sp - 1)->u.buf->size);
memcpy(b->item + (sp - 1)->u.buf->size, sp->u.buf->item,
sp->u.buf->size);
free_buffer((sp--)->u.buf);
free_buffer(sp->u.buf);
sp->u.buf = b;
}
break;
} /* end of x + T_BUFFER */
case T_NUMBER:
{
switch ((--sp)->type) {
case T_NUMBER:
sp->u.number += (sp+1)->u.number;
break;
case T_REAL:
sp->u.real += (sp+1)->u.number;
break;
case T_STRING:
{
char buff[20];
sprintf(buff, "%d", (sp+1)->u.number);
EXTEND_SVALUE_STRING(sp, buff, "f_add: 2");
break;
}
default:
error("Bad type argument to +. Had %s and %s.\n",
type_name(sp->type), type_name((sp+1)->type));
}
break;
} /* end of x + NUMBER */
case T_REAL:
{
switch ((--sp)->type) {
case T_NUMBER:
sp->type = T_REAL;
sp->u.real = sp->u.number + (sp+1)->u.real;
break;
case T_REAL:
sp->u.real += (sp+1)->u.real;
break;
case T_STRING:
{
char buff[40];
sprintf(buff, "%f", (sp+1)->u.real);
EXTEND_SVALUE_STRING(sp, buff, "f_add: 2");
break;
}
default:
error("Bad type argument to +. Had %s and %s\n",
type_name(sp->type), type_name((sp+1)->type));
}
break;
} /* end of x + T_REAL */
case T_ARRAY:
{
if (!((sp-1)->type == T_ARRAY)) {
error("Bad type argument to +. Had %s and %s\n",
type_name((sp - 1)->type), type_name(sp->type));
} else {
/* add_array now free's the arrays */
(sp-1)->u.arr = add_array((sp - 1)->u.arr, sp->u.arr);
sp--;
break;
}
} /* end of x + T_ARRAY */
case T_MAPPING:
{
if ((sp-1)->type == T_MAPPING) {
mapping_t *map;
map = add_mapping((sp - 1)->u.map, sp->u.map);
free_mapping((sp--)->u.map);
free_mapping(sp->u.map);
sp->u.map = map;
break;
} else
error("Bad type argument to +. Had %s and %s\n",
type_name((sp - 1)->type), type_name(sp->type));
} /* end of x + T_MAPPING */
case T_STRING:
{
switch ((sp-1)->type) {
case T_NUMBER:
{
char buff[20];
sprintf(buff, "%d", (sp-1)->u.number);
SVALUE_STRING_ADD_LEFT(buff, "f_add: 3");
break;
} /* end of T_NUMBER + T_STRING */
case T_REAL:
{
char buff[40];
sprintf(buff, "%f", (sp - 1)->u.real);
SVALUE_STRING_ADD_LEFT(buff, "f_add: 3");
break;
} /* end of T_REAL + T_STRING */
case T_STRING:
{
SVALUE_STRING_JOIN(sp-1, sp, "f_add: 1");
sp--;
break;
} /* end of T_STRING + T_STRING */
default:
error("Bad type argument to +. Had %s and %s\n",
type_name((sp - 1)->type), type_name(sp->type));
}
break;
} /* end of x + T_STRING */
default:
error("Bad type argument to +. Had %s and %s.\n",
type_name((sp-1)->type), type_name(sp->type));
}
break;
}
case F_VOID_ADD_EQ:
case F_ADD_EQ:
DEBUG_CHECK(sp->type != T_LVALUE,
"non-lvalue argument to +=\n");
lval = sp->u.lvalue;
sp--; /* points to the RHS */
switch (lval->type) {
case T_STRING:
if (sp->type == T_STRING) {
SVALUE_STRING_JOIN(lval, sp, "f_add_eq: 1");
} else if (sp->type == T_NUMBER) {
char buff[20];
sprintf(buff, "%d", sp->u.number);
EXTEND_SVALUE_STRING(lval, buff, "f_add_eq: 2");
} else if (sp->type == T_REAL) {
char buff[40];
sprintf(buff, "%f", sp->u.real);
EXTEND_SVALUE_STRING(lval, buff, "f_add_eq: 2");
} else {
bad_argument(sp, T_STRING | T_NUMBER | T_REAL, 2, instruction);
}
break;
case T_NUMBER:
if (sp->type == T_NUMBER) {
lval->u.number += sp->u.number;
/* both sides are numbers, no freeing required */
} else if (sp->type == T_REAL) {
lval->u.number += sp->u.real;
/* both sides are numbers, no freeing required */
} else {
error("Left hand side of += is a number (or zero); right side is not a number.\n");
}
break;
case T_REAL:
if (sp->type == T_NUMBER) {
lval->u.real += sp->u.number;
/* both sides are numerics, no freeing required */
}
if (sp->type == T_REAL) {
lval->u.real += sp->u.real;
/* both sides are numerics, no freeing required */
} else {
error("Left hand side of += is a number (or zero); right side is not a number.\n");
}
break;
case T_BUFFER:
if (sp->type != T_BUFFER) {
bad_argument(sp, T_BUFFER, 2, instruction);
} else {
buffer_t *b;
b = allocate_buffer(lval->u.buf->size + sp->u.buf->size);
memcpy(b->item, lval->u.buf->item, lval->u.buf->size);
memcpy(b->item + lval->u.buf->size, sp->u.buf->item,
sp->u.buf->size);
free_buffer(sp->u.buf);
free_buffer(lval->u.buf);
lval->u.buf = b;
}
break;
case T_ARRAY:
if (sp->type != T_ARRAY)
bad_argument(sp, T_ARRAY, 2, instruction);
else {
/* add_array now frees the arrays */
lval->u.arr = add_array(lval->u.arr, sp->u.arr);
}
break;
case T_MAPPING:
if (sp->type != T_MAPPING)
bad_argument(sp, T_MAPPING, 2, instruction);
else {
absorb_mapping(lval->u.map, sp->u.map);
free_mapping(sp->u.map); /* free RHS */
/* LHS not freed because its being reused */
}
break;
case T_LVALUE_BYTE:
if (sp->type != T_NUMBER)
error("Bad right type to += of char lvalue.\n");
else *global_lvalue_byte.u.lvalue_byte += sp->u.number;
break;
default:
bad_arg(1, instruction);
}
if (instruction == F_ADD_EQ) { /* not void add_eq */
assign_svalue_no_free(sp, lval);
} else {
/*
* but if (void)add_eq then no need to produce an
* rvalue
*/
sp--;
}
break;
case F_AND:
f_and();
break;
case F_AND_EQ:
f_and_eq();
break;
case F_FUNCTION_CONSTRUCTOR:
f_function_constructor();
break;
case F_FOREACH:
{
int flags = EXTRACT_UCHAR(pc++);
IF_DEBUG(foreach_in_progress++);
if (flags & 4) {
CHECK_TYPES(sp, T_MAPPING, 2, F_FOREACH);
push_refed_array(mapping_indices(sp->u.map));
(++sp)->type = T_NUMBER;
sp->u.lvalue = (sp-1)->u.arr->item;
sp->subtype = (sp-1)->u.arr->size;
(++sp)->type = T_LVALUE;
if (flags & 2)
sp->u.lvalue = find_value((int)(EXTRACT_UCHAR(pc++) + variable_index_offset));
else
sp->u.lvalue = fp + EXTRACT_UCHAR(pc++);
} else
if (sp->type == T_STRING) {
(++sp)->type = T_NUMBER;
sp->u.lvalue_byte = (unsigned char *)((sp-1)->u.string);
sp->subtype = SVALUE_STRLEN(sp - 1);
} else {
CHECK_TYPES(sp, T_ARRAY, 2, F_FOREACH);
(++sp)->type = T_NUMBER;
sp->u.lvalue = (sp-1)->u.arr->item;
sp->subtype = (sp-1)->u.arr->size;
}
(++sp)->type = T_LVALUE;
if (flags & 1)
sp->u.lvalue = find_value((int)(EXTRACT_UCHAR(pc++) + variable_index_offset));
else
sp->u.lvalue = fp + EXTRACT_UCHAR(pc++);
break;
}
case F_NEXT_FOREACH:
if ((sp-1)->type == T_LVALUE) {
/* mapping */
if ((sp-2)->subtype--) {
svalue_t *key = (sp-2)->u.lvalue++;
svalue_t *value = find_in_mapping((sp-4)->u.map, key);
assign_svalue((sp-1)->u.lvalue, key);
assign_svalue(sp->u.lvalue, value);
COPY_SHORT(&offset, pc);
pc -= offset;
break;
}
} else {
/* array or string */
if ((sp-1)->subtype--) {
if ((sp-2)->type == T_STRING) {
free_svalue(sp->u.lvalue, "foreach-string");
sp->u.lvalue->type = T_NUMBER;
sp->u.lvalue->u.number = *((sp-1)->u.lvalue_byte)++;
} else {
assign_svalue(sp->u.lvalue, (sp-1)->u.lvalue++);
}
COPY_SHORT(&offset, pc);
pc -= offset;
break;
}
}
pc += 2;
/* fallthrough */
case F_EXIT_FOREACH:
IF_DEBUG(foreach_in_progress--);
if ((sp-1)->type == T_LVALUE) {
/* mapping */
sp -= 3;
free_array((sp--)->u.arr);
free_mapping((sp--)->u.map);
} else {
/* array or string */
sp -= 2;
if (sp->type == T_STRING)
free_string_svalue(sp--);
else
free_array((sp--)->u.arr);
}
break;
case F_EXPAND_VARARGS:
{
svalue_t *s, *t;
array_t *arr;
i = EXTRACT_UCHAR(pc++);
s = sp - i;
if (s->type != T_ARRAY)
error("Item being expanded with ... is not an array\n");
arr = s->u.arr;
n = arr->size;
num_varargs += n - 1;
if (!n) {
t = s;
while (t < sp) {
*t = *(t + 1);
t++;
}
sp--;
} else if (n == 1) {
assign_svalue_no_free(s, &arr->item[0]);
} else {
t = sp;
sp += n - 1;
while (t > s) {
*(t + n - 1) = *t;
t--;
}
t = s + n - 1;
if (arr->ref == 1) {
memcpy(s, arr->item, n * sizeof(svalue_t));
free_empty_array(arr);
break;
} else {
while (n--)
assign_svalue_no_free(t--, &arr->item[n]);
}
}
free_array(arr);
break;
}
case F_NEW_CLASS:
{
array_t *cl;
cl = allocate_class(¤t_prog->classes[EXTRACT_UCHAR(pc++)]);
push_refed_class(cl);
}
break;
case F_AGGREGATE:
{
array_t *v;
LOAD_SHORT(offset, pc);
offset += num_varargs;
num_varargs = 0;
v = allocate_empty_array((int) offset);
/*
* transfer svalues in reverse...popping stack as we go
*/
while (offset--)
v->item[offset] = *sp--;
(++sp)->type = T_ARRAY;
sp->u.arr = v;
}
break;
case F_AGGREGATE_ASSOC:
{
mapping_t *m;
LOAD_SHORT(offset, pc);
offset += num_varargs;
num_varargs = 0;
m = load_mapping_from_aggregate(sp -= offset, offset);
(++sp)->type = T_MAPPING;
sp->u.map = m;
break;
}
case F_ASSIGN:
#ifdef DEBUG
if (sp->type != T_LVALUE) fatal("Bad argument to F_ASSIGN\n");
#endif
switch(sp->u.lvalue->type){
case T_LVALUE_BYTE:
if ((sp - 1)->type != T_NUMBER) {
error("Illegal rhs to char lvalue\n");
} else {
*global_lvalue_byte.u.lvalue_byte = ((sp - 1)->u.number & 0xff);
}
break;
default:
assign_svalue(sp->u.lvalue, sp - 1);
break;
case T_LVALUE_RANGE:
assign_lvalue_range(sp - 1);
break;
}
sp--; /* ignore lvalue */
/* rvalue is already in the correct place */
break;
case F_VOID_ASSIGN_LOCAL:
if (sp->type != T_INVALID) {
lval = fp + EXTRACT_UCHAR(pc++);
free_svalue(lval, "F_VOID_ASSIGN_LOCAL");
*lval = *sp--;
} else {
sp--;
pc++;
}
break;
case F_VOID_ASSIGN:
#ifdef DEBUG
if (sp->type != T_LVALUE) fatal("Bad argument to F_VOID_ASSIGN\n");
#endif
lval = (sp--)->u.lvalue;
if (sp->type != T_INVALID){
switch(lval->type){
case T_LVALUE_BYTE:
{
if (sp->type != T_NUMBER){
error("Illegal rhs to char lvalue\n");
} else {
*global_lvalue_byte.u.lvalue_byte = (sp--)->u.number & 0xff;
}
break;
}
case T_LVALUE_RANGE:
{
copy_lvalue_range(sp--);
break;
}
default:
{
free_svalue(lval, "F_VOID_ASSIGN : 3");
*lval = *sp--;
}
}
} else sp--;
break;
#ifdef DEBUG
case F_BREAK_POINT:
break_point();
break;
#endif
case F_CALL_FUNCTION_BY_ADDRESS:
{
function_t *funp;
LOAD_SHORT(offset, pc);
offset += function_index_offset;
/*
* Find the function in the function table. As the
* function may have been redefined by inheritance, we
* must look in the last table, which is pointed to by
* current_object.
*/
DEBUG_CHECK(offset >= current_object->prog->num_functions,
"Illegal function index\n");
funp = ¤t_object->prog->functions[offset];
if (funp->flags & NAME_UNDEFINED)
error("Undefined function: %s\n", funp->name);
/* Save all important global stack machine registers */
push_control_stack(FRAME_FUNCTION, funp);
caller_type = ORIGIN_LOCAL;
/* This assigment must be done after push_control_stack() */
current_prog = current_object->prog;
/*
* If it is an inherited function, search for the real
* definition.
*/
csp->num_local_variables = EXTRACT_UCHAR(pc++) + num_varargs;
num_varargs = 0;
function_index_offset = variable_index_offset = 0;
funp = setup_new_frame(funp);
csp->pc = pc; /* The corrected return address */
#ifdef LPC_TO_C
if (current_prog->program_size) {
#endif
pc = current_prog->program + funp->offset;
#ifdef LPC_TO_C
} else {
DEBUG_CHECK(!(funp->offset),
"Null function pointer in jump_table.\n");
(*
( void (*) PROT((void)) ) (funp->offset)
)();
}
#endif
}
break;
case F_CALL_INHERITED:
{
inherit_t *ip = current_prog->inherit + EXTRACT_UCHAR(pc++);
program_t *temp_prog = ip->prog;
function_t *funp;
LOAD_SHORT(offset, pc);
funp = &temp_prog->functions[offset];
push_control_stack(FRAME_FUNCTION, funp);
caller_type = ORIGIN_LOCAL;
current_prog = temp_prog;
csp->num_local_variables = EXTRACT_UCHAR(pc++) + num_varargs;
num_varargs = 0;
function_index_offset += ip->function_index_offset;
variable_index_offset += ip->variable_index_offset;
funp = setup_inherited_frame(funp);
csp->pc = pc;
#ifdef LPC_TO_C
if (current_prog->program_size) {
#endif
pc = current_prog->program + funp->offset;
#ifdef LPC_TO_C
} else {
DEBUG_CHECK(!(funp->offset),
"Null function pointer in jump_table.\n");
(*
( void (*) PROT((void)) ) (funp->offset)
)();
}
#endif
}
break;
case F_COMPL:
if (sp->type != T_NUMBER)
error("Bad argument to ~\n");
sp->u.number = ~sp->u.number;
break;
case F_CONST0:
push_number(0);
break;
case F_CONST1:
push_number(1);
break;
case F_PRE_DEC:
DEBUG_CHECK(sp->type != T_LVALUE,
"non-lvalue argument to --\n");
lval = sp->u.lvalue;
switch (lval->type) {
case T_NUMBER:
sp->type = T_NUMBER;
sp->u.number = --(lval->u.number);
break;
case T_REAL:
sp->type = T_REAL;
sp->u.real = --(lval->u.real);
break;
case T_LVALUE_BYTE:
sp->type = T_NUMBER;
sp->u.number = --(*global_lvalue_byte.u.lvalue_byte);
break;
default:
error("-- of non-numeric argument\n");
}
break;
case F_DEC:
DEBUG_CHECK(sp->type != T_LVALUE,
"non-lvalue argument to --\n");
lval = (sp--)->u.lvalue;
switch (lval->type) {
case T_NUMBER:
lval->u.number--;
break;
case T_REAL:
lval->u.real--;
break;
case T_LVALUE_BYTE:
--(*global_lvalue_byte.u.lvalue_byte);
break;
default:
error("-- of non-numeric argument\n");
}
break;
case F_DIVIDE:
{
switch((sp-1)->type|sp->type){
case T_NUMBER:
{
if (!(sp--)->u.number) error("Division by zero\n");
sp->u.number /= (sp+1)->u.number;
break;
}
case T_REAL:
{
if ((sp--)->u.real == 0.0) error("Division by zero\n");
sp->u.real /= (sp+1)->u.real;
break;
}
case T_NUMBER|T_REAL:
{
if ((sp--)->type == T_NUMBER){
if (!((sp+1)->u.number)) error("Division by zero\n");
sp->u.real /= (sp+1)->u.number;
} else {
if ((sp+1)->u.real == 0.0) error("Division by 0.0\n");
sp->type = T_REAL;
sp->u.real = sp->u.number / (sp+1)->u.real;
}
break;
}
default:
{
if (!((sp-1)->type & (T_NUMBER|T_REAL)))
bad_argument(sp-1,T_NUMBER|T_REAL,1, instruction);
if (!(sp->type & (T_NUMBER|T_REAL)))
bad_argument(sp, T_NUMBER|T_REAL,2, instruction);
}
}
}
break;
case F_DIV_EQ:
f_div_eq();
break;
case F_EQ:
f_eq();
break;
case F_GE:
f_ge();
break;
case F_GT:
f_gt();
break;
case F_GLOBAL:
{
svalue_t *s;
s = find_value((int) (EXTRACT_UCHAR(pc++) + variable_index_offset));
/*
* If variable points to a destructed object, replace it
* with 0, otherwise, fetch value of variable.
*/
if ((s->type == T_OBJECT) && (s->u.ob->flags & O_DESTRUCTED)) {
*++sp = const0;
assign_svalue(s, &const0);
} else {
assign_svalue_no_free(++sp, s);
}
break;
}
case F_PRE_INC:
DEBUG_CHECK(sp->type != T_LVALUE,
"non-lvalue argument to ++\n");
lval = sp->u.lvalue;
switch (lval->type) {
case T_NUMBER:
sp->type = T_NUMBER;
sp->u.number = ++lval->u.number;
break;
case T_REAL:
sp->type = T_REAL;
sp->u.real = ++lval->u.number;
break;
case T_LVALUE_BYTE:
sp->type = T_NUMBER;
sp->u.number = ++*global_lvalue_byte.u.lvalue_byte;
break;
default:
error("++ of non-numeric argument\n");
}
break;
case F_MEMBER:
{
array_t *arr;
if (sp->type != T_CLASS)
error("Tried to take a member of something that isn't a class.\n");
i = EXTRACT_UCHAR(pc++);
arr = sp->u.arr;
if (i >= arr->size) error("Class has no corresponding member.\n");
assign_svalue_no_free(sp, &arr->item[i]);
free_array(arr);
break;
}
case F_MEMBER_LVALUE:
{
array_t *arr;
if (sp->type != T_CLASS)
error("Tried to take a member of something that isn't a class.\n");
i = EXTRACT_UCHAR(pc++);
arr = sp->u.arr;
if (i >= arr->size) error("Class has no corresponding member.\n");
sp->type = T_LVALUE;
sp->u.lvalue = arr->item + i;
free_array(arr);
break;
}
case F_INDEX:
switch (sp->type) {
case T_MAPPING:
{
svalue_t *v;
mapping_t *m;
v = find_in_mapping(m = sp->u.map, sp - 1);
assign_svalue(--sp, v); /* v will always have a
* value */
free_mapping(m);
break;
}
case T_BUFFER:
{
if ((sp-1)->type != T_NUMBER)
error("Indexing a buffer with an illegal type.\n");
i = (sp - 1)->u.number;
if ((i > sp->u.buf->size) || (i < 0))
error("Buffer index out of bounds.\n");
i = sp->u.buf->item[i];
free_buffer(sp->u.buf);
(--sp)->u.number = i;
break;
}
case T_STRING:
{
if ((sp-1)->type != T_NUMBER) {
error("Indexing a string with an illegal type.\n");
}
i = (sp - 1)->u.number;
if ((i > SVALUE_STRLEN(sp)) || (i < 0))
error("String index out of bounds.\n");
i = (unsigned char) sp->u.string[i];
free_string_svalue(sp);
(--sp)->u.number = i;
break;
}
case T_ARRAY:
{
array_t *arr;
if ((sp-1)->type != T_NUMBER)
error("Indexing an array with an illegal type\n");
i = (sp - 1)->u.number;
if (i<0) error("Negative index passed to array.\n");
arr = sp->u.arr;
if (i >= arr->size) error("Array index out of bounds.\n");
assign_svalue_no_free(--sp, &arr->item[i]);
free_array(arr);
break;
}
default:
error("Indexing on illegal type.\n");
}
/*
* Fetch value of a variable. It is possible that it is a
* variable that points to a destructed object. In that case,
* it has to be replaced by 0.
*/
if (sp->type == T_OBJECT && (sp->u.ob->flags & O_DESTRUCTED)) {
free_object(sp->u.ob, "F_INDEX");
sp->type = T_NUMBER;
sp->u.number = 0;
}
break;
case F_RINDEX:
switch (sp->type) {
case T_BUFFER:
{
if ((sp-1)->type != T_NUMBER)
error("Indexing a buffer with an illegal type.\n");
i = sp->u.buf->size - (sp - 1)->u.number;
if ((i > sp->u.buf->size) || (i < 0))
error("Buffer index out of bounds.\n");
i = sp->u.buf->item[i];
free_buffer(sp->u.buf);
(--sp)->u.number = i;
break;
}
case T_STRING:
{
int len = SVALUE_STRLEN(sp);
if ((sp-1)->type != T_NUMBER) {
error("Indexing a string with an illegal type.\n");
}
i = len - (sp - 1)->u.number;
if ((i > len) || (i < 0))
error("String index out of bounds.\n");
i = (unsigned char) sp->u.string[i];
free_string_svalue(sp);
(--sp)->u.number = i;
break;
}
case T_ARRAY:
{
array_t *arr = sp->u.arr;
if ((sp-1)->type != T_NUMBER)
error("Indexing an array with an illegal type\n");
i = arr->size - (sp - 1)->u.number;
if (i < 0 || i >= arr->size) error("Array index out of bounds.\n");
assign_svalue_no_free(--sp, &arr->item[i]);
free_array(arr);
break;
}
default:
error("Indexing from the right on illegal type.\n");
}
/*
* Fetch value of a variable. It is possible that it is a
* variable that points to a destructed object. In that case,
* it has to be replaced by 0.
*/
if (sp->type == T_OBJECT && (sp->u.ob->flags & O_DESTRUCTED)) {
free_object(sp->u.ob, "F_RINDEX");
sp->type = T_NUMBER;
sp->u.number = 0;
}
break;
#ifdef F_JUMP_WHEN_ZERO
case F_JUMP_WHEN_ZERO:
if ((i = (sp->type == T_NUMBER)) && sp->u.number == 0) {
COPY_SHORT(&offset, pc);
pc = current_prog->program + offset;
} else {
pc += 2;
}
if (i) {
sp--; /* cheaper to do this when sp is an integer
* svalue */
} else {
pop_stack();
}
break;
#endif
#ifdef F_JUMP
case F_JUMP:
COPY_SHORT(&offset, pc);
pc = current_prog->program + offset;
break;
#endif
case F_LE:
f_le();
break;
case F_LSH:
f_lsh();
break;
case F_LSH_EQ:
f_lsh_eq();
break;
case F_MOD:
{
CHECK_TYPES(sp - 1, T_NUMBER, 1, instruction);
CHECK_TYPES(sp, T_NUMBER, 2, instruction);
if ((sp--)->u.number == 0)
error("Modulus by zero.\n");
sp->u.number %= (sp+1)->u.number;
}
break;
case F_MOD_EQ:
f_mod_eq();
break;
case F_MULTIPLY:
{
switch((sp-1)->type|sp->type){
case T_NUMBER:
{
sp--;
sp->u.number *= (sp+1)->u.number;
break;
}
case T_REAL:
{
sp--;
sp->u.real *= (sp+1)->u.real;
break;
}
case T_NUMBER|T_REAL:
{
if ((--sp)->type == T_NUMBER){
sp->type = T_REAL;
sp->u.real = sp->u.number * (sp+1)->u.real;
}
else sp->u.real *= (sp+1)->u.number;
break;
}
case T_MAPPING:
{
mapping_t *m;
m = compose_mapping((sp-1)->u.map, sp->u.map, 1);
pop_2_elems();
(++sp)->type = T_MAPPING;
sp->u.map = m;
break;
}
default:
{
if (!((sp-1)->type & (T_NUMBER|T_REAL|T_MAPPING)))
bad_argument(sp-1, T_NUMBER|T_REAL|T_MAPPING,1, instruction);
if (!(sp->type & (T_NUMBER|T_REAL|T_MAPPING)))
bad_argument(sp, T_NUMBER|T_REAL|T_MAPPING,2, instruction);
error("Args to * are not compatible.\n");
}
}
}
break;
case F_MULT_EQ:
f_mult_eq();
break;
case F_NE:
f_ne();
break;
case F_NEGATE:
if (sp->type == T_NUMBER)
sp->u.number = -sp->u.number;
else if (sp->type == T_REAL)
sp->u.real = -sp->u.real;
else
error("Bad argument to unary minus\n");
break;
case F_NOT:
if (sp->type == T_NUMBER)
sp->u.number = !sp->u.number;
else
assign_svalue(sp, &const0);
break;
case F_OR:
f_or();
break;
case F_OR_EQ:
f_or_eq();
break;
case F_PARSE_COMMAND:
f_parse_command();
break;
case F_POP_VALUE:
pop_stack();
break;
case F_POST_DEC:
DEBUG_CHECK(sp->type != T_LVALUE,
"non-lvalue argument to --\n");
lval = sp->u.lvalue;
switch(lval->type) {
case T_NUMBER:
sp->type = T_NUMBER;
sp->u.number = lval->u.number--;
break;
case T_REAL:
sp->type = T_REAL;
sp->u.real = lval->u.real--;
break;
case T_LVALUE_BYTE:
sp->type = T_NUMBER;
sp->u.number = (*global_lvalue_byte.u.lvalue_byte)--;
break;
default:
error("-- of non-numeric argument\n");
}
break;
case F_POST_INC:
DEBUG_CHECK(sp->type != T_LVALUE,
"non-lvalue argument to ++\n");
lval = sp->u.lvalue;
switch (lval->type) {
case T_NUMBER:
sp->type = T_NUMBER;
sp->u.number = lval->u.number++;
break;
case T_REAL:
sp->type = T_REAL;
sp->u.real = lval->u.real++;
break;
case T_LVALUE_BYTE:
sp->type = T_NUMBER;
sp->u.number = (*global_lvalue_byte.u.lvalue_byte)++;
break;
default:
error("++ of non-numeric argument\n");
}
break;
case F_GLOBAL_LVALUE:
(++sp)->type = T_LVALUE;
sp->u.lvalue = find_value((int) (EXTRACT_UCHAR(pc++) +
variable_index_offset));
break;
case F_INDEX_LVALUE:
push_indexed_lvalue(0);
break;
case F_RINDEX_LVALUE:
push_indexed_lvalue(1);
break;
case F_NN_RANGE_LVALUE:
push_lvalue_range(0x00);
break;
case F_RN_RANGE_LVALUE:
push_lvalue_range(0x10);
break;
case F_RR_RANGE_LVALUE:
push_lvalue_range(0x11);
break;
case F_NR_RANGE_LVALUE:
push_lvalue_range(0x01);
break;
case F_NN_RANGE:
f_range(0x00);
break;
case F_RN_RANGE:
f_range(0x10);
break;
case F_NR_RANGE:
f_range(0x01);
break;
case F_RR_RANGE:
f_range(0x11);
break;
case F_NE_RANGE:
f_extract_range(0);
break;
case F_RE_RANGE:
f_extract_range(1);
break;
case F_RETURN_ZERO:
{
/*
* Deallocate frame and return.
*/
pop_n_elems(csp->num_local_variables);
sp++;
DEBUG_CHECK(sp != fp, "Bad stack at F_RETURN\n");
*sp = const0;
pop_control_stack();
#ifdef TRACE
tracedepth--;
if (TRACEP(TRACE_RETURN)) {
do_trace("Return", "", "");
if (TRACEHB) {
if (TRACETST(TRACE_ARGS)) {
add_message(command_giver, " with value: 0");
}
add_message(command_giver, "\n");
}
}
#endif
/* The control stack was popped just before */
if (csp[1].framekind & FRAME_EXTERNAL)
return;
break;
}
break;
case F_RETURN:
{
svalue_t sv;
if (csp->num_local_variables) {
sv = *sp--;
/*
* Deallocate frame and return.
*/
pop_n_elems(csp->num_local_variables);
sp++;
DEBUG_CHECK(sp != fp, "Bad stack at F_RETURN\n");
*sp = sv; /* This way, the same ref counts are
* maintained */
}
pop_control_stack();
#ifdef TRACE
tracedepth--;
if (TRACEP(TRACE_RETURN)) {
do_trace("Return", "", "");
if (TRACEHB) {
if (TRACETST(TRACE_ARGS)) {
add_message(command_giver, " with value: ");
print_svalue(sp);
}
add_message(command_giver, "\n");
}
}
#endif
/* The control stack was popped just before */
if (csp[1].framekind & FRAME_EXTERNAL)
return;
break;
}
case F_RSH:
f_rsh();
break;
case F_RSH_EQ:
f_rsh_eq();
break;
case F_SSCANF:
f_sscanf();
break;
case F_STRING:
LOAD_SHORT(offset, pc);
DEBUG_CHECK1(offset >= current_prog->num_strings,
"string %d out of range in F_STRING!\n",
offset);
(++sp)->type = T_STRING;
sp->subtype = STRING_SHARED;
sp->u.string = ref_string(current_prog->strings[offset]);
break;
case F_SHORT_STRING:
DEBUG_CHECK1(EXTRACT_UCHAR(pc) >= current_prog->num_strings,
"string %d out of range in F_STRING!\n",
EXTRACT_UCHAR(pc));
(++sp)->type = T_STRING;
sp->subtype = STRING_SHARED;
sp->u.string = ref_string(current_prog->strings[EXTRACT_UCHAR(pc++)]);
break;
case F_SUBTRACT:
{
i = (sp--)->type;
switch (i | sp->type) {
case T_NUMBER:
sp->u.number -= (sp+1)->u.number;
break;
case T_REAL:
sp->u.real -= (sp+1)->u.real;
break;
case T_NUMBER | T_REAL:
if (sp->type == T_REAL) sp->u.real -= (sp+1)->u.number;
else {
sp->type = T_REAL;
sp->u.real = sp->u.number - (sp+1)->u.real;
}
break;
case T_ARRAY:
{
/*
* subtract_array already takes care of
* destructed objects
*/
sp->u.arr = subtract_array(sp->u.arr, (sp+1)->u.arr);
break;
}
default:
if (!((sp++)->type & (T_NUMBER|T_REAL|T_ARRAY)))
error("Bad left type to -.\n");
else if (!(sp->type & (T_NUMBER|T_REAL|T_ARRAY)))
error("Bad right type to -.\n");
else error("Arguments to - do not have compatible types.\n");
}
break;
}
case F_SUB_EQ:
f_sub_eq();
break;
case F_SIMUL_EFUN:
{
unsigned short index;
int num_args;
LOAD_SHORT(index, pc);
num_args = EXTRACT_UCHAR(pc++) + num_varargs;
num_varargs = 0;
call_simul_efun(index, num_args);
}
break;
case F_SWITCH:
f_switch();
break;
case F_XOR:
f_xor();
break;
case F_XOR_EQ:
f_xor_eq();
break;
case F_CATCH:
{
/*
* Compute address of next instruction after the CATCH
* statement.
*/
((char *) &offset)[0] = pc[0];
((char *) &offset)[1] = pc[1];
offset = pc + offset - current_prog->program;
pc += 2;
do_catch(pc, offset);
pc = current_prog->program + offset;
break;
}
case F_END_CATCH:
{
free_svalue(&catch_value, "F_END_CATCH");
catch_value = const0;
/* We come here when no longjmp() was executed */
pop_control_stack();
push_number(0);
return; /* return to do_catch */
}
case F_TIME_EXPRESSION:
{
long sec, usec;
get_usec_clock(&sec, &usec);
push_number(sec);
push_number(usec);
break;
}
case F_END_TIME_EXPRESSION:
{
long sec, usec;
get_usec_clock(&sec, &usec);
usec = (sec - (sp - 1)->u.number) * 1000000 + (usec - sp->u.number);
sp -= 2;
push_number(usec);
break;
}
#define Instruction (instruction + ONEARG_MAX)
#ifdef DEBUG
#define CALL_THE_EFUN goto call_the_efun
#else
#define CALL_THE_EFUN (*oefun_table[instruction])(); continue
#endif
case F_EFUN0:
st_num_arg = 0;
instruction = EXTRACT_UCHAR(pc++);
CALL_THE_EFUN;
case F_EFUN1:
st_num_arg = 1;
instruction = EXTRACT_UCHAR(pc++);
CHECK_TYPES(sp, instrs2[instruction].type[0], 1, Instruction);
CALL_THE_EFUN;
case F_EFUN2:
st_num_arg = 2;
instruction = EXTRACT_UCHAR(pc++);
CHECK_TYPES(sp - 1, instrs2[instruction].type[0], 1, Instruction);
CHECK_TYPES(sp, instrs2[instruction].type[1], 2, Instruction);
CALL_THE_EFUN;
case F_EFUN3:
st_num_arg = 3;
instruction = EXTRACT_UCHAR(pc++);
CHECK_TYPES(sp - 2, instrs2[instruction].type[0], 1, Instruction);
CHECK_TYPES(sp - 1, instrs2[instruction].type[1], 2, Instruction);
CHECK_TYPES(sp, instrs2[instruction].type[2], 3, Instruction);
CALL_THE_EFUN;
case F_EFUNV:
{
int i, num;
st_num_arg = EXTRACT_UCHAR(pc++) + num_varargs;
num_varargs = 0;
instruction = EXTRACT_UCHAR(pc++);
num = instrs2[instruction].min_arg;
for (i = 1; i <= num; i++) {
CHECK_TYPES(sp - st_num_arg + i, instrs2[instruction].type[i-1], i, Instruction);
}
CALL_THE_EFUN;
}
default:
/* optimized 1 arg efun */
st_num_arg = 1;
CHECK_TYPES(sp, instrs[instruction].type[0], 1, instruction);
#ifndef DEBUG
(*ooefun_table[instruction])();
continue;
#else
instruction -= ONEARG_MAX;
call_the_efun:
/* We have an efun. Execute it
*/
if (Instruction > NUM_OPCODES) {
fatal("Undefined instruction %s (%d)\n",
get_f_name(Instruction), Instruction);
}
if (Instruction < BASE) {
fatal("No case for eoperator %s (%d)\n",
get_f_name(Instruction), Instruction);
}
if (instrs2[instruction].ret_type == TYPE_NOVALUE)
expected_stack = sp - st_num_arg;
else
expected_stack = sp - st_num_arg + 1;
num_arg = st_num_arg;
(*oefun_table[instruction]) ();
if (expected_stack != sp)
fatal("Bad stack after evaluation. Instruction %d, num arg %d\n",
instruction, num_arg);
#endif
} /* switch (instruction) */
DEBUG_CHECK1(sp < fp + csp->num_local_variables - 1,
"Bad stack after evaluation. Instruction %d\n",
instruction);
} /* while (1) */
}
static void
do_catch P2(char *, pc, unsigned short, new_pc_offset)
{
error_context_t econ;
/*
* Save some global variables that must be restored separately after a
* longjmp. The stack will have to be manually popped all the way.
*/
save_context(&econ);
push_control_stack(FRAME_CATCH, 0);
#if defined(DEBUG) || defined(TRACE_CODE)
csp->num_local_variables = (csp - 1)->num_local_variables; /* marion */
#endif
if (SETJMP(econ.context)) {
/*
* They did a throw() or error. That means that the control stack
* must be restored manually here.
*/
restore_context(&econ);
sp++;
*sp = catch_value;
catch_value = const1;
/* if it's too deep or max eval, we can't let them catch it */
if (max_eval_error) {
pop_context(&econ);
error("Can't catch eval cost too big error.\n");
}
if (too_deep_error) {
pop_context(&econ);
error("Can't catch too deep recursion error.\n");
}
} else {
assign_svalue(&catch_value, &const1);
/* note, this will work, since csp->extern_call won't be used */
eval_instruction(pc);
}
pop_context(&econ);
}
/*
* Apply a fun 'fun' to the program in object 'ob', with
* 'num_arg' arguments (already pushed on the stack).
* If the function is not found, search in the object pointed to by the
* inherit pointer.
* If the function name starts with '::', search in the object pointed out
* through the inherit pointer by the current object. The 'current_object'
* stores the base object, not the object that has the current function being
* evaluated. Thus, the variable current_prog will normally be the same as
* current_object->prog, but not when executing inherited code. Then,
* it will point to the code of the inherited object. As more than one
* object can be inherited, the call of function by index number has to
* be adjusted. The function number 0 in a superclass object must not remain
* number 0 when it is inherited from a subclass object. The same problem
* exists for variables. The global variables function_index_offset and
* variable_index_offset keep track of how much to adjust the index when
* executing code in the superclass objects.
*
* There is a special case when called from the heart beat, as
* current_prog will be 0. When it is 0, set current_prog
* to the 'ob->prog' sent as argument.
*
* Arguments are always removed from the stack.
* If the function is not found, return 0 and nothing on the stack.
* Otherwise, return 1, and a pushed return value on the stack.
*
* Note that the object 'ob' can be destructed. This must be handled by
* the caller of apply().
*
* If the function failed to be called, then arguments must be deallocated
* manually ! (Look towards end of this function.)
*/
#ifdef DEBUG
static char debug_apply_fun[30];/* For debugging */
#endif
#ifdef CACHE_STATS
unsigned int apply_low_call_others = 0;
unsigned int apply_low_cache_hits = 0;
unsigned int apply_low_slots_used = 0;
unsigned int apply_low_collisions = 0;
#endif
typedef struct cache_entry_s {
int id;
char *name;
function_t *pr;
function_t *pr_inherited;
program_t *progp;
program_t *oprogp;
int function_index_offset;
int variable_index_offset;
} cache_entry_t;
static cache_entry_t cache[APPLY_CACHE_SIZE];
#ifdef DEBUGMALLOC_EXTENSIONS
void mark_apply_low_cache() {
int i;
for (i = 0; i < APPLY_CACHE_SIZE; i++) {
if (cache[i].id && !cache[i].progp)
EXTRA_REF(BLOCK(cache[i].name))++;
}
}
#endif
int apply_low P3(char *, fun, object_t *, ob, int, num_arg)
{
/*
* static memory is initialized to zero by the system or so Jacques says
* :)
*/
cache_entry_t *entry;
function_t *pr;
program_t *progp;
int ix;
static int cache_mask = APPLY_CACHE_SIZE - 1;
char *funname;
int local_call_origin = call_origin;
IF_DEBUG(control_stack_t *save_csp);
if (!local_call_origin)
local_call_origin = ORIGIN_DRIVER;
call_origin = 0;
ob->time_of_ref = current_time; /* Used by the swapper */
/*
* This object will now be used, and is thus a target for reset later on
* (when time due).
*/
#ifdef LAZY_RESETS
try_reset(ob);
if ((ob->flags & O_DESTRUCTED) && (num_error <= 0)) {
pop_n_elems(num_arg);
return 0;
}
#endif
ob->flags &= ~O_RESET_STATE;
#ifdef DEBUG
strncpy(debug_apply_fun, fun, sizeof(debug_apply_fun));
debug_apply_fun[sizeof debug_apply_fun - 1] = '\0';
#endif
if (num_error <= 0) { /* !failure */
/*
* If there is a chain of objects shadowing, start with the first of
* these.
*/
#ifndef NO_SHADOWS
while (ob->shadowed && ob->shadowed != current_object)
ob = ob->shadowed;
retry_for_shadow:
#endif
if (ob->flags & O_SWAPPED)
load_ob_from_swap(ob);
progp = ob->prog;
DEBUG_CHECK(ob->flags & O_DESTRUCTED,"apply() on destructed object\n");
#ifdef CACHE_STATS
apply_low_call_others++;
#endif
ix = (progp->id_number ^ (POINTER_INT) fun ^
((POINTER_INT) fun >> APPLY_CACHE_BITS)) & cache_mask;
entry = &cache[ix];
if ((entry->id == progp->id_number)
&& (!entry->progp || (entry->oprogp == ob->prog))
&& !strcmp(entry->name, fun)) {
/*
* We have found a matching entry in the cache. The pointer to
* the function name has to match, not only the contents. This is
* because hashing the string in order to get a cache index would
* be much more costly than hashing it's pointer. If cache access
* would be costly, the cache would be useless.
*/
#ifdef CACHE_STATS
apply_low_cache_hits++;
#endif
if (entry->progp
&& (!(entry->pr->type & (TYPE_MOD_STATIC | TYPE_MOD_PRIVATE))
|| current_object == ob || (local_call_origin & (ORIGIN_DRIVER | ORIGIN_CALL_OUT)))) {
/*
* the cache will tell us in which program the function is,
* and where
*/
push_control_stack(FRAME_FUNCTION | FRAME_OB_CHANGE, entry->pr);
caller_type = local_call_origin;
csp->num_local_variables = num_arg;
current_prog = entry->progp;
pr = entry->pr_inherited;
function_index_offset = entry->function_index_offset;
variable_index_offset = entry->variable_index_offset;
if (pr->flags & NAME_TRUE_VARARGS)
setup_varargs_variables(csp->num_local_variables,
pr->num_local, pr->num_arg);
else
setup_variables(csp->num_local_variables,
pr->num_local, pr->num_arg);
#ifdef TRACE
tracedepth++;
if (TRACEP(TRACE_CALL)) {
do_trace_call(pr);
}
#endif
#ifdef OLD_PREVIOUS_OBJECT_BEHAVIOUR
/*
* Now, previous_object() is always set, even by
* call_other(this_object()). It should not break any
* compatibility.
*/
if (current_object != ob)
#endif
previous_ob = current_object;
current_object = ob;
IF_DEBUG(save_csp = csp);
call_program(current_prog, pr->offset);
DEBUG_CHECK(save_csp - 1 != csp,
"Bad csp after execution in apply_low.\n");
/*
* Arguments and local variables are now removed. One
* resulting value is always returned on the stack.
*/
return 1;
} /* when we come here, the cache has told us
* that the function isn't defined in the
* object */
} else {
/* we have to search the function */
if (!entry->progp && entry->id) {
/*
* The old cache entry was for an undefined function, so the
* name had to be allocated
*/
free_string(entry->name);
}
#ifdef CACHE_STATS
if (!entry->id) {
apply_low_slots_used++;
} else {
apply_low_collisions++;
}
#endif
/*
* All functions are shared strings. Searching the hash table
* will typically take less than three string compares. If the
* string isn't in the hash table then the object contains no
* function by that name. If the string is in the hash table then
* we can search for the string in the object by comparing
* pointers rather than using strcmp's (since shared strings are
* unique). The idea for this optimization comes from the
* lp-strcmpoptim file on alcazar.
*/
if ((funname = findstring(fun))) {
#ifdef OPTIMIZE_FUNCTION_TABLE_SEARCH
int i = lookup_function(progp->functions,
progp->tree_r, funname);
if (i == -1 ||
(progp->functions[i].flags & NAME_UNDEFINED)
|| ((progp->functions[i].type & (TYPE_MOD_STATIC | TYPE_MOD_PRIVATE))
&& current_object != ob && !(local_call_origin & (ORIGIN_DRIVER | ORIGIN_CALL_OUT)))) {
;
} else {
pr = (function_t *) & progp->functions[i];
#else
/* comparing pointers okay since both are shared strings */
for (pr = progp->functions;
pr < progp->functions + progp->num_functions;
pr++) {
if (pr->name == 0 ||
pr->name != funname)
continue;
if (pr->flags & NAME_UNDEFINED)
continue;
/* Static functions may not be called from outside. */
if ((pr->type & (TYPE_MOD_STATIC | TYPE_MOD_PRIVATE)) &&
current_object != ob && !(local_call_origin & (ORIGIN_DRIVER | ORIGIN_CALL_OUT))) {
continue;
}
#endif
push_control_stack(FRAME_FUNCTION | FRAME_OB_CHANGE, pr);
caller_type = local_call_origin;
/* The searched function is found */
entry->id = progp->id_number;
entry->pr = pr;
entry->name = pr->name;
csp->num_local_variables = num_arg;
current_prog = progp;
entry->oprogp = current_prog; /* before
* setup_new_frame */
pr = setup_new_frame(pr);
entry->pr_inherited = pr;
entry->progp = current_prog;
entry->variable_index_offset = variable_index_offset;
entry->function_index_offset = function_index_offset;
#ifdef OLD_PREVIOUS_OBJECT_BEHAVIOUR
if (current_object != ob)
#endif
previous_ob = current_object;
current_object = ob;
IF_DEBUG(save_csp = csp);
call_program(current_prog, pr->offset);
DEBUG_CHECK(save_csp - 1 != csp,
"Bad csp after execution in apply_low\n");
/*
* Arguments and local variables are now removed. One
* resulting value is always returned on the stack.
*/
return 1;
}
}
/* We have to mark a function not to be in the object */
entry->id = progp->id_number;
/* Beek - 99% of the time it's a shared string already */
entry->name = make_shared_string(fun);
entry->progp = (program_t *) 0;
}
#ifndef NO_SHADOWS
if (ob->shadowing) {
/*
* This is an object shadowing another. The function was not
* found, but can maybe be found in the object we are shadowing.
*/
ob = ob->shadowing;
goto retry_for_shadow;
}
#endif
} /* !failure */
/* Failure. Deallocate stack. */
pop_n_elems(num_arg);
return 0;
}
/*
* Arguments are supposed to be
* pushed (using push_string() etc) before the call. A pointer to a
* 'svalue_t' will be returned. It will be a null pointer if the called
* function was not found. Otherwise, it will be a pointer to a static
* area in apply(), which will be overwritten by the next call to apply.
* Reference counts will be updated for this value, to ensure that no pointers
* are deallocated.
*/
svalue_t *apply P4(char *, fun, object_t *, ob, int, num_arg,
int, where)
{
IF_DEBUG(svalue_t *expected_sp);
tracedepth = 0;
call_origin = where;
#ifdef TRACE
if (TRACEP(TRACE_APPLY)) {
do_trace("Apply", "", "\n");
}
#endif
IF_DEBUG(expected_sp = sp - num_arg);
if (apply_low(fun, ob, num_arg) == 0)
return 0;
free_svalue(&apply_ret_value, "sapply");
apply_ret_value = *sp--;
DEBUG_CHECK(expected_sp != sp,
"Corrupt stack pointer.\n");
return &apply_ret_value;
}
/* Reason for the following 1. save cache space 2. speed :) */
/* The following is to be called only from reset_object for */
/* otherwise extra checks are needed - Sym */
void call___INIT P1(object_t *, ob)
{
function_t *pr;
program_t *progp;
int num_functions;
IF_DEBUG(svalue_t *expected_sp);
IF_DEBUG(control_stack_t *save_csp);
tracedepth = 0;
#ifdef TRACE
if (TRACEP(TRACE_APPLY)) {
do_trace("Apply", "", "\n");
}
#endif
IF_DEBUG(expected_sp = sp);
/* No try_reset here for obvious reasons :) */
ob->flags &= ~O_RESET_STATE;
progp = ob->prog;
num_functions = progp->num_functions;
if (!num_functions) return;
/* ___INIT turns out to be always the last function */
pr = progp->functions + num_functions - 1;
if (*pr->name != APPLY___INIT_SPECIAL_CHAR) return;
push_control_stack(FRAME_FUNCTION | FRAME_OB_CHANGE, pr);
caller_type = ORIGIN_DRIVER;
csp->num_local_variables = 0;
current_prog = progp;
pr = setup_new_frame(pr);
#ifdef OLD_PREVIOUS_OBJECT_BEHAVIOUR
if (current_object != ob)
#endif
previous_ob = current_object;
current_object = ob;
IF_DEBUG(save_csp = csp);
call_program(current_prog, pr->offset);
DEBUG_CHECK(save_csp - 1 != csp,
"Bad csp after execution in apply_low\n");
sp--;
DEBUG_CHECK(expected_sp != sp,
"Corrupt stack pointer.\n");
}
/*
* this is a "safe" version of apply
* this allows you to have dangerous driver mudlib dependencies
* and not have to worry about causing serious bugs when errors occur in the
* applied function and the driver depends on being able to do something
* after the apply. (such as the ed exit function, and the net_dead function).
* note: this function uses setjmp() and thus is fairly expensive when
* compared to a normal apply(). Use sparingly.
*/
svalue_t *
safe_apply P4(char *, fun, object_t *, ob, int, num_arg, int, where)
{
svalue_t *ret;
error_context_t econ;
save_context(&econ);
if (!SETJMP(econ.context)) {
if (!(ob->flags & O_DESTRUCTED)) {
ret = apply(fun, ob, num_arg, where);
} else ret = NULL;
} else {
restore_context(&econ);
ret = NULL;
}
pop_context(&econ);
return ret;
}
/*
* Call a function in all objects in a array.
*/
array_t *call_all_other P3(array_t *, v, char *, func, int, numargs)
{
int size;
svalue_t *tmp, *vptr, *rptr;
array_t *ret;
object_t *ob;
int i;
tmp = sp;
(++sp)->type = T_ARRAY;
sp->u.arr = ret = allocate_array(size = v->size);
if (size && (sp + numargs >= end_of_stack)) {
too_deep_error = 1;
error("stack overflow\n");
}
for (vptr = v->item, rptr = ret->item; size--; vptr++, rptr++) {
if (vptr->type == T_OBJECT) {
ob = vptr->u.ob;
} else if (vptr->type == T_STRING) {
ob = find_object(vptr->u.string);
if (!ob || !object_visible(ob))
continue;
} else continue;
if (ob->flags & O_DESTRUCTED)
continue;
i = numargs;
while (i--) push_svalue(tmp - i);
call_origin = ORIGIN_CALL_OTHER;
if (apply_low(func, ob, numargs)) *rptr = *sp--;
}
sp--;
pop_n_elems(numargs);
return ret;
}
/*
* This function is similar to apply(), except that it will not
* call the function, only return object name if the function exists,
* or 0 otherwise.
*/
char *function_exists P2(char *, fun, object_t *, ob)
{
function_t *pr;
char *funname;
#ifdef OPTIMIZE_FUNCTION_TABLE_SEARCH
int i;
#endif
DEBUG_CHECK(ob->flags & O_DESTRUCTED,
"function_exists() on destructed object\n");
if (ob->flags & O_SWAPPED)
load_ob_from_swap(ob);
pr = ob->prog->functions;
/* all function names are in the shared string table */
if ((funname = findstring(fun))) {
#ifdef OPTIMIZE_FUNCTION_TABLE_SEARCH
i = lookup_function(ob->prog->functions,
ob->prog->tree_r, funname);
if (i != -1) {
program_t *progp;
pr = (function_t *) & ob->prog->functions[i];
if ((pr->flags & NAME_UNDEFINED) ||
((pr->type & TYPE_MOD_STATIC) && current_object != ob))
return 0;
#else
for (; pr < ob->prog->functions + ob->prog->num_functions; pr++) {
program_t *progp;
/* okay to compare pointers since both are shared strings */
if (funname != pr->name)
continue;
/* Static functions may not be called from outside. */
if ((pr->type & TYPE_MOD_STATIC) && current_object != ob)
continue;
if (pr->flags & NAME_UNDEFINED)
return 0;
#endif
for (progp = ob->prog; pr->flags & NAME_INHERITED;) {
progp = progp->inherit[pr->offset].prog;
pr = &progp->functions[pr->function_index_offset];
}
return progp->name;
}
}
return 0;
}
#ifndef NO_SHADOWS
/*
is_static: returns 1 if a function named 'fun' is declared 'static' in 'ob';
0 otherwise.
*/
int is_static P2(char *, fun, object_t *, ob)
{
char *funname;
DEBUG_CHECK(ob->flags & O_DESTRUCTED,
"is_static() on destructed object\n");
if (ob->flags & O_SWAPPED)
load_ob_from_swap(ob);
/* all function names are in the shared string table */
if ((funname = findstring(fun))) {
function_t *pr;
#ifdef OPTIMIZE_FUNCTION_TABLE_SEARCH
int i;
i = lookup_function(ob->prog->functions,
ob->prog->tree_r, funname);
if (i != -1) {
pr = (function_t *) & ob->prog->functions[i];
#else
function_t *limit;
limit = ob->prog->functions + ob->prog->num_functions;
for (pr = ob->prog->functions; pr < limit; pr++) {
/* okay to compare pointers since both are shared strings */
if (funname != pr->name)
continue;
#endif
if (pr->flags & NAME_UNDEFINED)
return 0;
if (pr->type & TYPE_MOD_STATIC)
return 1;
}
}
return 0;
}
#endif
/*
* Call a specific function address in an object. This is done with no
* frame set up. It is expected that there are no arguments. Returned
* values are removed.
*/
void call_function P2(program_t *, progp, function_t *, pr)
{
if (pr->flags & NAME_UNDEFINED)
return;
push_control_stack(FRAME_FUNCTION | FRAME_OB_CHANGE, pr);
caller_type = ORIGIN_DRIVER;
DEBUG_CHECK(csp != control_stack,
"call_function with bad csp\n");
csp->num_local_variables = 0;
current_prog = progp;
pr = setup_new_frame(pr);
previous_ob = current_object;
tracedepth = 0;
call_program(current_prog, pr->offset);
pop_stack();
}
void translate_absolute_line P4(int, abs_line, unsigned short *, file_info,
int *, ret_file, int *, ret_line) {
unsigned short *p1, *p2;
int file;
int line_tmp = abs_line;
/* two passes: first, find out what file we're interested in */
p1 = file_info;
while (line_tmp > *p1) {
line_tmp -= *p1;
p1 += 2;
}
file = p1[1];
/* now correct the line number for that file */
p2 = file_info;
while (p2 < p1) {
if (p2[1] == file)
line_tmp += *p2;
p2 += 2;
}
*ret_line = line_tmp;
*ret_file = file;
}
int find_line P4(char *, p, program_t *, progp,
char **, ret_file, int *, ret_line )
{
int offset;
unsigned char *lns;
short abs_line;
int file_idx;
*ret_file = "";
*ret_line = 0;
if (!progp) return 1;
if (progp == &fake_prog) return 2;
#if defined(LPC_TO_C)
/* currently no line number info for compiled programs */
if (progp->program_size == 0)
return 3;
#endif
/*
* Load line numbers from swap if necessary. Leave them in memory until
* look_for_objects_to_swap() swaps them back out, since more errors are
* likely.
*/
if (!progp->line_info) {
load_line_numbers(progp);
if (!progp->line_info)
return 4;
}
offset = p - progp->program;
DEBUG_CHECK2(offset > (int) progp->program_size,
"Illegal offset %d in object /%s\n", offset, progp->name);
lns = progp->line_info;
while (offset > *lns) {
offset -= *lns;
lns += 3;
}
COPY_SHORT(&abs_line, lns + 1);
translate_absolute_line(abs_line, &progp->file_info[2],
&file_idx, ret_line);
*ret_file = progp->strings[file_idx - 1];
return 0;
}
void get_explicit_line_number_info P4(char *, p, program_t *, prog,
char **, ret_file, int *, ret_line) {
find_line(p, prog, ret_file, ret_line);
if (!(*ret_file))
*ret_file = prog->name;
}
void get_line_number_info P2(char **, ret_file, int *, ret_line)
{
find_line(pc, current_prog, ret_file, ret_line);
if (!(*ret_file))
*ret_file = current_prog->name;
}
char* get_line_number P2(char *, p, program_t *, progp)
{
static char buf[256];
int i;
char *file;
int line;
i = find_line(p, progp, &file, &line);
switch (i) {
case 1:
strcpy(buf, "(no program)");
return buf;
case 2:
*buf = 0;
return buf;
case 3:
strcpy(buf, "(compiled program)");
return buf;
case 4:
strcpy(buf, "(no line numbers)");
return buf;
case 5:
strcpy(buf, "(includes too deep)");
return buf;
}
if (!file)
file = progp->name;
sprintf(buf, "/%s:%d", file, line);
return buf;
}
/*
* Write out a trace. If there is a heart_beat(), then return the
* object that had that heart beat.
*/
char *dump_trace P1(int, how)
{
control_stack_t *p;
char *ret = 0;
function_t *funp;
#if defined(ARGUMENTS_IN_TRACEBACK) || defined(LOCALS_IN_TRACEBACK)
svalue_t *ptr;
int i;
#endif
if (current_prog == 0)
return 0;
if (csp < &control_stack[0]) {
return 0;
}
#ifdef TRACE_CODE
if (how)
(void) last_instructions();
#endif
for (p = &control_stack[0]; p < csp; p++) {
switch (p[0].framekind & FRAME_MASK) {
case FRAME_FUNCTION:
debug_message("'%15s' in '%20s' ('%20s') %s\n",
p[0].fr.func->name, p[1].prog->name, p[1].ob->name,
get_line_number(p[1].pc, p[1].prog));
if (strcmp(p[0].fr.func->name, "heart_beat") == 0)
ret = p->ob ? p->ob->name : 0;
funp = p[0].fr.func;
break;
case FRAME_FUNP:
debug_message("' <function>' in '%20s' ('%20s') %s\n",
p[1].prog->name, p[1].ob->name,
get_line_number(p[1].pc, p[1].prog));
funp = (function_t *)&p[0].fr.funp->f.functional;
break;
case FRAME_FAKE:
debug_message("' <function>' in '%20s' ('%20s') %s\n",
p[1].prog->name, p[1].ob->name,
get_line_number(p[1].pc, p[1].prog));
funp = 0;
break;
case FRAME_CATCH:
debug_message("' CATCH' in '%20s' ('%20s') %s\n",
p[1].prog->name, p[1].ob->name,
get_line_number(p[1].pc, p[1].prog));
funp = 0;
break;
#ifdef DEBUG
default:
fatal("unknown type of frame\n");
funp = 0;
#endif
}
#ifdef ARGUMENTS_IN_TRACEBACK
if (funp) {
ptr = p[1].fp;
debug_message("arguments were (");
for (i = 0; i < funp->num_arg; i++) {
outbuffer_t outbuf;
if (i) {
debug_message(",");
}
outbuf_zero(&outbuf);
svalue_to_string(&ptr[i], &outbuf, 0, 0, 0);
/* don't need to fix length here */
debug_message("%s", outbuf.buffer);
FREE_MSTR(outbuf.buffer);
}
debug_message(")\n");
}
#endif
#ifdef LOCALS_IN_TRACEBACK
if (funp && funp->num_local) {
ptr = p[1].fp + funp->num_arg;
debug_message("locals were: ");
for (i = 0; i < funp->num_local; i++) {
outbuffer_t outbuf;
if (i) {
debug_message(",");
}
outbuf_zero(&outbuf);
svalue_to_string(&ptr[i], &outbuf, 0, 0, 0);
/* no need to fix length */
debug_message("%s", outbuf.buffer);
FREE_MSTR(outbuf.buffer);
}
debug_message("\n");
}
#endif
}
switch (p[0].framekind & FRAME_MASK) {
case FRAME_FUNCTION:
debug_message("'%15s' in '%20s' ('%20s') %s\n",
p[0].fr.func->name,
current_prog->name, current_object->name,
get_line_number(pc, current_prog));
funp = p[0].fr.func;
break;
case FRAME_FUNP:
debug_message("' <function>' in '%20s' ('%20s') %s\n",
current_prog->name, current_object->name,
get_line_number(pc, current_prog));
funp = (function_t *)&p[0].fr.funp->f.functional;
break;
case FRAME_FAKE:
debug_message("' <function>' in '%20s' ('%20s') %s\n",
current_prog->name, current_object->name,
get_line_number(pc, current_prog));
funp = 0;
break;
case FRAME_CATCH:
debug_message("' CATCH' in '%20s' ('%20s') %s\n",
current_prog->name, current_object->name,
get_line_number(pc, current_prog));
funp = 0;
break;
}
#ifdef ARGUMENTS_IN_TRACEBACK
if (funp) {
debug_message("arguments were (");
for (i = 0; i < funp->num_arg; i++) {
outbuffer_t outbuf;
if (i) {
debug_message(",");
}
outbuf_zero(&outbuf);
svalue_to_string(&fp[i], &outbuf, 0, 0, 0);
/* no need to fix length */
debug_message("%s", outbuf.buffer);
FREE_MSTR(outbuf.buffer);
}
debug_message(")\n");
}
#endif
#ifdef LOCALS_IN_TRACEBACK
if (funp && funp->num_local) {
ptr = fp + funp->num_arg;
debug_message("locals were: ");
for (i = 0; i < funp->num_local; i++) {
outbuffer_t outbuf;
if (i) {
debug_message(",");
}
outbuf_zero(&outbuf);
svalue_to_string(&ptr[i], &outbuf, 0, 0, 0);
/* no need to fix length */
debug_message("%s", outbuf.buffer);
FREE_MSTR(outbuf.buffer);
}
debug_message("\n");
}
#endif
return ret;
}
array_t *get_svalue_trace()
{
control_stack_t *p;
array_t *v;
mapping_t *m;
char *file;
int line;
function_t *funp;
#if defined(ARGUMENTS_IN_TRACEBACK) || defined(LOCALS_IN_TRACEBACK)
svalue_t *ptr;
int i, n;
#ifdef LOCALS_IN_TRACEBACK
int n2;
#endif
#endif
if (current_prog == 0)
return null_array();
if (csp < &control_stack[0]) {
return null_array();
}
v = allocate_empty_array((csp - &control_stack[0]) + 1);
for (p = &control_stack[0]; p < csp; p++) {
m = allocate_mapping(6);
switch (p[0].framekind & FRAME_MASK) {
case FRAME_FUNCTION:
add_mapping_string(m, "function", p[0].fr.func->name);
funp = p[0].fr.func;
break;
case FRAME_CATCH:
add_mapping_string(m, "function", "CATCH");
funp = 0;
break;
case FRAME_FAKE:
add_mapping_string(m, "function", "<function>");
funp = 0;
break;
case FRAME_FUNP:
add_mapping_string(m, "function", "<function>");
funp = (function_t *)&p[0].fr.funp->f.functional;
break;
#ifdef DEBUG
default:
fatal("unknown type of frame\n");
funp = 0;
#endif
}
add_mapping_string(m, "program", p[1].prog->name);
add_mapping_object(m, "object", p[1].ob);
get_explicit_line_number_info(p[1].pc, p[1].prog, &file, &line);
add_mapping_string(m, "file", file);
add_mapping_pair(m, "line", line);
#ifdef ARGUMENTS_IN_TRACEBACK
if (funp) {
array_t *v2;
n = funp->num_arg;
ptr = p[1].fp;
v2 = allocate_empty_array(n);
for (i = 0; i < n; i++) {
assign_svalue_no_free(&v2->item[i], &ptr[i]);
}
add_mapping_array(m, "arguments", v2);
v2->ref--;
}
#endif
#ifdef LOCALS_IN_TRACEBACK
if (funp) {
array_t *v2;
n = funp->num_arg;
n2 = funp->num_local;
ptr = p[1].fp;
v2 = allocate_empty_array(n2);
for (i = 0; i < n2; i++) {
assign_svalue_no_free(&v2->item[i], &ptr[i + n]);
}
add_mapping_array(m, "locals", v2);
v2->ref--;
}
#endif
v->item[(p - &control_stack[0])].type = T_MAPPING;
v->item[(p - &control_stack[0])].u.map = m;
}
m = allocate_mapping(6);
switch (p[0].framekind & FRAME_MASK) {
case FRAME_FUNCTION:
add_mapping_string(m, "function", p[0].fr.func->name);
funp = p[0].fr.func;
break;
case FRAME_CATCH:
add_mapping_string(m, "function", "CATCH");
funp = 0;
break;
case FRAME_FAKE:
add_mapping_string(m, "function", "<function>");
funp = 0;
break;
case FRAME_FUNP:
add_mapping_string(m, "function", "<function>");
funp = (function_t *)&p[0].fr.funp->f.functional;
break;
}
add_mapping_string(m, "program", current_prog->name);
add_mapping_object(m, "object", current_object);
get_line_number_info(&file, &line);
add_mapping_string(m, "file", file);
add_mapping_pair(m, "line", line);
#ifdef ARGUMENTS_IN_TRACEBACK
if (funp) {
array_t *v2;
n = funp->num_arg;
v2 = allocate_empty_array(n);
for (i = 0; i < n; i++) {
assign_svalue_no_free(&v2->item[i], &fp[i]);
}
add_mapping_array(m, "arguments", v2);
v2->ref--;
}
#endif
#ifdef LOCALS_IN_TRACEBACK
if (funp) {
array_t *v2;
n = funp->num_arg;
n2 = funp->num_local;
v2 = allocate_empty_array(n2);
for (i = 0; i < n2; i++) {
assign_svalue_no_free(&v2->item[i], &fp[i + n]);
}
add_mapping_array(m, "locals", v2);
v2->ref--;
}
#endif
v->item[(csp - &control_stack[0])].type = T_MAPPING;
v->item[(csp - &control_stack[0])].u.map = m;
/* return a reference zero array */
v->ref--;
return v;
}
char * get_line_number_if_any()
{
if (current_prog)
return get_line_number(pc, current_prog);
return 0;
}
#define SSCANF_ASSIGN_SVALUE_STRING(S) \
arg->type = T_STRING; \
arg->u.string = S; \
arg->subtype = STRING_MALLOC; \
arg--; \
num_arg--
#define SSCANF_ASSIGN_SVALUE_NUMBER(N) \
arg->type = T_NUMBER; \
arg->subtype = 0; \
arg->u.number = N; \
arg--; \
num_arg--
#define SSCANF_ASSIGN_SVALUE(T,U,V) \
arg->type = T; \
arg->U = V; \
arg--; \
num_arg--
/* arg points to the same place it used to */
int inter_sscanf P4(svalue_t *, arg, svalue_t *, s0, svalue_t *, s1, int, num_arg)
{
char *fmt; /* Format description */
char *in_string; /* The string to be parsed. */
int number_of_matches;
int skipme; /* Encountered a '*' ? */
int base = 10;
int num;
char *match, old_char;
register char *tmp;
/*
* First get the string to be parsed.
*/
CHECK_TYPES(s0, T_STRING, 1, F_SSCANF);
in_string = s0->u.string;
/*
* Now get the format description.
*/
CHECK_TYPES(s1, T_STRING, 2, F_SSCANF);
fmt = s1->u.string;
/*
* Loop for every % or substring in the format.
*/
for (number_of_matches = 0; num_arg >= 0; number_of_matches++) {
while (*fmt) {
if (*fmt == '%') {
if (*++fmt == '%') {
if (*in_string++ != '%') return number_of_matches;
fmt++;
continue;
}
break;
}
if (*fmt++ != *in_string++) return number_of_matches;
}
if (!*fmt) {
if (*s1->u.string && (fmt[-1] == '%'))
error("Format string cannot end in '%%' in sscanf()\n");
/*
* We have reached the end of the format string. If there are
* any chars left in the in_string, then we put them in the
* last variable (if any).
*/
if (*in_string && num_arg) {
number_of_matches++;
SSCANF_ASSIGN_SVALUE_STRING(string_copy(in_string, "sscanf"));
}
break;
}
DEBUG_CHECK(fmt[-1] != '%', "In sscanf, should be a %% now!\n");
if ((skipme = (*fmt == '*'))) fmt++;
else if (num_arg < 1) {
/*
* Hmm ... maybe we should return number_of_matches here instead
* of an error
*/
error("Too few arguments to sscanf()\n");
}
switch (*fmt++) {
case 'x':
base = 16;
/* fallthrough */
case 'd':
{
tmp = in_string;
num = (int) strtol(in_string, &in_string, base);
if (tmp == in_string) return number_of_matches;
if (!skipme) {
SSCANF_ASSIGN_SVALUE_NUMBER(num);
}
base = 10;
continue;
}
case 'f':
{
float tmp_num;
tmp = in_string;
tmp_num = _strtof(in_string, &in_string);
if (tmp == in_string)return number_of_matches;
if (!skipme) {
SSCANF_ASSIGN_SVALUE(T_REAL, u.real, tmp_num);
}
continue;
}
case '(':
{
struct regexp *reg;
tmp = fmt; /* 1 after the ( */
num = 1;
while (1) {
switch (*tmp) {
case '\\':
if (*++tmp) {
tmp++;
continue;
}
case '\0':
error("Bad regexp format: '%%%s' in sscanf format string\n", fmt);
case '(':
num++;
/* FALLTHROUGH */
default:
tmp++;
continue;
case ')':
if (!--num) break;
tmp++;
continue;
}
{
int n = tmp - fmt;
char *buf = (char *)DXALLOC(n + 1, TAG_TEMPORARY,
"sscanf regexp");
memcpy(buf, fmt, n);
buf[n] = 0;
regexp_user = EFUN_REGEXP;
reg = regcomp((unsigned char *)buf, 0);
FREE(buf);
if (!reg) error(regexp_error);
if (!regexec(reg, in_string) || (in_string != reg->startp[0]))
return number_of_matches;
if (!skipme) {
n = *reg->endp - in_string;
buf = new_string(n, "sscanf regexp return");
memcpy(buf, in_string, n);
buf[n] = 0;
SSCANF_ASSIGN_SVALUE_STRING(buf);
}
in_string = *reg->endp;
FREE((char *)reg);
fmt = ++tmp;
break;
}
}
continue;
}
case 's':
break;
default:
error("Bad type : '%%%c' in sscanf() format string\n", fmt[-1]);
}
/*
* Now we have the string case.
*/
/*
* First case: There were no extra characters to match. Then this is
* the last match.
*/
if (!*fmt) {
number_of_matches++;
if (!skipme) {
SSCANF_ASSIGN_SVALUE_STRING(string_copy(in_string, "sscanf"));
}
break;
}
/*
* If the next char in the format string is a '%' then we have to do
* some special checks. Only %d, %f, %x, %(regexp) and %% are allowed
* after a %s
*/
if (*fmt++ == '%') {
int skipme2;
tmp = in_string;
if ((skipme2 = (*fmt == '*'))) fmt++;
else if (num_arg < 2) error("Too few arguments to sscanf().\n");
number_of_matches++;
switch (*fmt++) {
case 's':
error("Illegal to have 2 adjacent %%s's in format string in sscanf()\n");
case 'x':
do {
while (*tmp && (*tmp != '0')) tmp++;
if (*tmp == '0') {
if ((tmp[1] == 'x' || tmp[1] == 'X') &&
isxdigit(tmp[2])) break;
tmp += 2;
}
} while (*tmp);
break;
case 'd':
while (*tmp && !isdigit(*tmp)) tmp++;
break;
case 'f':
while (*tmp && !isdigit(*tmp) &&
(*tmp != '.' || !isdigit(tmp[1]))) tmp++;
break;
case '%':
while (*tmp && (*tmp != '%')) tmp++;
break;
case '(':
{
struct regexp *reg;
tmp = fmt;
num = 1;
while (1) {
switch (*tmp) {
case '\\':
if (*++tmp) {
tmp++;
continue;
}
case '\0':
error("Bad regexp format : '%%%s' in sscanf format string\n", fmt);
case '(':
num++;
/* FALLTHROUGH */
default:
tmp++;
continue;
case ')':
if (!--num) break;
tmp++;
continue;
}
{
int n = tmp - fmt;
char *buf = (char *)DXALLOC(n + 1, TAG_TEMPORARY,
"sscanf regexp");
memcpy(buf, fmt, n);
buf[n] = 0;
regexp_user = EFUN_REGEXP;
reg = regcomp((unsigned char *)buf, 0);
FREE(buf);
if (!reg) error(regexp_error);
if (!regexec(reg, in_string)) {
if (!skipme) {
SSCANF_ASSIGN_SVALUE_STRING(string_copy(in_string, "sscanf"));
}
FREE((char *)reg);
return number_of_matches;
} else {
if (!skipme) {
match = new_string(num = (*reg->startp - in_string), "inter_sscanf");
memcpy(match, in_string, num);
match[num] = 0;
SSCANF_ASSIGN_SVALUE_STRING(match);
}
in_string = *reg->endp;
if (!skipme2) {
match = new_string(num = (*reg->endp - *reg->startp), "inter_sscanf");
memcpy(match, *reg->startp, num);
match[num] = 0;
SSCANF_ASSIGN_SVALUE_STRING(match);
}
FREE((char *)reg);
}
fmt = ++tmp;
break;
}
}
continue;
}
default:
error("Bad type : '%%%c' in sscanf() format string\n", fmt[-1]);
}
if (!skipme) {
match = new_string(num = (tmp - in_string), "inter_sscanf");
memcpy(match, in_string, num);
match[num] = 0;
SSCANF_ASSIGN_SVALUE_STRING(match);
}
if (!*(in_string = tmp)) return number_of_matches;
switch (fmt[-1]) {
case 'x':
base = 16;
case 'd':
{
num = (int) strtol(in_string, &in_string, base);
/* We already knew it would be matched - Sym */
if (!skipme2) {
SSCANF_ASSIGN_SVALUE_NUMBER(num);
}
base = 10;
continue;
}
case 'f':
{
float tmp_num = _strtof(in_string, &in_string);
if (!skipme2) {
SSCANF_ASSIGN_SVALUE(T_REAL, u.real, tmp_num);
}
continue;
}
case '%':
in_string++;
continue; /* on the big for loop */
}
}
if ((tmp = strchr(fmt, '%')) != NULL) num = tmp - fmt + 1;
else {
tmp = fmt + (num = strlen(fmt));
num++;
}
old_char = *--fmt;
match = in_string;
/* This loop would be even faster if it used replace_string's skiptable
algorithm. Maybe that algorithm should be lifted so it can be
used in strsrch as well has here, etc? */
while (*in_string) {
if ((*in_string == old_char) && !strncmp(in_string, fmt, num)) {
/*
* Found a match !
*/
if (!skipme) {
char *newmatch;
newmatch = new_string(skipme = (in_string - match), "inter_sscanf");
memcpy(newmatch, match, skipme);
newmatch[skipme] = 0;
SSCANF_ASSIGN_SVALUE_STRING(newmatch);
}
in_string += num;
fmt = tmp; /* advance fmt to next % */
break;
}
in_string++;
}
if (fmt == tmp) /* If match, then do continue. */
continue;
/*
* No match was found. Then we stop here, and return the result so
* far !
*/
break;
}
return number_of_matches;
}
/* dump # of times each efun has been used */
#ifdef OPCPROF
void opcdump P1(char *, tfn)
{
int i, len, limit;
char tbuf[SMALL_STRING_SIZE], *fn;
FILE *fp;
if ((len = strlen(tfn)) >= (SMALL_STRING_SIZE - 7)) {
error("Path '%s' too long.\n", tfn);
return;
}
strcpy(tbuf, tfn);
strcpy(tbuf + len, ".efun");
fn = check_valid_path(tbuf, current_object, "opcprof", 1);
if (!fn) {
error("Invalid path '%s' for writing.\n", tbuf);
return;
}
fp = fopen(fn, "w");
if (!fp) {
error("Unable to open %s.\n", fn);
return;
}
limit = sizeof(opc_efun) / sizeof(opc_t);
for (i = 0; i < limit; i++) {
fprintf(fp, "%-30s: %10d\n", opc_efun[i].name, opc_efun[i].count);
}
fclose(fp);
strcpy(tbuf, tfn);
strcpy(tbuf + len, ".eoper");
fn = check_valid_path(tbuf, current_object, "opcprof", 1);
if (!fn) {
error("Invalid path '%s' for writing.\n", tbuf);
return;
}
fp = fopen(fn, "w");
if (!fp) {
error("Unable to open %s for writing.\n", fn);
return;
}
for (i = 0; i < BASE; i++) {
fprintf(fp, "%-30s: %10d\n",
query_instr_name(i), opc_eoper[i]);
}
fclose(fp);
}
#endif
/* dump # of times each efun has been used */
#ifdef OPCPROF_2D
typedef struct {
int op1, op2;
int num_calls;
} sort_elem_t;
int sort_elem_cmp P2(sort_elem_t *, se1, sort_elem_t *, se2) {
return se2->num_calls - se1->num_calls;
}
void opcdump P1(char *, tfn)
{
int ind, i, j, len, limit;
char tbuf[SMALL_STRING_SIZE], *fn;
FILE *fp;
sort_elem_t ops[(BASE + 1) * (BASE + 1)];
if ((len = strlen(tfn)) >= (SMALL_STRING_SIZE - 10)) {
error("Path '%s' too long.\n", tfn);
return;
}
strcpy(tbuf, tfn);
strcpy(tbuf + len, ".eop-2d");
fn = check_valid_path(tbuf, current_object, "opcprof", 1);
if (!fn) {
error("Invalid path '%s' for writing.\n", tbuf);
return;
}
fp = fopen(fn, "w");
if (!fp) {
error("Unable to open %s for writing.\n", fn);
return;
}
for (i = 0; i <= BASE; i++) {
for (j = 0; j <= BASE; j++) {
ind = i * (BASE + 1) + j;
ops[ind].num_calls = opc_eoper_2d[i][j];
ops[ind].op1 = i;
ops[ind].op2 = j;
}
}
quickSort((char *) ops, (BASE + 1) * (BASE + 1), sizeof(sort_elem_t),
sort_elem_cmp);
for (i = 0; i < (BASE + 1) * (BASE + 1); i++) {
if (ops[i].num_calls)
fprintf(fp, "%-30s %-30s: %10d\n", query_instr_name(ops[i].op1),
query_instr_name(ops[i].op2), ops[i].num_calls);
}
fclose(fp);
}
#endif
/*
* Reset the virtual stack machine.
*/
void reset_machine P1(int, first)
{
csp = control_stack - 1;
if (first)
sp = &start_of_stack[-1];
else {
pop_n_elems(sp - start_of_stack + 1);
IF_DEBUG(foreach_in_progress = 0);
}
}
#ifdef TRACE_CODE
static char *get_arg P2(int, a, int, b)
{
static char buff[10];
char *from, *to;
from = previous_pc[a];
to = previous_pc[b];
if (to - from < 2)
return "";
if (to - from == 2) {
sprintf(buff, "%d", from[1]);
return buff;
}
if (to - from == 3) {
short arg;
COPY_SHORT(&arg, from + 1);
sprintf(buff, "%d", (int)arg);
return buff;
}
if (to - from == 5) {
int arg;
COPY_INT(&arg, from + 1);
sprintf(buff, "%d", arg);
return buff;
}
return "";
}
int last_instructions()
{
int i;
i = last;
do {
if (previous_instruction[i] != 0)
debug_message("%6x: %3d %8s %-25s (%d)\n", previous_pc[i],
previous_instruction[i],
get_arg(i, (i + 1) %
(sizeof previous_instruction / sizeof(int))),
get_f_name(previous_instruction[i]),
stack_size[i] + 1);
i = (i + 1) % (sizeof previous_instruction / sizeof(int));
} while (i != last);
return last;
}
#endif /* TRACE_CODE */
#ifdef TRACE
/* Generate a debug message to the user */
void do_trace P3(char *, msg, char *, fname, char *, post)
{
char *objname;
if (!TRACEHB)
return;
objname = TRACETST(TRACE_OBJNAME) ? (current_object && current_object->name ? current_object->name : "??") : "";
add_vmessage(command_giver, "*** %d %*s %s %s %s%s", tracedepth, tracedepth, "", msg, objname, fname, post);
}
#endif
/* If the master object can't be loaded, we return zero. (svalue_t *)-1
* means that we haven't gotten to loading the master object yet in main.c.
* In that case, the check should succeed.
*/
svalue_t *apply_master_ob P2(char *, fun, int, num_arg)
{
IF_DEBUG(svalue_t *expected_sp);
if (master_ob == (object_t *)-1) {
pop_n_elems(num_arg);
return (svalue_t *)-1;
}
call_origin = ORIGIN_DRIVER;
#ifdef TRACE
if (TRACEP(TRACE_APPLY)) {
do_trace("Apply", "", "\n");
}
#endif
IF_DEBUG(expected_sp = sp - num_arg);
if (apply_low(fun, master_ob, num_arg) == 0)
return 0;
free_svalue(&apply_ret_value, "sapply");
apply_ret_value = *sp--;
DEBUG_CHECK(expected_sp != sp,
"Corrupt stack pointer.\n");
return &apply_ret_value;
}
svalue_t *safe_apply_master_ob P2(char *, fun, int, num_arg)
{
if (master_ob == (object_t *)-1) {
pop_n_elems(num_arg);
return (svalue_t *)-1;
}
return safe_apply(fun, master_ob, num_arg, ORIGIN_DRIVER);
}
/*
* When an object is destructed, all references to it must be removed
* from the stack.
*/
void remove_object_from_stack P1(object_t *, ob)
{
svalue_t *svp;
for (svp = start_of_stack; svp <= sp; svp++) {
if (svp->type != T_OBJECT)
continue;
if (svp->u.ob != ob)
continue;
free_object(svp->u.ob, "remove_object_from_stack");
svp->type = T_NUMBER;
svp->u.number = 0;
}
}
int strpref P2(char *, p, char *, s)
{
while (*p)
if (*p++ != *s++)
return 0;
return 1;
}
static float _strtof P2(char *, nptr, char **, endptr)
{
register char *s = nptr;
register float acc;
register int neg, c, any, div;
div = 1;
neg = 0;
/*
* Skip white space and pick up leading +/- sign if any.
*/
do {
c = *s++;
} while (isspace(c));
if (c == '-') {
neg = 1;
c = *s++;
} else if (c == '+')
c = *s++;
for (acc = 0, any = 0;; c = *s++) {
if (isdigit(c))
c -= '0';
else if ((div == 1) && (c == '.')) {
div = 10;
continue;
} else
break;
if (div == 1) {
acc *= (float) 10;
acc += (float) c;
} else {
acc += (float) c / (float) div;
div *= 10;
}
any = 1;
}
if (neg)
acc = -acc;
if (endptr != 0)
*endptr = any ? s - 1 : (char *) nptr;
return acc;
}
#ifdef DEBUGMALLOC_EXTENSIONS
void mark_stack() {
svalue_t *sv;
for (sv = start_of_stack; sv <= sp; sv++) mark_svalue(sv);
}
#endif
/* Be careful. This assumes there will be a frame pushed right after this,
as we use econ->save_csp + 1 to restore */
void save_context P1(error_context_t *, econ) {
econ->save_command_giver = command_giver;
econ->save_sp = sp;
econ->save_csp = csp;
econ->save_context = current_error_context;
current_error_context = econ;
}
void pop_context P1(error_context_t *, econ) {
current_error_context = econ->save_context;
}
/* can the error handler do this ? */
void restore_context P1(error_context_t *, econ) {
command_giver = econ->save_command_giver;
csp = econ->save_csp + 1;
pop_control_stack();
pop_n_elems(sp - econ->save_sp);
}
