cfuns.c

#include "std.h"

#ifdef LPC_TO_C
#include "cfuns.h"
#include "backend.h"
#include "lpc_to_c.h"
#include "eoperators.h"
#include "parse.h"
#include "qsort.h"

IF_DEBUG(extern int stack_in_use_as_temporary);

/* temporaries for LPC->C code */
int lpc_int;
svalue_t *lpc_svp;
array_t *lpc_arr;
mapping_t *lpc_map;

static svalue_t *lval;

void c_new_class(int  which, int  has_values) {
    array_t *cl;
    
    cl = allocate_class(&current_prog->classes[which], has_values);
    push_refed_class(cl);
}

void c_member(int  idx) {
    array_t *arr;

    if (sp->type != T_CLASS)
        error("Tried to take a member of something that isn't a class.\n");
    arr = sp->u.arr;
    if (idx >= arr->size) error("Class has no corresponding member.\n");
    assign_svalue_no_free(sp, &arr->item[idx]);
    free_class(arr);
}

void c_member_lvalue(int  idx) {
    array_t *arr;

    if (sp->type != T_CLASS)
        error("Tried to take a member of something that isn't a class.\n");
    arr = sp->u.arr;
    if (idx >= arr->size) error("Class has no corresponding member.\n");
    sp->type = T_LVALUE;
    sp->u.lvalue = arr->item + idx;
    free_class(arr);
}

void c_return() {
    svalue_t sv;

    sv = *sp--;
    pop_n_elems(csp->num_local_variables);
    sp++;
    DEBUG_CHECK(sp != fp, "Bad stack at c_return\n");
    *sp =sv;
    pop_control_stack();
}

void c_return_zero() {
    pop_n_elems(csp->num_local_variables);
    sp++;
    DEBUG_CHECK(sp != fp, "Bad stack at c_return\n");
    *sp = const0;
    pop_control_stack();
}

void c_foreach(int  flags, int  idx1, int  idx2) {
    IF_DEBUG(stack_in_use_as_temporary++);
    
    if (flags & FOREACH_MAPPING) {
	CHECK_TYPES(sp, T_MAPPING, 2, F_FOREACH);
	
	push_refed_array(mapping_indices(sp->u.map));

	STACK_INC;
	sp->type = T_NUMBER;
	sp->u.lvalue = (sp-1)->u.arr->item;
	sp->subtype = (sp-1)->u.arr->size;
		    
	STACK_INC;
	sp->type = T_LVALUE;
	if (flags & FOREACH_LEFT_GLOBAL) {
	    sp->u.lvalue = &current_object->variables[idx1 + variable_index_offset];
	} else {
	    sp->u.lvalue = fp + idx1;
	}
    } else 
    if (sp->type == T_STRING) {
	STACK_INC;
	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);

	STACK_INC;
	sp->type = T_NUMBER;
	sp->u.lvalue = (sp-1)->u.arr->item;
	sp->subtype = (sp-1)->u.arr->size;
    }

    if (flags & FOREACH_RIGHT_GLOBAL) {
	STACK_INC;
	sp->type = T_LVALUE;
	sp->u.lvalue = &current_object->variables[idx2 + variable_index_offset];
    } else if (flags & FOREACH_REF) {
	ref_t *ref = make_ref();
	svalue_t *loc = fp + idx2;

	/* foreach guarantees our target remains valid */
	ref->lvalue = 0;
	ref->sv.type = T_NUMBER;
	STACK_INC;
	sp->type = T_REF;
	sp->u.ref = ref;
	DEBUG_CHECK(loc->type != T_NUMBER && loc->type != T_REF, "Somehow a reference in foreach acquired a value before coming into scope");
	loc->type = T_REF;
	loc->u.ref = ref;
	ref->ref++;
    } else {
	STACK_INC;
	sp->type = T_LVALUE;
	sp->u.lvalue = fp + idx2;
    }
}

void c_expand_varargs(int  where) {
    svalue_t *s, *t;
    array_t *arr;
    int n;
    
    s = sp - where;
    
    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;
	CHECK_STACK_OVERFLOW(n - 1);
	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);
	    return;
	} else {
	    while (n--)
		assign_svalue_no_free(t--, &arr->item[n]);
	}
    }
    free_array(arr);
}

void c_exit_foreach (void) {
    IF_DEBUG(stack_in_use_as_temporary--);
    if (sp->type == T_REF) {
	if (!(--sp->u.ref->ref) && sp->u.ref->lvalue == 0)
	    FREE(sp->u.ref);
    }
    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);
    }
}

int c_next_foreach (void) {
    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);
	    if (sp->type == T_REF) {
		if (value == &const0u)
		    sp->u.ref->lvalue = 0;
		else
		    sp->u.ref->lvalue = value;
	    } else
		assign_svalue(sp->u.lvalue, value);
	    return 1;
	}
    } else {
	/* array or string */
	if ((sp-1)->subtype--) {
	    if ((sp-2)->type == T_STRING) {
		if (sp->type == T_REF) {
		    sp->u.ref->lvalue = &global_lvalue_byte;
		    global_lvalue_byte.u.lvalue_byte = (unsigned char *)((sp-1)->u.lvalue_byte++);
		} else {
		    free_svalue(sp->u.lvalue, "string foreach");
		    sp->u.lvalue->type = T_NUMBER;
		    sp->u.lvalue->subtype = 0;
		    sp->u.lvalue->u.number = *((sp-1)->u.lvalue_byte)++;
		}
	    } else {
		if (sp->type == T_REF)
		    sp->u.ref->lvalue = (sp-1)->u.lvalue++;
		else
		    assign_svalue(sp->u.lvalue, (sp-1)->u.lvalue++);
	    }
	    return 1;
	}
    }
    c_exit_foreach();
    return 0;
}

void c_call_inherited(int  inh, int  func, int  num_arg) {
    inherit_t *ip = current_prog->inherit + inh;
    program_t *temp_prog = ip->prog;
    function_t *funp;
    
    push_control_stack(FRAME_FUNCTION);

    caller_type = ORIGIN_LOCAL;
    current_prog = temp_prog;
		
    csp->num_local_variables = num_arg + num_varargs;
    num_varargs = 0;
    		
    function_index_offset += ip->function_index_offset;
    variable_index_offset += ip->variable_index_offset;
    
    funp = setup_inherited_frame(func);
    csp->pc = pc;

    call_program(current_prog, funp->address);
}

void c_call(int  func, int  num_arg) {
    function_t *funp;
    
    func += 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(func >= current_object->prog->last_inherited +
		current_object->prog->num_functions_defined,
		"Illegal function index\n");
    
    if (current_object->prog->function_flags[func] & FUNC_UNDEFINED)
	error("Undefined function: %s\n", function_name(current_object->prog, func));
    /* Save all important global stack machine registers */
    push_control_stack(FRAME_FUNCTION);
    
    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 = num_arg + num_varargs;
    num_varargs = 0;
    funp = setup_new_frame(func);
    csp->pc = pc;	/* The corrected return address */
    call_program(current_prog, funp->address);
}

void c_efun_return(int  args) {
    svalue_t sv;
		
    sv = *sp--;
    pop_n_elems(args);
    *++sp = sv;
}

void c_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--;
}

void c_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");
    }
}

void c_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");
    }
}

void c_pre_dec() {
    svalue_t *lval;

    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");
    }
}

void c_pre_inc() {
    svalue_t *lval;

    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");
    }
}

void c_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 */
}

void c_void_assign_local(svalue_t *  var) {
    if (sp->type == T_INVALID) {
	sp--;
	return;
    }
    free_svalue(var, "c_void_assign_local");
    *var = *sp--;
}

void c_index() {
    int i;
    
    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;
	}
#ifndef NO_BUFFER_TYPE
    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;
	}
#endif
    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 = const0u;
    }
}

void c_rindex() {
    int i;

    switch (sp->type) {
#ifndef NO_BUFFER_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;
	}
#endif
    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 *vec = sp->u.arr;
	    
	    if ((sp-1)->type != T_NUMBER)
		error("Indexing an array with an illegal type\n");
	    i = vec->size - (sp - 1)->u.number;
	    if (i < 0 || i >= vec->size) error("Array index out of bounds.\n");
	    assign_svalue_no_free(--sp, &vec->item[i]);
	    free_array(vec);
	    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 = const0u;
    }
}

void
c_functional(int  kind, int  num_arg, POINTER_INT  func) {
    funptr_t *fp;
    
    fp = (funptr_t *)DXALLOC(sizeof(funptr_hdr_t) + sizeof(functional_t),
			     TAG_FUNP, "c_functional");
    fp->hdr.owner = current_object;
    add_ref( current_object, "c_functional" );
    fp->hdr.type = kind;
    
    current_prog->func_ref++;
    
    fp->f.functional.prog = current_prog;
    fp->f.functional.offset = func;
    fp->f.functional.num_arg = num_arg;
    fp->f.functional.num_local = 0;
    fp->f.functional.fio = function_index_offset;
    fp->f.functional.vio = variable_index_offset;

    if (sp->type == T_ARRAY) {
	fp->hdr.args = sp->u.arr;
	fp->f.functional.num_arg += sp->u.arr->size;
    } else
	fp->hdr.args = 0;
    
    fp->hdr.ref = 1;

    sp->type = T_FUNCTION;
    sp->u.fp = fp;
}

void
c_anonymous(int  num_arg, int  num_local, POINTER_INT  func) {
    funptr_t *fp;
    
    fp = (funptr_t *)DXALLOC(sizeof(funptr_hdr_t) + sizeof(functional_t),
			     TAG_FUNP, "c_functional");
    fp->hdr.owner = current_object;
    add_ref( current_object, "c_functional" );
    if (num_arg & 0x10000)
	fp->hdr.type = FP_FUNCTIONAL | FP_NOT_BINDABLE;
    else
	fp->hdr.type = FP_FUNCTIONAL;
    
    current_prog->func_ref++;
    
    fp->f.functional.prog = current_prog;
    fp->f.functional.offset = func;
    fp->f.functional.num_arg = num_arg & 0xff;
    fp->f.functional.num_local = num_local;
    fp->f.functional.fio = function_index_offset;
    fp->f.functional.vio = variable_index_offset;

    fp->hdr.args = 0;

    fp->hdr.ref = 1;

    STACK_INC;
    sp->type = T_FUNCTION;
    sp->u.fp = fp;
}

void
c_function_constructor(int  kind, int  arg)
{
    funptr_t *fp;

    switch (kind) {
    case FP_EFUN:
	fp = make_efun_funp(arg, sp);
	pop_stack();
	break;
    case FP_LOCAL:
	fp = make_lfun_funp(arg, sp); 
	pop_stack();
	break;
    case FP_SIMUL:
	fp = make_simul_funp(arg, sp); 
	pop_stack();
	break;
    case FP_FUNCTIONAL:
    case FP_FUNCTIONAL | FP_NOT_BINDABLE:
    case FP_ANONYMOUS:
    case FP_ANONYMOUS | FP_NOT_BINDABLE:
	fatal("Wrong constructor called for LPC->C functional.\n");
    default:
	fatal("Tried to make unknown type of function pointer.\n");
    }
    push_refed_funp(fp);
}

void c_not() {
    if (sp->type == T_NUMBER)
	sp->u.number = !sp->u.number;
    else
	assign_svalue(sp, &const0);
}

void c_mod() {
    CHECK_TYPES(sp - 1, T_NUMBER, 1, F_MOD);
    CHECK_TYPES(sp, T_NUMBER, 2, F_MOD);
    if ((sp--)->u.number == 0)
	error("Modulus by zero.\n");
    sp->u.number %= (sp+1)->u.number;
}

void c_add_eq(int  is_void) {
    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,
			 (is_void ? F_VOID_ADD_EQ : F_ADD_EQ));
	}
	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;
#ifndef NO_BUFFER_TYPE
    case T_BUFFER:
	if (sp->type != T_BUFFER) {
	    bad_argument(sp, T_BUFFER, 2, (is_void ? F_VOID_ADD_EQ : F_ADD_EQ));
	} 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;
#endif
    case T_ARRAY:
	if (sp->type != T_ARRAY)
	    bad_argument(sp, T_ARRAY, 2, (is_void ? F_VOID_ADD_EQ : F_ADD_EQ));
	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, (is_void ? F_VOID_ADD_EQ : F_ADD_EQ));
	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, (is_void ? F_VOID_ADD_EQ : F_ADD_EQ));
    }
    
    if (!is_void) {	/* not void add_eq */
	assign_svalue_no_free(sp, lval);
    } else {
	/*
	 * but if (void)add_eq then no need to produce an
	 * rvalue
	 */
	sp--;
    }
}

void c_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, F_DIVIDE);
	    if (!(sp->type & (T_NUMBER|T_REAL)))
		bad_argument(sp, T_NUMBER|T_REAL,2, F_DIVIDE);
	}
    }
}

void c_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();
	    push_refed_mapping(m);
	    break;
	}
	
    default:
	{
	    if (!((sp-1)->type & (T_NUMBER|T_REAL|T_MAPPING)))
		bad_argument(sp-1, T_NUMBER|T_REAL|T_MAPPING,1, F_MULTIPLY);
	    if (!(sp->type & (T_NUMBER|T_REAL|T_MAPPING)))
		bad_argument(sp, T_NUMBER|T_REAL|T_MAPPING,2, F_MULTIPLY);
	    error("Args to * are not compatible.\n");
	}
    }
    
}

void c_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");
    }
}

void c_dec() {
    svalue_t *lval;

    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");
    }
}

void c_le() {
    int i = sp->type;

    switch((--sp)->type|i) {
    case T_NUMBER:
	sp->u.number = sp->u.number <= (sp+1)->u.number;
	break;
	
    case T_REAL:
	sp->u.number = sp->u.real <= (sp+1)->u.real;
	sp->type = T_NUMBER;
	break;
	
    case T_NUMBER|T_REAL:
	if (i == T_NUMBER) {
	    sp->type = T_NUMBER;
	    sp->u.number = sp->u.real <= (sp+1)->u.number;
	} else sp->u.number = sp->u.number <= (sp+1)->u.real;
	break;
	
    case T_STRING:
	i = strcmp(sp->u.string, (sp+1)->u.string) <= 0;
	free_string_svalue(sp+1);
	free_string_svalue(sp);
	sp->type = T_NUMBER;
	sp->u.number = i;
	break;
	
    default:
	{
	    switch((sp++)->type) {
	    case T_NUMBER:
	    case T_REAL:
		bad_argument(sp, T_NUMBER | T_REAL, 2, F_LE);
		
	    case T_STRING:
		bad_argument(sp, T_STRING, 2, F_LE);
		
	    default:
		bad_argument(sp - 1, T_NUMBER | T_STRING | T_REAL, 1, F_LE);
	    }
	}
    }
}

void c_lt() {
    int i = sp->type;
    switch (i | (--sp)->type) {
    case T_NUMBER:
	sp->u.number = sp->u.number < (sp+1)->u.number;
	break;
    case T_REAL:
	sp->u.number = sp->u.real < (sp+1)->u.real;
	sp->type = T_NUMBER;
	break;
    case T_NUMBER|T_REAL:
	if (i == T_NUMBER) {
	    sp->type = T_NUMBER;
	    sp->u.number = sp->u.real < (sp+1)->u.number;
	} else sp->u.number = sp->u.number < (sp+1)->u.real;
	break;
    case T_STRING:
	i = (strcmp((sp - 1)->u.string, sp->u.string) < 0);
	free_string_svalue(sp+1);
	free_string_svalue(sp);
	sp->type = T_NUMBER;
	sp->u.number = i;
	break;
    default:
	switch ((sp++)->type) {
	case T_NUMBER:
	case T_REAL:
	    bad_argument(sp, T_NUMBER | T_REAL, 2, F_LT);
	case T_STRING:
	    bad_argument(sp, T_STRING, 2, F_LT);
	default:
	    bad_argument(sp-1, T_NUMBER | T_STRING | T_REAL, 1, F_LT);
	}
    }
}

void c_gt() {
    int i = sp->type;
    switch ((--sp)->type | i) {
    case T_NUMBER:
	sp->u.number = sp->u.number > (sp+1)->u.number;
	break;
    case T_REAL:
	sp->u.number = sp->u.real > (sp+1)->u.real;
	sp->type = T_NUMBER;
	break;
    case T_NUMBER | T_REAL:
	if (i == T_NUMBER) {
	    sp->type = T_NUMBER;
	    sp->u.number = sp->u.real > (sp+1)->u.number;
	} else sp->u.number = sp->u.number > (sp+1)->u.real;
	break;
    case T_STRING:
	i = strcmp(sp->u.string, (sp+1)->u.string) > 0;
	free_string_svalue(sp+1);
	free_string_svalue(sp);
	sp->type = T_NUMBER;
	sp->u.number = i;
	break;
    default:
	{
	    switch ((sp++)->type) {
	    case T_NUMBER:
	    case T_REAL:
		bad_argument(sp, T_NUMBER | T_REAL, 2, F_GT);
	    case T_STRING:
		bad_argument(sp, T_STRING, 2, F_GT);
	    default:
		bad_argument(sp-1, T_NUMBER | T_REAL | T_STRING, 1, F_GT);
	    }
	}
    }
}

void c_ge() {
    int i = sp->type;
    switch ((--sp)->type | i) {
    case T_NUMBER:
	sp->u.number = sp->u.number >= (sp+1)->u.number;
	break;
    case T_REAL:
	sp->u.number = sp->u.real >= (sp+1)->u.real;
	sp->type = T_NUMBER;
	break;
    case T_NUMBER | T_REAL:
	if (i == T_NUMBER) {
	    sp->type = T_NUMBER;
	    sp->u.number = sp->u.real >= (sp+1)->u.number;
	} else sp->u.number = sp->u.number >= (sp+1)->u.real;
	break;
    case T_STRING:
	i = strcmp(sp->u.string, (sp+1)->u.string) >= 0;
	free_string_svalue(sp + 1);
	free_string_svalue(sp);
	sp->type = T_NUMBER;
	sp->u.number = i;
	break;
    default:
	{
	    switch ((sp++)->type) {
	    case T_NUMBER:
	    case T_REAL:
		bad_argument(sp, T_NUMBER | T_REAL, 2, F_GE);
	    case T_STRING:
		bad_argument(sp, T_STRING, 2, F_GE);
	    default:
		bad_argument(sp - 1, T_NUMBER | T_STRING | T_REAL, 1, F_GE);
	    }
	}
    }
}

void c_subtract() {
    int 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");
    }
}

void c_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");
}

void c_compl() {
    if (sp->type != T_NUMBER)
	error("Bad argument to ~\n");
    sp->u.number = ~sp->u.number;
}

void c_add() {
    switch (sp->type) {
#ifndef NO_BUFFER_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 */
#endif
    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));
    }
}

int c_loop_cond_compare(svalue_t *  s1, svalue_t *  s2) {
    switch (s1->type | s2->type) {
    case T_NUMBER: 
	return s1->u.number < s2->u.number;
    case T_REAL:
	return s1->u.real < s2->u.real;
    case T_STRING:
	return (strcmp(s1->u.string, s2->u.string) < 0);
    case T_NUMBER|T_REAL:
	if (s1->type == T_NUMBER) return s1->u.number < s2->u.real;
	else return s1->u.real < s2->u.number;
    default:
	if (s1->type == T_OBJECT && (s1->u.ob->flags & O_DESTRUCTED)) {
	    free_object(s1->u.ob, "do_loop_cond:1");
	    *s1 = const0u;
	}
	if (s2->type == T_OBJECT && (s2->u.ob->flags & O_DESTRUCTED)) {
	    free_object(s2->u.ob, "do_loop_cond:2");
	    *s2 = const0u;
	}
	if (s1->type == T_NUMBER && s2->type == T_NUMBER)
	    return 0;
	
	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");
	}
    }
    return 0;
}

void c_sscanf(int  num_arg) {
    svalue_t *fp;
    int i;

    /*
     * allocate stack frame for rvalues and return value (number of matches);
     * perform some stack manipulation; note: source and template strings are
     * already on the stack by this time
     */
    fp = sp;
    CHECK_STACK_OVERFLOW(num_arg + 1);
    sp += num_arg + 1;
    *sp = *(fp--);		/* move format description to top of stack */
    *(sp - 1) = *(fp);		/* move source string just below the format
				 * desc. */
    fp->type = T_NUMBER;	/* this svalue isn't invalidated below, and
				 * if we don't change it to something safe,
				 * it will get freed twice if an error occurs */
    /*
     * prep area for rvalues
     */
    for (i = 1; i <= num_arg; i++)
	fp[i].type = T_INVALID;

    /*
     * do it...
     */
    i = inter_sscanf(sp - 2, sp - 1, sp, num_arg);

    /*
     * remove source & template strings from top of stack
     */
    pop_2_elems();

    /*
     * save number of matches on stack
     */
    fp->type = T_NUMBER;
    fp->u.number = i;
}

void c_parse_command(int  num_arg) {
    svalue_t *arg;
    svalue_t *fp;
    int i;

    /*
     * type checking on first three required parameters to parse_command()
     */
    arg = sp - 2;
    CHECK_TYPES(&arg[0], T_STRING, 1, F_PARSE_COMMAND);
    CHECK_TYPES(&arg[1], T_OBJECT | T_ARRAY, 2, F_PARSE_COMMAND);
    CHECK_TYPES(&arg[2], T_STRING, 3, F_PARSE_COMMAND);

    /*
     * allocate stack frame for rvalues and return value (number of matches);
     * perform some stack manipulation;
     */
    fp = sp;
    CHECK_STACK_OVERFLOW(num_arg + 1);
    sp += num_arg + 1;
    arg = sp;
    *(arg--) = *(fp--);		/* move pattern to top of stack */
    *(arg--) = *(fp--);		/* move source object or array to just below 
				   the pattern */
    *(arg) = *(fp);		/* move source string just below the object */
    fp->type = T_NUMBER;

    /*
     * prep area for rvalues
     */
    for (i = 1; i <= num_arg; i++)
	fp[i].type = T_INVALID;

    /*
     * do it...
     */
    i = parse(arg[0].u.string, &arg[1], arg[2].u.string, &fp[1], num_arg);

    /*
     * remove mandatory parameters
     */
    pop_3_elems();

    /*
     * save return value on stack
     */
    fp->u.number = i;
}

void c_prepare_catch(error_context_t *  econ) {
    if (!save_context(econ))
	error("Can't catch too deep recursion error.\n");
    push_control_stack(FRAME_CATCH);
#if defined(DEBUG) || defined(TRACE_CODE)
    csp->num_local_variables = (csp - 1)->num_local_variables;	/* marion */
#endif
    assign_svalue(&catch_value, &const1);
}

void c_caught_error(error_context_t *  econ) {
    restore_context(econ);
    STACK_INC;
    *sp = catch_value;
    catch_value = const1;

    /* if it's too deep or max eval, we can't let them catch it */
    pop_context(econ);
    if (max_eval_error)
	error("Can't catch eval cost too big error.\n");
    if (too_deep_error)
	error("Can't catch too deep recursion error.\n");
}
    
void c_end_catch(error_context_t *  econ) {
    free_svalue(&catch_value, "F_END_CATCH");
    catch_value = const0;
    /* We come here when no longjmp() was executed */
    pop_control_stack();
    push_number(0);
    pop_context(econ);
}

static int compare_switch_entries P2(string_switch_entry_t *, p1,
				     string_switch_entry_t *, p2) {
    return ((POINTER_INT)p1->string - (POINTER_INT)p2->string);
}

#ifdef DEBUGMALLOC_EXTENSIONS
typedef struct msl_s {
    struct msl_s *next;
    string_switch_entry_t **tables;
} msl_t;

static msl_t *g_msl_tables = 0;

static void add_switch_list(string_switch_entry_t **  tables) {
    msl_t *new;
        
    new = ALLOCATE(msl_t, TAG_DEBUGMALLOC, "add_switch_list");
    new->next = g_msl_tables;
    new->tables = tables;
}
	
void mark_switch_lists (void) {
    string_switch_entry_t *p, **tables;
    msl_t *msl = g_msl_tables;
    
    while (msl) {
	tables = msl->tables;
	msl = msl->next;
	while (*tables) {
	    p = *tables++;
	    while (p->string) {
		EXTRA_REF(BLOCK(p->string))++;
		p++;
	    }
	}
    }
}
#endif

void fix_switches(string_switch_entry_t **  tables) {
    string_switch_entry_t *p;

#ifdef DEBUGMALLOC_EXTENSIONS
    add_switch_list(tables);
#endif
    while (*tables) {
	p = *tables;
	while (p->string) {
	    p->string = make_shared_string(p->string);
	    p++;
	}
	quickSort((char *)(*tables), p - *tables , 
		  sizeof(string_switch_entry_t), compare_switch_entries);
	tables++;
    }
}

int c_string_switch_lookup P3(svalue_t *, str, string_switch_entry_t *, table,
			      int, table_size) {
    char *the_string;

    if (str->subtype == STRING_SHARED)
	the_string = str->u.string;
    else {
	if (!(the_string = findstring(str->u.string)))
	    return -1;
    }

    /* this should use a binary search, but for now ... */
    while (table->string) {
	if (the_string == table->string) return table->index;
	table++;
    }
    return -1;
}

void c_evaluate(int  num) {
    svalue_t *v;
    svalue_t *arg = sp - num + 1;

    if (arg->type != T_FUNCTION) {
	pop_n_elems(num-1);
	return;
    }
    if (current_object->flags & O_DESTRUCTED) {
	pop_n_elems(num);
	push_undefined();
	return;
    }
    v = call_function_pointer(arg->u.fp, num - 1);
    free_funp(arg->u.fp);
    assign_svalue_no_free(sp, v);
}

int c_range_switch_lookup P3(int, num, range_switch_entry_t *, table,
			     int, table_size) {
    /* this should also be a better search method */
    
    while (table->index2 != -2) {
	if (table->index2 == -1) {
	    if (table->index1 <= num && num <= (table+1)->index1)
		return (table+1)->index2;
	    table += 2;
	} else {
	    if (table->index1 == num) return table->index2;
	    table++;
	}
    }
    return 0;
}

void c_make_ref(int  op) {
    ref_t *ref;

    /* global and local refs need no protection since they are
     * guaranteed to outlive the current scope.  Lvalues inside
     * structures may not, however ...
     */
    ref->lvalue = sp->u.lvalue;
    if (op != F_GLOBAL_LVALUE && op != F_LOCAL_LVALUE) {
	ref->sv.type = lv_owner_type;
	ref->sv.subtype = STRING_MALLOC; /* ignored if non-string */
	if (lv_owner_type == T_STRING) {
	    ref->sv.u.string = (char *)lv_owner;
	    INC_COUNTED_REF(lv_owner);
	    ADD_STRING(MSTR_SIZE(lv_owner));
	    NDBG(BLOCK(lv_owner));
	} else {
	    ref->sv.u.refed = lv_owner;
	    lv_owner->ref++;
	    if (lv_owner_type == T_MAPPING)
		((mapping_t *)lv_owner)->count |= MAP_LOCKED;
	}
    } else {
	ref->sv.type = T_NUMBER;
    }
    sp->type = T_REF;
    sp->u.ref = ref;
}

void c_kill_refs(int  num) {
    while (num--)
	kill_ref(global_ref_list);
}

#endif