int fail_op ( )
{
Address offset;
descriptor *d;
d = pop ( );
d = CoerceData (deref (d), T_Double);
offset = fetch (pc ++).addr;
if (D_Type (d) != T_Double) {
TypeError ("in conditional context", d, NULL, NULL, F_False);
RecycleData (d);
return 1;
}
if (*D_Double (d) == 0) {
RecycleData (d);
pc += offset;
d = push ( );
D_Type (d) = T_Null;
D_Temp (d) = F_False;
D_Trapped (d) = F_False;
D_Pointer (d) = NULL;
} else
RecycleData (d);
return 0;
}
int asgn_op ( )
{
descriptor *src;
descriptor *dest;
int status;
src = pop ( );
dest = top ( );
src = deref (src);
if (!assignable (dest)) {
TypeError ("cannot assign to", NULL, dest, NULL, F_False);
RecycleData (src);
return 1;
}
dest = deref (dest);
src = CollapseMatrix (src);
status = AssignData (dest, &src);
RecycleData (src);
D_Temp (dest) = F_False;
return status;
}
int pop_op ( )
{
int i;
int n;
n = fetch (pc ++).ival;
for (i = 0; i < n; i ++)
RecycleData (pop ( ));
d_printf ("pop\n");
return 0;
}
int jz_op ( )
{
Address offset;
descriptor *d;
d = pop ( );
d = CoerceData (deref (d), T_Double);
offset = fetch (pc ++).addr;
if (D_Type (d) != T_Double) {
TypeError ("in conditional context", d, NULL, NULL, F_False);
RecycleData (d);
return 1;
}
if (*D_Double (d) == 0)
pc += offset;
RecycleData (d);
return 0;
}
int gen_op ( )
{
Matrix a;
Matrix b;
void *ptr;
descriptor *d;
descriptor *v;
descriptor *var;
descriptor *index;
descriptor *vector;
descriptor temp;
double value;
Address increment;
Array arr;
int fail;
unsigned offset;
unsigned i;
unsigned c;
unsigned r;
index = ntop (0);
vector = ntop (1);
var = ntop (2);
offset = fetch (pc ++).ival;
if (D_Type (index) == T_Double) {
if (!assignable (var)) {
TypeError ("cannot assign to", NULL, var, NULL, F_False);
return 1;
}
d = &temp;
D_Type (d) = T_Null;
D_Temp (d) = F_False;
D_Trapped (d) = F_False;
D_Pointer (d) = NULL;
v = CoerceData (vector, T_Double);
AssignData (d, &v);
RecycleData (v);
D_Temp (d) = F_False;
d_printf ("d = %s %p\n", D_TypeName (d), D_Pointer (d));
switch (D_Type (d)) {
case T_Double:
case T_Matrix:
case T_Array:
case T_Null:
break;
default:
TypeError ("cannot index", NULL, d, NULL, F_False);
return 1;
}
*vector = *d;
D_Type (index) = T_Row;
D_Row (index) = 0;
}
d_printf ("vector = %s %p\n", D_TypeName (vector), D_Pointer (vector));
var = deref (var);
fail = F_False;
switch (D_Type (vector)) {
case T_Double:
if (D_Row (index) ++ == 0)
AssignData (var, &vector);
else
fail = F_True;
break;
case T_Matrix:
a = D_Matrix (vector);
d = &temp;
D_Temp (d) = F_False;
D_Trapped (d) = F_False;
if (Mrows (a) == 1) {
if (++ D_Row (index) <= Mcols (a)) {
D_Type (d) = T_Double;
D_Double (d) = &value;
value = mdata (a, 1, D_Row (index));
AssignData (var, &d);
} else
fail = F_True;
} else if (Mcols (a) == 1) {
if (++ D_Row (index) <= Mrows (a)) {
D_Type (d) = T_Double;
D_Double (d) = &value;
value = mdata (a, D_Row (index), 1);
AssignData (var, &d);
} else
fail = F_True;
} else {
if (++ D_Row (index) <= Mcols (a)) {
d_printf ("indexing matrix\n");
r = Mrows (a);
c = D_Row (index);
FreeData (var);
CreateData (var, NULL, NULL, T_Matrix, r, 1);
D_Temp (var) = F_False;
b = D_Matrix (var);
for (i = 1; i <= r; i ++)
sdata (b, i, 1) = mdata (a, i, c);
} else
fail = F_True;
}
break;
case T_Array:
arr = D_Array (vector);
d = &temp;
if (++ D_Row (index) <= arr -> length) {
increment = D_Row (index) * arr -> elt_size;
ptr = (void *) ((char *) arr -> ptr + increment);
D_Type (d) = arr -> type;
D_Temp (d) = F_False;
D_Trapped (d) = F_False;
D_Pointer (d) = ptr;
AssignData (var, &d);
} else
fail = F_True;
break;
case T_Null:
fail = F_True;
break;
}
/* After assignment the variable is certainly not temporary. Its trapped
status remains as before: if it was trapped then AssignData() called
the trap handler which didn't change the status. If it wasn't then
AssignData() left the status alone. */
D_Temp (var) = F_False;
if (fail == F_True) {
pop ( );
FreeData (pop ( )); /* free the privately owned vector */
pop ( );
d = push ( );
D_Type (d) = T_Null;
D_Temp (d) = F_False;
D_Trapped (d) = F_False;
D_Pointer (d) = NULL;
pc += offset;
d_printf ("failing\n");
}
return 0;
}
int ne_op ( )
{
Matrix a;
Matrix b;
Matrix c;
double lvalue;
double rvalue;
descriptor *left;
descriptor *right;
descriptor *result;
descriptor temp;
int type_error;
int status;
int cmp;
unsigned i;
unsigned j;
right = pop ( );
result = top ( );
temp = *result;
left = &temp;
left = deref (left);
right = deref (right);
if (D_Type (left) != T_String || D_Type (right) != T_String) {
left = CoerceData (left, T_Double);
right = CoerceData (right, T_Double);
}
status = 0;
type_error = F_False;
switch (D_Type (left)) {
case T_Double:
switch (D_Type (right)) {
case T_Double:
D_Type (result) = T_Double;
D_Temp (result) = F_False;
D_Trapped (result) = F_False;
D_Double (result) = dbllit (*D_Double (left) != *D_Double (right));
break;
case T_Matrix:
a = D_Matrix (right);
CreateData (result, left, right, T_Matrix, Mrows (a), Mcols (a));
b = D_Matrix (result);
lvalue = *D_Double (left);
for (i = 1; i <= Mrows (a); i ++)
for (j = 1; j <= Mcols (a); j ++)
sdata (b, i, j) = lvalue != mdata (a, i, j);
break;
default:
type_error = F_True;
break;
}
break;
case T_Matrix:
switch (D_Type (right)) {
case T_Double:
a = D_Matrix (left);
CreateData (result, left, right, T_Matrix, Mrows (a), Mcols (a));
b = D_Matrix (result);
rvalue = *D_Double (right);
for (i = 1; i <= Mrows (a); i ++)
for (j = 1; j <= Mcols (a); j ++)
sdata (b, i, j) = mdata (a, i, j) != rvalue;
break;
case T_Matrix:
a = D_Matrix (left);
b = D_Matrix (right);
CreateData (result, left, right, T_Matrix, Mrows (a), Mcols (a));
c = D_Matrix (result);
if ((status = CompareNEQMatrices (c, a, b)))
MatrixError ("!=", a, b, status, F_False);
break;
default:
type_error = F_True;
break;
}
break;
case T_String:
switch (D_Type (right)) {
case T_String:
cmp = strcmp (*D_String (left), *D_String (right));
D_Type (result) = T_Double;
D_Temp (result) = F_False;
D_Trapped (result) = F_False;
D_Double (result) = dbllit (cmp != 0);
break;
default:
type_error = F_True;
break;
}
break;
case T_Function:
case T_Intrinsic:
case T_Array:
case T_Pair:
if (D_Type (left) == D_Type (right)) {
D_Type (result) = T_Double;
D_Temp (result) = F_False;
D_Trapped (result) = F_False;
D_Double (result) = dbllit (D_Pointer (left) == D_Pointer (right));
} else
type_error = F_False;
break;
case T_Constraint:
case T_Definition:
case T_Element:
case T_Force:
case T_Load:
case T_Material:
case T_Node:
case T_Stress:
case T_External:
if (D_Type (left) == D_Type (right)) {
cmp = *(void **) D_Pointer (left) != *(void **) D_Pointer (right);
D_Type (result) = T_Double;
D_Temp (result) = F_False;
D_Trapped (result) = F_False;
D_Double (result) = dbllit (cmp);
} else if (D_Type (right) == T_Null) {
cmp = *(void **) D_Pointer (left) != NULL;
D_Type (result) = T_Double;
D_Temp (result) = F_False;
D_Trapped (result) = F_False;
D_Double (result) = dbllit (cmp);
} else
type_error = F_True;
break;
case T_Null:
switch (D_Type (right)) {
case T_Constraint:
case T_Definition:
case T_Element:
case T_Force:
case T_Load:
case T_Material:
case T_Node:
case T_Stress:
case T_External:
cmp = *(void **) D_Pointer (right) != NULL;
D_Type (result) = T_Double;
D_Temp (result) = F_False;
D_Trapped (result) = F_False;
D_Double (result) = dbllit (cmp);
break;
default:
type_error = F_True;
break;
}
break;
default:
type_error = F_True;
break;
}
if (type_error == F_True)
TypeError ("!=", left, right, NULL, F_False);
RecycleData (left);
RecycleData (right);
d_printf ("ne ans =\n");
d_PrintData (result);
return type_error == F_True || status != 0;
}
int lt_op ( )
{
Matrix a;
Matrix b;
Matrix c;
double lvalue;
double rvalue;
descriptor *left;
descriptor *right;
descriptor *result;
descriptor temp;
int type_error;
int status;
int cmp;
unsigned i;
unsigned j;
right = pop ( );
result = top ( );
temp = *result;
left = &temp;
left = deref (left);
right = deref (right);
if (D_Type (left) != T_String || D_Type (right) != T_String) {
left = CoerceData (left, T_Double);
right = CoerceData (right, T_Double);
}
status = 0;
type_error = F_False;
switch (D_Type (left)) {
case T_Double:
switch (D_Type (right)) {
case T_Double:
D_Type (result) = T_Double;
D_Temp (result) = F_False;
D_Trapped (result) = F_False;
D_Double (result) = dbllit (*D_Double (left) < *D_Double (right));
break;
case T_Matrix:
a = D_Matrix (right);
CreateData (result, left, right, T_Matrix, Mrows (a), Mcols (a));
b = D_Matrix (result);
lvalue = *D_Double (left);
for (i = 1; i <= Mrows (a); i ++)
for (j = 1; j <= Mcols (a); j ++)
sdata (b, i, j) = lvalue < mdata (a, i, j);
break;
default:
type_error = F_True;
break;
}
break;
case T_Matrix:
switch (D_Type (right)) {
case T_Double:
a = D_Matrix (left);
CreateData (result, left, right, T_Matrix, Mrows (a), Mcols (a));
b = D_Matrix (result);
rvalue = *D_Double (right);
for (i = 1; i <= Mrows (a); i ++)
for (j = 1; j <= Mcols (a); j ++)
sdata (b, i, j) = mdata (a, i, j) < rvalue;
break;
case T_Matrix:
a = D_Matrix (left);
b = D_Matrix (right);
CreateData (result, left, right, T_Matrix, Mrows (a), Mcols (a));
c = D_Matrix (result);
if ((status = CompareLTMatrices (c, a, b)))
MatrixError ("<", a, b, status, F_False);
break;
default:
type_error = F_True;
break;
}
break;
case T_String:
switch (D_Type (right)) {
case T_String:
cmp = strcmp (*D_String (left), *D_String (right));
D_Type (result) = T_Double;
D_Temp (result) = F_False;
D_Trapped (result) = F_False;
D_Double (result) = dbllit (cmp < 0);
break;
default:
type_error = F_True;
break;
}
break;
default:
type_error = F_True;
break;
}
if (type_error == F_True)
TypeError ("<", left, right, NULL, F_False);
RecycleData (left);
RecycleData (right);
d_printf ("lt ans =\n");
d_PrintData (result);
return type_error == F_True || status != 0;
}