/*
* hash_number - hash a NUMBER
*
* given:
* type - hash type (see hash.h)
* n - the NUMBER
* state - the state to hash or NULL
*
* returns:
* the new state
*/
HASH *
hash_number(int type, void *n, HASH *state)
{
NUMBER *number = (NUMBER *)n; /* n as a NUMBER pointer */
BOOL sign; /* sign of the denominator */
/*
* initialize if state is NULL
*/
if (state == NULL) {
state = hash_init(type, NULL);
}
/*
* setup for the NUMBER hash
*/
(state->chkpt)(state);
state->bytes = FALSE;
/*
* process the numerator
*/
state = hash_zvalue(type, number->num, state);
/*
* if the NUMBER is not an integer, process the denominator
*/
if (qisfrac(number)) {
/* note the division */
(state->note)(HASH_DIV(state->base), state);
/* hash denominator as positive -- just in case */
sign = number->den.sign;
number->den.sign = 0;
/* hash the denominator */
state = hash_zvalue(type, number->den, state);
/* restore the sign */
number->den.sign = sign;
}
/*
* all done
*/
return state;
}
/*
* Raise an object to an integral power.
* This is the default routine if the user's is not defined.
* Negative powers mean the positive power of the inverse.
* Zero means the multiplicative identity.
*
* given:
* vp value to be powered
* q power to raise number to
*/
S_FUNC VALUE
objpowi(VALUE *vp, NUMBER *q)
{
VALUE res, tmp;
long power; /* power to raise to */
FULL bit; /* current bit value */
if (qisfrac(q)) {
math_error("Raising object to non-integral power");
/*NOTREACHED*/
}
if (zge31b(q->num)) {
math_error("Raising object to very large power");
/*NOTREACHED*/
}
power = ztolong(q->num);
if (qisneg(q))
power = -power;
/*
* Handle some low powers specially
*/
if ((power <= 2) && (power >= -2)) {
switch ((int) power) {
case 0:
return objcall(OBJ_ONE, vp, NULL_VALUE, NULL_VALUE);
case 1:
res.v_obj = objcopy(vp->v_obj);
res.v_type = V_OBJ;
res.v_subtype = V_NOSUBTYPE;
return res;
case -1:
return objcall(OBJ_INV, vp, NULL_VALUE, NULL_VALUE);
case 2:
return objcall(OBJ_SQUARE, vp, NULL_VALUE, NULL_VALUE);
}
}
if (power < 0)
power = -power;
/*
* Compute the power by squaring and multiplying.
* This uses the left to right method of power raising.
*/
bit = TOPFULL;
while ((bit & power) == 0)
bit >>= 1L;
bit >>= 1L;
res = objcall(OBJ_SQUARE, vp, NULL_VALUE, NULL_VALUE);
if (bit & power) {
tmp = objcall(OBJ_MUL, &res, vp, NULL_VALUE);
objfree(res.v_obj);
res = tmp;
}
bit >>= 1L;
while (bit) {
tmp = objcall(OBJ_SQUARE, &res, NULL_VALUE, NULL_VALUE);
objfree(res.v_obj);
res = tmp;
if (bit & power) {
tmp = objcall(OBJ_MUL, &res, vp, NULL_VALUE);
objfree(res.v_obj);
res = tmp;
}
bit >>= 1L;
}
if (qisneg(q)) {
tmp = objcall(OBJ_INV, &res, NULL_VALUE, NULL_VALUE);
objfree(res.v_obj);
return tmp;
}
return res;
}
/*
* Add an opcode to the current function being compiled.
* Note: This can change the curfunc global variable when the
* function needs expanding.
*/
void
addop(long op)
{
register FUNC *fp; /* current function */
NUMBER *q, *q1, *q2;
unsigned long count;
BOOL cut;
int diff;
fp = curfunc;
count = fp->f_opcodecount;
cut = TRUE;
diff = 2;
q = NULL;
if ((count + 5) >= maxopcodes) {
maxopcodes += OPCODEALLOCSIZE;
fp = (FUNC *) malloc(funcsize(maxopcodes));
if (fp == NULL) {
math_error("cannot malloc function");
/*NOTREACHED*/
}
memcpy((char *) fp, (char *) curfunc,
funcsize(curfunc->f_opcodecount));
if (curfunc != functemplate)
free(curfunc);
curfunc = fp;
}
/*
* Check the current opcode against the previous opcode and try to
* slightly optimize the code depending on the various combinations.
*/
switch (op) {
case OP_GETVALUE:
switch (oldop) {
case OP_NUMBER:
case OP_ZERO:
case OP_ONE:
case OP_IMAGINARY:
case OP_GETEPSILON:
case OP_SETEPSILON:
case OP_STRING:
case OP_UNDEF:
case OP_GETCONFIG:
case OP_SETCONFIG:
return;
case OP_DUPLICATE:
diff = 1;
oldop = OP_DUPVALUE;
break;
case OP_FIADDR:
diff = 1;
oldop = OP_FIVALUE;
break;
case OP_GLOBALADDR:
diff = 1 + PTR_SIZE;
oldop = OP_GLOBALVALUE;
break;
case OP_LOCALADDR:
oldop = OP_LOCALVALUE;
break;
case OP_PARAMADDR:
oldop = OP_PARAMVALUE;
break;
case OP_ELEMADDR:
oldop = OP_ELEMVALUE;
break;
default:
cut = FALSE;
}
if (cut) {
fp->f_opcodes[count - diff] = oldop;
return;
}
break;
case OP_POP:
switch (oldop) {
case OP_ASSIGN:
fp->f_opcodes[count-1] = OP_ASSIGNPOP;
oldop = OP_ASSIGNPOP;
return;
case OP_NUMBER:
case OP_IMAGINARY:
q = constvalue(fp->f_opcodes[count-1]);
qfree(q);
break;
case OP_STRING:
sfree(findstring((long)fp->f_opcodes[count-1]));
break;
case OP_LOCALADDR:
case OP_PARAMADDR:
break;
case OP_GLOBALADDR:
diff = 1 + PTR_SIZE;
break;
case OP_UNDEF:
fp->f_opcodecount -= 1;
oldop = OP_NOP;
oldoldop = OP_NOP;
return;
default:
cut = FALSE;
}
if (cut) {
fp->f_opcodecount -= diff;
oldop = OP_NOP;
oldoldop = OP_NOP;
fprintf(stderr,
"Line %ld: unused value ignored\n",
linenumber());
return;
}
break;
case OP_NEGATE:
if (oldop == OP_NUMBER) {
q = constvalue(fp->f_opcodes[count-1]);
fp->f_opcodes[count-1] = addqconstant(qneg(q));
qfree(q);
return;
}
}
if (oldop == OP_NUMBER) {
if (oldoldop == OP_NUMBER) {
q1 = constvalue(fp->f_opcodes[count - 3]);
q2 = constvalue(fp->f_opcodes[count - 1]);
switch (op) {
case OP_DIV:
if (qiszero(q2)) {
cut = FALSE;
break;
}
q = qqdiv(q1,q2);
break;
case OP_MUL:
q = qmul(q1,q2);
break;
case OP_ADD:
q = qqadd(q1,q2);
break;
case OP_SUB:
q = qsub(q1,q2);
break;
case OP_POWER:
if (qisfrac(q2) || qisneg(q2))
cut = FALSE;
else
q = qpowi(q1,q2);
break;
default:
cut = FALSE;
}
if (cut) {
qfree(q1);
qfree(q2);
fp->f_opcodes[count - 3] = addqconstant(q);
fp->f_opcodecount -= 2;
oldoldop = OP_NOP;
return;
}
} else if (op != OP_NUMBER) {
q = constvalue(fp->f_opcodes[count - 1]);
if (op == OP_POWER) {
if (qcmpi(q, 2L) == 0) {
fp->f_opcodecount--;
fp->f_opcodes[count - 2] = OP_SQUARE;
qfree(q);
oldop = OP_SQUARE;
return;
}
if (qcmpi(q, 4L) == 0) {
fp->f_opcodes[count - 2] = OP_SQUARE;
fp->f_opcodes[count - 1] = OP_SQUARE;
qfree(q);
oldop = OP_SQUARE;
return;
}
}
if (qiszero(q)) {
qfree(q);
fp->f_opcodes[count - 2] = OP_ZERO;
fp->f_opcodecount--;
} else if (qisone(q)) {
qfree(q);
fp->f_opcodes[count - 2] = OP_ONE;
fp->f_opcodecount--;
}
}
}
/*
* No optimization possible, so store the opcode.
*/
fp->f_opcodes[fp->f_opcodecount] = op;
fp->f_opcodecount++;
oldoldop = oldop;
oldop = op;
}
/*
* Call the appropriate user-defined routine to handle an object action.
* Returns the value that the routine returned.
*/
VALUE
objcall(int action, VALUE *v1, VALUE *v2, VALUE *v3)
{
FUNC *fp; /* function to call */
STATIC OBJECTACTIONS *oap; /* object to call for */
struct objectinfo *oip; /* information about action */
long index; /* index of function (negative if undefined) */
VALUE val; /* return value */
VALUE tmp; /* temp value */
char name[SYMBOLSIZE+1+1]; /* full name of user routine to call */
size_t namestr_len; /* length of the namestr() return string */
char *namestr_ret; /* namestr() return string */
size_t opi_name_len; /* length of the oip name */
/* initialize VALUEs */
val.v_subtype = V_NOSUBTYPE;
tmp.v_subtype = V_NOSUBTYPE;
if ((unsigned)action > OBJ_MAXFUNC) {
math_error("Illegal action for object call");
/*NOTREACHED*/
}
oip = &objectinfo[action];
if (v1->v_type == V_OBJ) {
oap = v1->v_obj->o_actions;
} else if (v2->v_type == V_OBJ) {
oap = v2->v_obj->o_actions;
} else {
math_error("Object routine called with non-object");
/*NOTREACHED*/
}
index = oap->oa_indices[action];
if (index < 0) {
namestr_ret = namestr(&objectnames, oap->oa_index);
if (namestr_ret == NULL) {
math_error("namestr returned NULL!!!");
/*NOTREACHED*/
}
namestr_len = strlen(namestr_ret);
opi_name_len = strlen(oip->name);
if (namestr_len > (size_t)SYMBOLSIZE-1-opi_name_len) {
math_error("namestr returned a strong too long!!!");
/*NOTREACHED*/
}
name[0] = '\0';
strncpy(name, namestr_ret, namestr_len+1);
strcat(name, "_");
strncat(name, oip->name, opi_name_len+1);
index = adduserfunc(name);
oap->oa_indices[action] = index;
}
fp = NULL;
if (index >= 0)
fp = findfunc(index);
if (fp == NULL) {
switch (oip->error) {
case ERR_PRINT:
objprint(v1->v_obj);
val.v_type = V_NULL;
break;
case ERR_CMP:
val.v_type = V_INT;
if (v1->v_type != v2->v_type) {
val.v_int = 1;
return val;
}
val.v_int = objcmp(v1->v_obj, v2->v_obj);
break;
case ERR_TEST:
val.v_type = V_INT;
val.v_int = objtest(v1->v_obj);
break;
case ERR_POW:
if (v2->v_type != V_NUM) {
math_error("Non-real power");
/*NOTREACHED*/
}
val = objpowi(v1, v2->v_num);
break;
case ERR_ONE:
val.v_type = V_NUM;
val.v_num = qlink(&_qone_);
break;
case ERR_INC:
tmp.v_type = V_NUM;
tmp.v_num = &_qone_;
val = objcall(OBJ_ADD, v1, &tmp, NULL_VALUE);
break;
case ERR_DEC:
tmp.v_type = V_NUM;
tmp.v_num = &_qone_;
val = objcall(OBJ_SUB, v1, &tmp, NULL_VALUE);
break;
case ERR_SQUARE:
val = objcall(OBJ_MUL, v1, v1, NULL_VALUE);
break;
case ERR_VALUE:
copyvalue(v1, &val);
break;
case ERR_ASSIGN:
copyvalue(v2, &tmp);
tmp.v_subtype |= v1->v_subtype;
freevalue(v1);
*v1 = tmp;
val.v_type = V_NULL;
break;
default:
math_error("Function \"%s\" is undefined",
namefunc(index));
/*NOTREACHED*/
}
return val;
}
switch (oip->args) {
case 0:
break;
case 1:
++stack;
stack->v_addr = v1;
stack->v_type = V_ADDR;
break;
case 2:
++stack;
stack->v_addr = v1;
stack->v_type = V_ADDR;
++stack;
stack->v_addr = v2;
stack->v_type = V_ADDR;
break;
case 3:
++stack;
stack->v_addr = v1;
stack->v_type = V_ADDR;
++stack;
stack->v_addr = v2;
stack->v_type = V_ADDR;
++stack;
stack->v_addr = v3;
stack->v_type = V_ADDR;
break;
default:
math_error("Bad number of args to calculate");
/*NOTREACHED*/
}
calculate(fp, oip->args);
switch (oip->retval) {
case A_VALUE:
return *stack--;
case A_UNDEF:
freevalue(stack--);
val.v_type = V_NULL;
break;
case A_INT:
if ((stack->v_type != V_NUM) || qisfrac(stack->v_num)) {
math_error("Integer return value required");
/*NOTREACHED*/
}
index = qtoi(stack->v_num);
qfree(stack->v_num);
stack--;
val.v_type = V_INT;
val.v_int = index;
break;
default:
math_error("Bad object return");
/*NOTREACHED*/
}
return val;
}