/*
* Construct a complex number given the real and imaginary components.
*/
COMPLEX *
qqtoc(NUMBER *q1, NUMBER *q2)
{
COMPLEX *r;
if (qiszero(q1) && qiszero(q2))
return clink(&_czero_);
r = comalloc();
qfree(r->real);
qfree(r->imag);
r->real = qlink(q1);
r->imag = qlink(q2);
return r;
}
/*
* Allocate a new complex number.
*/
COMPLEX *
comalloc(void)
{
COMPLEX *r;
r = (COMPLEX *) malloc(sizeof(COMPLEX));
if (r == NULL) {
math_error("Cannot allocate complex number");
/*NOTREACHED*/
}
r->links = 1;
r->real = qlink(&_qzero_);
r->imag = qlink(&_qzero_);
return r;
}
/*
* Copy an object value
*/
OBJECT *
objcopy(OBJECT *op)
{
VALUE *v1, *v2;
OBJECT *np;
int i;
i = op->o_actions->oa_count;
if (i < USUAL_ELEMENTS)
i = USUAL_ELEMENTS;
if (i == USUAL_ELEMENTS)
np = (OBJECT *) malloc(sizeof(OBJECT));
else
np = (OBJECT *) malloc(objectsize(i));
if (np == NULL) {
math_error("Cannot allocate object");
/*NOTREACHED*/
}
np->o_actions = op->o_actions;
v1 = op->o_table;
v2 = np->o_table;
for (i = op->o_actions->oa_count; i-- > 0; v1++, v2++) {
if (v1->v_type == V_NUM) {
v2->v_num = qlink(v1->v_num);
v2->v_type = V_NUM;
} else {
copyvalue(v1, v2);
}
v2->v_subtype = V_NOSUBTYPE;
}
return np;
}
/*
* Return the imaginary part of a complex number as a real.
*/
COMPLEX *
c_imag(COMPLEX *c)
{
COMPLEX *r;
if (cisreal(c))
return clink(&_czero_);
r = comalloc();
qfree(r->real);
r->real = qlink(c->imag);
return r;
}
/*
* Subtract a real number from a complex number.
*/
COMPLEX *
csubq(COMPLEX *c, NUMBER *q)
{
COMPLEX *r;
if (qiszero(q))
return clink(c);
r = comalloc();
qfree(r->real);
qfree(r->imag);
r->real = qsub(c->real, q);
r->imag = qlink(c->imag);
return r;
}
/*
* Return the real part of a complex number.
*/
COMPLEX *
c_real(COMPLEX *c)
{
COMPLEX *r;
if (cisreal(c))
return clink(c);
r = comalloc();
if (!qiszero(c->real)) {
qfree(r->real);
r->real = qlink(c->real);
}
return r;
}
/*
* Take the conjugate of a complex number.
* This negates the complex part.
*/
COMPLEX *
cconj(COMPLEX *c)
{
COMPLEX *r;
if (cisreal(c))
return clink(c);
r = comalloc();
if (!qiszero(c->real)) {
qfree(r->real);
r->real = qlink(c->real);
}
qfree(r->imag);
r->imag = qneg(c->imag);
return r;
}
/*
* Define a possibly new global variable which may or may not be static.
* If it did not already exist, it is created with a value of zero.
* The address of the global symbol structure is returned.
*
* given:
* name name of global variable
* isstatic TRUE if symbol is static
*/
GLOBAL *
addglobal(char *name, BOOL isstatic)
{
GLOBAL *sp; /* current symbol pointer */
GLOBAL **hp; /* hash table head address */
size_t len; /* length of string */
int newfilescope; /* file scope being looked for */
int newfuncscope; /* function scope being looked for */
newfilescope = SCOPE_GLOBAL;
newfuncscope = 0;
if (isstatic) {
newfilescope = filescope;
newfuncscope = funcscope;
}
len = strlen(name);
if (len <= 0)
return NULL;
hp = &globalhash[HASHSYM(name, len)];
for (sp = *hp; sp; sp = sp->g_next) {
if ((sp->g_len == len) && (strcmp(sp->g_name, name) == 0)
&& (sp->g_filescope == newfilescope)
&& (sp->g_funcscope == newfuncscope))
return sp;
}
sp = (GLOBAL *) malloc(sizeof(GLOBAL));
if (sp == NULL)
return sp;
sp->g_name = addstr(&globalnames, name);
sp->g_len = len;
sp->g_filescope = newfilescope;
sp->g_funcscope = newfuncscope;
sp->g_value.v_num = qlink(&_qzero_);
sp->g_value.v_type = V_NUM;
sp->g_value.v_subtype = V_NOSUBTYPE;
sp->g_next = *hp;
*hp = sp;
return sp;
}
/*
* Allocate a new object structure with the specified index.
*/
OBJECT *
objalloc(long index)
{
OBJECTACTIONS *oap;
OBJECT *op;
VALUE *vp;
int i;
if (index < 0 || index > maxobjcount) {
math_error("Allocating bad object index");
/*NOTREACHED*/
}
oap = objects[index];
if (oap == NULL) {
math_error("Object type not defined");
/*NOTREACHED*/
}
i = oap->oa_count;
if (i < USUAL_ELEMENTS)
i = USUAL_ELEMENTS;
if (i == USUAL_ELEMENTS)
op = (OBJECT *) malloc(sizeof(OBJECT));
else
op = (OBJECT *) malloc(objectsize(i));
if (op == NULL) {
math_error("Cannot allocate object");
/*NOTREACHED*/
}
op->o_actions = oap;
vp = op->o_table;
for (i = oap->oa_count; i-- > 0; vp++) {
vp->v_num = qlink(&_qzero_);
vp->v_type = V_NUM;
vp->v_subtype = V_NOSUBTYPE;
}
return 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;
}
