/*
This file is part of the FElt finite element analysis package.
Copyright (C) 1993-2000 Jason I. Gobat and Darren C. Atkinson
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*/
/************************************************************************
* File: apply.c *
* *
* Description: This file contains the function definitions for the *
* virtual machine instructions related to function and *
* array application and function return. *
************************************************************************/
# include "trap.h"
# include "apply.h"
# include "debug.h"
# include "error.h"
# include "lexer.h"
# include "coerce.h"
# include "execute.h"
# include "functab.h"
# include "our-stdlib.h"
# include "pathsearch.h"
static descriptor *ret_val;
static descriptor ret_obj;
static Function top_of_stack;
static int array_index PROTO ((descriptor *, int));
static int matrix_index PROTO ((descriptor *, int));
static int intrinsic_call PROTO ((descriptor *, int));
static int function_search PROTO ((descriptor *, int));
static int external_call PROTO ((descriptor *, int));
static int submatrix_assignment PROTO ((descriptor *, descriptor **));
/************************************************************************
* Function: submatrix_assignment *
* *
* Description: Trapped variable handler for submatrix assignment. The *
* handler verifies that the source is the same size and *
* type as the destination submatrix. *
************************************************************************/
static int submatrix_assignment (dest, src)
descriptor *dest;
descriptor **src;
{
Matrix a;
Matrix b;
int status;
/* RecycleData() calls the function with only one argument. */
if (!src) {
D_Temp (dest) = F_True;
D_Trapped (dest) = F_False;
RecycleData (dest);
return 0;
}
*src = CoerceData (*src, T_Double);
switch (D_Type (*src)) {
case T_Double:
a = D_Matrix (dest);
if (Mrows (a) == 1 && Mcols (a) == 1) {
sdata (a, 1, 1) = *D_Double (*src);
return 0;
}
TypeError ("=", dest, *src, NULL, F_False);
return 1;
case T_Matrix:
a = D_Matrix (*src);
b = D_Matrix (dest);
if ((status = CopyMatrix (b, a)))
MatrixError ("=", b, a, status, F_False);
return status;
default:
TypeError ("=", dest, *src, NULL, F_False);
return 1;
}
}
/************************************************************************
* Function: function_call *
* *
* Description: Calls the function whose name and arguments are on the *
* stack. After the call returns the name and arguments *
* are removed from the stack and the return value is *
* placed on the top of the stack. If too few arguments *
* are given to the function then null descriptors on *
* pushed in their place. If too many arguments are given *
* then they are silently discarded. All value arguments *
* are dereferenced in place on the stack. *
************************************************************************/
int function_call (object, num_args)
descriptor *object;
int num_args;
{
int i;
int j;
descriptor *d;
descriptor *fp;
descriptor *arg;
descriptor *args;
descriptor *locals;
descriptor *result;
descriptor temp;
Function function;
Function old_top;
fp = sp - num_args;
args = sp - num_args + 1;
function = D_Function (object);
old_top = top_of_stack;
top_of_stack = function;
/* Remove any extra arguments. */
if (function -> num_args < num_args)
for (i = function -> num_args; i < num_args; i ++)
RecycleData (pop ( ));
/* Add any necessary arguments. */
else if (function -> num_args > num_args)
for (i = num_args; i < function -> num_args; i ++) {
arg = push ( );
D_Type (arg) = T_Null;
D_Temp (arg) = F_False;
D_Trapped (arg) = F_False;
D_Pointer (arg) = NULL;
}
/* Dereference any value arguments in place on the stack. */
for (i = function -> num_args - 1, j = 0; i >= 0; i --, j ++) {
arg = ntop (i);
/* If the argument is a value argument then make a copy of it in
place on the stack. */
if (function -> arg_types [j] == ValueArg) {
d = &temp;
*d = *arg;
d = deref (d);
D_Type (arg) = T_Null;
D_Temp (arg) = F_False;
D_Trapped (arg) = F_False;
D_Pointer (arg) = NULL;
AssignData (arg, &d);
/* Otherwise, the argument is shared. If the argument is not
assignable and is not temporary then we have to copy it. */
} else if (!assignable (arg) && D_Temp (arg) == F_False) {
d = &temp;
*d = *arg;
d = deref (d);
D_Type (arg) = T_Null;
D_Temp (arg) = F_False;
D_Trapped (arg) = F_False;
D_Pointer (arg) = NULL;
AssignData (arg, &d);
}
D_Temp (arg) = F_False;
D_Trapped (arg) = F_False;
}
/* Push null descriptors for the local variables. */
locals = sp + 1;
for (i = 0; i < function -> num_locals; i ++) {
arg = push ( );
D_Type (arg) = T_Null;
D_Temp (arg) = F_False;
D_Trapped (arg) = F_False;
D_Pointer (arg) = NULL;
}
/* Call the function. If the function fails then show the stack. */
if (execute (function -> cs, locals, args) != -1) {
fprintf (stderr, "%s:%u: ", *strlit (curr_file_num), curr_line_num);
fprintf (stderr, "%s (", function -> name);
for (i = 0; i < function -> num_args; i ++)
fprintf (stderr, "%s%s", i ? "," : "", D_TypeName (args + i));
fprintf (stderr, ")\n");
top_of_stack = old_top;
return 1;
}
top_of_stack = old_top;
d_printf ("freeing locals: ");
d_printf ("%d + %d\n", function -> num_args, function -> num_locals);
for (i = 0; i < function -> num_args + function -> num_locals; i ++)
FreeData (pop ( ));
RecycleData (pop ( ));
result = push ( );
*result = *ret_val;
d_printf ("rtn ans =\n");
d_PrintData (result);
return 0;
}
/************************************************************************
* Function: intrinsic_call *
* *
* Description: Calls the intrinsic function whose index and arguments *
* are on the top of the stack. The parameter list is *
* adjusted as in the case of a normal function call. *
* However, a special case is made since an intrinsic *
* function may take a variable number of arguments. The *
* arguments are not dereferenced. *
************************************************************************/
static int intrinsic_call (object, num_args)
descriptor *object;
int num_args;
{
int i;
int nargs;
int index;
int num_passed;
descriptor *arg;
descriptor *result;
/* If the function accepts a fixed number of arguments then set up the
stack by pushing or popping extra descriptors. */
if ((nargs = functab [index = D_Intrinsic (object)].num_args) >= 0) {
/* Remove any extra arguments. */
if (nargs < num_args)
for (i = nargs; i < num_args; i ++)
RecycleData (pop ( ));
/* Add any necessary arguments. */
else if (nargs > num_args)
for (i = num_args; i < nargs; i ++) {
arg = push ( );
D_Type (arg) = T_Null;
D_Temp (arg) = F_False;
D_Trapped (arg) = F_False;
D_Pointer (arg) = NULL;
}
num_passed = nargs;
} else
num_passed = num_args;
/* Call the intrinsic function. */
if (functab [index].func (num_passed))
return 1;
ret_val = pop ( );
RecycleData (pop ( ));
result = push ( );
*result = *ret_val;
return 0;
}
/************************************************************************
* Function: matrix_index *
* *
* Description: Indexes the descriptor whose indices are on the top of *
* the stack and places the result on the stack. The *
* following types and indices are legal, where a vector *
* is a matrix with either a single row or column: *
* *
* scalar (1) -> scalar *
* scalar (1,1) -> scalar *
* row-vector (x) -> row-vector *
* row_vector (x,1) -> row-vector *
* col-vector (x) -> col-vector *
* col-vector (1,x) -> col-vector *
* matrix (x) -> col-vector *
* matrix (x,y) -> matrix *
* *
* An index must either be a scalar or a vector whose *
* elements are contiguous and increasing. The result *
* will be a trapped variable. The trap handler will *
* verify that the object to be assigned must be of the *
* same type and size. *
************************************************************************/
static int matrix_index (object, num_args)
descriptor *object;
int num_args;
{
Matrix a;
Matrix b;
Matrix index;
descriptor *arg2;
descriptor *arg1;
descriptor *result;
descriptor *orig;
descriptor temp;
double value;
int type_error;
int status;
unsigned i;
unsigned dim;
unsigned nrows;
unsigned ncols;
unsigned s_row;
unsigned s_col;
unsigned e_row;
unsigned e_col;
/* Check the number of arguments. */
if (num_args == 0 || num_args > 2) {
rterror ("incorrect number of indices for %s", D_TypeName (object));
return 1;
}
/* Set up the stack. */
arg2 = num_args == 2 ? pop ( ) : NULL;
arg1 = pop ( );
result = top ( );
temp = *result;
object = &temp;
orig = object;
object = deref (object);
/* Initialize the arguments. */
status = 0;
type_error = F_False;
arg1 = CoerceData (deref (arg1), T_Double);
if (arg2)
arg2 = CoerceData (deref (arg2), T_Double);
s_row = e_row = s_col = e_col = 0;
/* Compute the starting and ending row indices. */
switch (D_Type (arg1)) {
case T_Double:
s_row = e_row = *D_Double (arg1);
break;
case T_Matrix:
index = D_Matrix (arg1);
if (Mrows (index) == 1) {
s_row = mdata (index, 1, 1);
e_row = mdata (index, 1, Mcols (index));
for (i = 2; i <= Mcols (index); i ++)
if (mdata (index, 1, i) != s_row + i - 1) {
rterror ("improper row index in index expression");
status = 1;
break;
}
} else if (Mcols (index) == 1) {
s_row = mdata (index, 1, 1);
e_row = mdata (index, Mrows (index), 1);
for (i = 2; i <= Mrows (index); i ++)
if (mdata (index, i, 1) != s_row + i - 1) {
rterror ("improper row index in index expression");
status = 1;
break;
}
} else {
rterror ("matrix used as row index in index expression");
status = 1;
}
break;
case T_Row:
if (D_Type (object) == T_Double)
s_row = e_row = 1;
else if (D_Type (object) == T_Matrix) {
s_row = 1;
e_row = Mrows (D_Matrix (object));
}
break;
default:
TypeError ("in index expression", arg1, NULL, NULL, F_False);
type_error = F_True;
break;
}
/* Compute the starting and ending column indices. */
if (arg2 && type_error == F_False && status == 0) {
switch (D_Type (arg2)) {
case T_Double:
s_col = e_col = *D_Double (arg2);
break;
case T_Matrix:
index = D_Matrix (arg2);
if (Mrows (index) == 1) {
s_col = mdata (index, 1, 1);
e_col = mdata (index, 1, Mcols (index));
for (i = 2; i <= Mcols (index); i ++)
if (mdata (index, 1, i) != s_col + i - 1) {
rterror ("improper column index in index expression");
status = 1;
break;
}
} else if (Mcols (index) == 1) {
s_col = mdata (index, 1, 1);
e_col = mdata (index, Mrows (index), 1);
for (i = 2; i <= Mrows (index); i ++)
if (mdata (index, i, 1) != s_col + i - 1) {
rterror ("improper column index in index expression");
status = 1;
break;
}
} else {
rterror ("matrix used as column index in index expression");
status = 1;
}
break;
case T_Row:
if (D_Type (object) == T_Double)
s_col = e_col = 1;
else if (D_Type (object) == T_Matrix) {
s_col = 1;
e_col = Mcols (D_Matrix (object));
}
break;
default:
TypeError ("in index expression", arg2, NULL, NULL, F_False);
type_error = F_True;
break;
}
} else
s_col = e_col = 1;
/* Perform the indexing. */
if (type_error == F_False && status == 0) {
switch (D_Type (object)) {
case T_Int:
case T_Byte:
case T_Double:
if (s_row != 1 || e_row != 1) {
rterror ("row index is out of range (must be one)");
status = 1;
} else if (s_col != 1 || e_col != 1) {
rterror ("column index is out of range (must be one)");
status = 1;
/* If the object cannot be assignable then we can just copy the
object. */
} else if (!D_Trapped (object) && D_Type (orig) != T_Variable) {
CreateData (result, NULL, NULL, T_Double);
*D_Double (result) = *D_Double (object);
/* If the object is not trapped then change the double into a
matrix with one row and column. The result is a submatrix of
the new matrix. This way, the matrix library does the
reference counting for us. */
} else if (D_Trapped (object) == F_False) {
value = *D_Double (object);
FreeData (object);
CreateData (object, NULL, NULL, T_Matrix, 1, 1);
a = D_Matrix (object);
sdata (a, 1, 1) = value;
D_Temp (object) = F_False;
b = CreateSubsectionMatrix (a, 1, 1, 1, 1);
D_Type (result) = T_Matrix;
D_Temp (result) = F_False;
D_Trapped (result) = AddTrap (submatrix_assignment);
D_Matrix (result) = b;
/* Otherwise, we don't need to do anything (I think). Note that
all bytes and integers are trapped, so this case will be
executed. */
} else {
/* Result should be the object itself, as located on the
interpreter stack, as opposed to our stack. */
}
break;
case T_Matrix:
a = D_Matrix (object);
nrows = Mrows (a);
ncols = Mcols (a);
/* Handle a missing second argument. */
if (!arg2)
/* If only one argument was specified and the object is a row
vector then swap the indices. */
if (Mrows (a) == 1) {
dim = s_row;
s_row = s_col;
s_col = dim;
dim = e_row;
e_row = e_col;
e_col = dim;
/* If only one argument was specified and the object is a
matrix then return the entire column. */
} else if (Mcols (a) != 1) {
s_col = s_row;
e_col = e_row;
s_row = 1;
e_row = Mrows (a);
}
/* Check the indices. */
if (s_row < 1 || s_row > nrows) {
rterror ("row index is out of range (1 .. %u)", nrows);
status = 1;
} else if (e_row < s_row || e_row > nrows) {
rterror ("row index is out of range (1 .. %u)", nrows);
status = 1;
} else if (s_col < 1 || s_col > ncols) {
rterror ("column index is out of range (1 .. %u)", ncols);
status = 1;
} else if (e_col < s_col || e_col > ncols) {
rterror ("column index is out of range (1 .. %u)", ncols);
status = 1;
} else {
/* Compute the subsection. */
if (IsCompact (a)) {
b = MakeFullFromCompact (a);
DestroyMatrix (a);
D_Matrix (object) = a = b;
}
b = CreateSubsectionMatrix (a, s_row, s_col, e_row, e_col);
if (b) {
D_Type (result) = T_Matrix;
D_Temp (result) = F_False;
D_Trapped (result) = AddTrap (submatrix_assignment);
D_Matrix (result) = b;
} else
status = 1;
}
break;
}
}
/* Clean up and return. */
RecycleData (arg2);
RecycleData (arg1);
RecycleData (object);
d_printf ("index ans =\n");
d_PrintData (result);
return type_error == F_True || status != 0;
}
/************************************************************************
* Function: array_index *
* *
* Description: Indexes the array descriptor whose index is on the top *
* of the stack and places the result on the stack. The *
* following types are legal: *
* *
* array (double) -> element (array indexing) *
* array (vector) -> array (subarray creation) *
* *
* An attempt is first made to coerce the index to a *
* double value. *
************************************************************************/
static int array_index (object, num_args)
descriptor *object;
int num_args;
{
Array array;
Matrix index;
void *ptr;
descriptor *arg;
descriptor *result;
descriptor temp;
unsigned i;
unsigned end;
unsigned start;
int len;
int type;
int handler;
int type_error;
int status;
/* Check the number of arguments. */
if (num_args != 1) {
rterror ("incorrect number of indices for array");
return 1;
}
/* Set up the stack. */
arg = pop ( );
result = top ( );
temp = *result;
object = &temp;
object = deref (object);
status = 0;
type_error = F_False;
start = end = 0;
arg = CoerceData (deref (arg), T_Double);
array = D_Array (object);
switch (D_Type (arg)) {
case T_Double:
start = end = *D_Double (arg);
break;
case T_Matrix:
index = D_Matrix (arg);
if (Mrows (index) == 1) {
start = mdata (index, 1, 1);
end = mdata (index, 1, Mcols (index));
for (i = 2; i <= Mcols (index); i ++)
if (mdata (index, 1, i) != start + i - 1) {
rterror ("improper array index in index expression");
status = 1;
break;
}
} else if (Mcols (index) == 1) {
start = mdata (index, 1, 1);
end = mdata (index, Mrows (index), 1);
for (i = 2; i <= Mrows (index); i ++)
if (mdata (index, i, 1) != start + i - 1) {
rterror ("improper array index in index expression");
status = 1;
break;
}
} else {
rterror ("matrix used as array index in index expression");
status = 1;
}
break;
case T_Row:
start = 1;
end = array -> length;
break;
default:
type_error = F_True;
break;
}
if (type_error == F_False && status == 0) {
if (array -> length == 0) {
rterror ("index is out of range (no valid array members)");
status = 1;
} else if (start < 1 || start > array -> length) {
rterror ("index is out of range (1 .. %u)", array -> length);
status = 1;
} else if (end < start || end > array -> length) {
rterror ("index is out of range (1 .. %u)", array -> length);
status = 1;
} else if (start == end) {
ptr = (void *) ((char *) array -> ptr + start * array -> elt_size);
D_Type (result) = array -> type;
D_Temp (result) = F_False;
D_Trapped (result) = array -> handler;
D_Pointer (result) = ptr;
} else {
start --; /* all arrays are unit offset */
ptr = (void *) ((char *) array -> ptr + start * array -> elt_size);
type = array -> type;
len = end - start;
handler = array -> handler;
CreateData (result, NULL, NULL, T_Array, ptr, type, len, handler);
D_Array (result) -> elt_size = array -> elt_size;
D_Trapped (result) = D_Trapped (object);
}
}
if (type_error == F_True)
TypeError ("in index expression", arg, NULL, NULL, F_False);
RecycleData (arg);
RecycleData (object);
d_printf ("index ans =\n");
d_PrintData (result);
return type_error == F_True || status != 0;
}
/************************************************************************
* Function: function_search *
* *
* Description: Searches the global symbol table for a symbol with the *
* same name as the specified null descriptor. If such a *
* symbol exists and is a function, then it is used as the *
* basis for a function call. Otherwise, if there is a *
* file in the include-search path with the same name then *
* it is included and the search is made again in the *
* global symbol table. *
************************************************************************/
static int function_search (object, num_args)
descriptor *object;
int num_args;
{
int idx;
ste *s;
char *name;
char *file;
descriptor *d;
static char *path;
if (D_Type (object) != T_Variable) {
TypeError ("function call to", NULL, object, NULL, F_False);
return 1;
}
idx = D_Variable (object) - varp;
if (idx < 0 || (top_of_stack && idx > top_of_stack -> num_locals)) {
TypeError ("function call to", NULL, object, NULL, F_False);
return 1;
}
if (top_of_stack) {
name = top_of_stack -> local_names [idx];
if ((s = st_lookup (&var_st, name))) {
d = global (s -> idx);
d = deref (d);
switch (D_Type (d)) {
case T_Function:
return function_call (d, num_args);
case T_Intrinsic:
return intrinsic_call (d, num_args);
default:
d = deref (d);
TypeError ("function call to", NULL, d, NULL, F_False);
return 1;
}
}
} else
name = st_index (&var_st, idx) -> name;
if (!path)
path = getenv ("BURLAP_PATH");
if ((file = pathsearch (path, name, ".b", F_False))) {
printf ("including %s\n", file);
bfinclude (file);
if ((s = st_lookup (&var_st, name))) {
d = global (s -> idx);
d = deref (d);
switch (D_Type (d)) {
case T_Function:
return function_call (d, num_args);
case T_Intrinsic:
return intrinsic_call (d, num_args);
default:
d = deref (d);
TypeError ("function call to", NULL, d, NULL, F_False);
return 1;
}
}
}
TypeError ("function call to", NULL, deref (object), NULL, F_False);
return 1;
}
/************************************************************************
* Function: external_call *
* *
* Description: Calls the external C function pointed to by the *
* specified descriptor. This mechanism is used to call *
* the set-up and stress functions of the built-in FElt *
* elements. The first argument must be an element and *
* the second argument, if specified, must be an integer. *
************************************************************************/
static int external_call (object, num_args)
descriptor *object;
int num_args;
{
void **ptr;
descriptor *arg1;
descriptor *arg2;
descriptor *result;
descriptor temp;
int type_error;
int mode;
int i;
if (num_args < 1) {
rterror ("incorrect number of arguments for %s", D_TypeName (object));
return 1;
}
for (i = 2; i < num_args; i ++)
RecycleData (pop ( ));
arg2 = num_args >= 2 ? pop ( ) : NULL;
result = top ( );
temp = *result;
arg1 = &temp;
type_error = F_False;
arg1 = CoerceData (deref (arg1), T_Double);
if (arg2)
arg2 = CoerceData (deref (arg2), T_Int);
if (D_Type (arg1) == T_Element) {
CreateData (result, NULL, NULL, T_Double);
ptr = (void **) D_Pointer (arg1);
mode = arg2 && D_Type (arg2) == T_Int ? *D_Int (arg2) : 0;
*D_Double (result) = (*D_External (object)) (*ptr, mode);
} else
type_error = F_True;
if (type_error == F_True)
TypeError ("in C function call", arg1, arg2, NULL, F_False);
RecycleData (arg1);
RecycleData (arg2);
return type_error == F_True;
}
/************************************************************************
* Function: apply_op *
* *
* Description: Pops the descriptors on the top of the stack and *
* performs a function or array application. The *
* following types are legal: *
* *
* null (...) (function search) *
* array (...) (array indexing) *
* double (...) (scalar indexing) *
* matrix (...) (matrix indexing) *
* function (...) (user-defined function call) *
* intrinsic (...) (intrinsic function call) *
* external (...) (external C function call) *
* *
* No coercion is performed since the result of an index *
* is a variable. *
************************************************************************/
int apply_op ( )
{
int num_args;
descriptor *object;
num_args = fetch (pc ++).ival;
object = ntop (num_args);
object = deref (object);
switch (D_Type (object)) {
case T_Null:
return function_search (ntop (num_args), num_args);
case T_Array:
return array_index (object, num_args);
case T_Int:
case T_Byte:
case T_Double:
case T_Matrix:
return matrix_index (object, num_args);
case T_Function:
return function_call (object, num_args);
case T_Intrinsic:
return intrinsic_call (object, num_args);
case T_External:
return external_call (object, num_args);
default:
TypeError ("function call to", NULL, object, NULL, F_False);
return 1;
}
}
/************************************************************************
* Function: rtn_op *
* *
* Description: Returns from a function call. If the descriptor on the *
* top of the stack is not a global variable (i.e. it is *
* local to the current function) then the descriptor is *
* dereferenced. The descriptor is saved in a static *
* location and a termination code is returned so that *
* the current stack frame will be erased and execution *
* will return to the caller. *
************************************************************************/
int rtn_op ( )
{
descriptor *d;
d = pop ( );
ret_val = &ret_obj;
if (!is_global (d)) {
d_printf ("returning =\n");
d_PrintData (d);
d = deref (d);
D_Temp (d) = F_False;
D_Type (ret_val) = T_Null;
D_Temp (ret_val) = F_False;
D_Trapped (ret_val) = F_False;
D_Pointer (ret_val) = NULL;
AssignData (ret_val, &d);
D_Temp (ret_val) = F_True;
} else
*ret_val = *d;
d_printf ("returning = %p (%s)\n", D_Pointer (d), D_TypeName (d));
d_printf ("rtn\n");
return -1;
}
syntax highlighted by Code2HTML, v. 0.9.1