static int do_binary_function_c (int (*f)(double, double,VOID_STAR), VOID_STAR cd)
{
Array_Or_Scalar_Type a_ast, b_ast, c_ast;
if (-1 == pop_2_arrays_or_scalar (&a_ast, &b_ast))
return -1;
c_ast.at = NULL;
c_ast.num = 1;
c_ast.inc = 0;
c_ast.cptr = &c_ast.c;
if ((a_ast.at != NULL) || (b_ast.at != NULL))
{
if (a_ast.at != NULL)
c_ast.at = SLang_create_array1 (SLANG_CHAR_TYPE, 0, NULL, a_ast.at->dims, a_ast.at->num_dims, 1);
else
c_ast.at = SLang_create_array1 (SLANG_CHAR_TYPE, 0, NULL, b_ast.at->dims, b_ast.at->num_dims, 1);
if (c_ast.at == NULL)
{
free_array_or_scalar (&a_ast);
free_array_or_scalar (&b_ast);
return -1;
}
c_ast.cptr = (char *) c_ast.at->data;
c_ast.num = c_ast.at->num_elements;
c_ast.inc = 1;
}
if (a_ast.is_float)
{
if (b_ast.is_float)
(void) do_c_ff_fun (f, cd, &a_ast, &b_ast, &c_ast);
else
(void) do_c_fd_fun (f, cd, &a_ast, &b_ast, &c_ast);
}
else if (b_ast.is_float)
(void) do_c_df_fun (f, cd, &a_ast, &b_ast, &c_ast);
else
(void) do_c_dd_fun (f, cd, &a_ast, &b_ast, &c_ast);
free_array_or_scalar (&a_ast);
free_array_or_scalar (&b_ast);
if (c_ast.at != NULL)
return SLang_push_array (c_ast.at, 1);
return SLang_push_char (c_ast.c);
}
/* This is called when at is 2d */
static SLang_Array_Type *allocate_transposed_array (SLang_Array_Type *at)
{
SLang_Array_Type *bt;
int no_init;
no_init = (0 == (at->flags & SLARR_DATA_VALUE_IS_POINTER));
bt = SLang_create_array1 (at->data_type, 0, NULL, at->dims, 2, no_init);
if (bt != NULL)
{
bt->dims[1] = at->dims[0];
bt->dims[0] = at->dims[1];
}
return bt;
}
static void nint_intrin (void)
{
double x;
SLang_Array_Type *at, *bt;
int (*at_to_int_fun)(SLang_Array_Type *, SLang_Array_Type *);
if (SLang_peek_at_stack () != SLANG_ARRAY_TYPE)
{
if (-1 == SLang_pop_double (&x))
return;
(void) SLang_push_int (do_nint (x));
return;
}
switch (SLang_peek_at_stack1 ())
{
case -1:
return;
case SLANG_INT_TYPE:
return;
case SLANG_FLOAT_TYPE:
if (-1 == SLang_pop_array_of_type (&at, SLANG_FLOAT_TYPE))
return;
at_to_int_fun = float_to_nint;
break;
case SLANG_DOUBLE_TYPE:
default:
if (-1 == SLang_pop_array_of_type (&at, SLANG_DOUBLE_TYPE))
return;
at_to_int_fun = double_to_nint;
break;
}
if (NULL == (bt = SLang_create_array1 (SLANG_INT_TYPE, 0, NULL, at->dims, at->num_dims, 1)))
{
SLang_free_array (at);
return;
}
if (0 == (*at_to_int_fun) (at, bt))
(void) SLang_push_array (bt, 0);
SLang_free_array (bt);
SLang_free_array (at);
}
static SLang_Array_Type *create_from_tmp_array (SLang_Array_Type *a, SLang_Array_Type *b, SLtype type)
{
SLang_Array_Type *c;
if ((a != NULL) && (a->data_type == type) && (a->num_refs == 1))
{
a->num_refs += 1;
return a;
}
if ((b != NULL) && (b->data_type == type) && (b->num_refs == 1))
{
b->num_refs += 1;
return b;
}
if (a != NULL)
c = a;
else
c = b;
return SLang_create_array1 (type, 0, NULL, c->dims, c->num_dims, 1);
}
static int pop_array_or_string (SLtype itype, char **sp,
SLang_Array_Type **atsp, SLang_Array_Type **atip)
{
char *s;
if (SLang_peek_at_stack () == SLANG_ARRAY_TYPE)
{
SLang_Array_Type *ats, *ati;
*sp = NULL;
if (-1 == SLang_pop_array_of_type (&ats, SLANG_STRING_TYPE))
{
*atsp = NULL;
*atip = NULL;
return -1;
}
if (NULL == (ati = SLang_create_array1 (itype, 0, NULL, ats->dims, ats->num_dims, 1)))
{
*atsp = NULL;
*atip = NULL;
SLang_free_array (ats);
return -1;
}
*atsp = ats;
*atip = ati;
return 0;
}
*atsp = NULL;
*atip = NULL;
if (-1 == SLang_pop_slstring (&s))
{
*sp = NULL;
return -1;
}
*sp = s;
return 0;
}
static int map_or_contract_array (SLCONST SLarray_Map_Type *c, int use_contraction,
int dim_specified, int *use_this_dim,
VOID_STAR clientdata)
{
int k, use_all_dims;
SLang_Array_Type *at, *new_at;
SLindex_Type *old_dims;
SLindex_Type old_dims_buf[SLARRAY_MAX_DIMS];
SLindex_Type sub_dims[SLARRAY_MAX_DIMS];
SLindex_Type tmp_dims[SLARRAY_MAX_DIMS];
unsigned int i, j, old_num_dims, sub_num_dims;
SLtype new_data_type, old_data_type;
char *old_data, *new_data;
SLindex_Type w[SLARRAY_MAX_DIMS], wk;
size_t old_sizeof_type, new_sizeof_type;
SLuindex_Type dims_k;
int from_type;
SLCONST SLarray_Map_Type *csave;
SLarray_Map_Fun_Type *fmap;
SLarray_Contract_Fun_Type *fcon;
use_all_dims = 1;
k = 0;
if (dim_specified)
{
if (use_this_dim != NULL)
{
k = *use_this_dim;
use_all_dims = 0;
}
}
else if (SLang_Num_Function_Args == 2)
{
if (-1 == SLang_pop_integer (&k))
return -1;
use_all_dims = 0;
}
if (-1 == (from_type = SLang_peek_at_stack1 ()))
return -1;
csave = c;
while (c->f != NULL)
{
if (c->from_type == (SLtype) from_type)
break;
c++;
}
/* Look for a more generic version */
if (c->f != NULL)
{
if (-1 == SLang_pop_array_of_type (&at, c->typecast_to_type))
return -1;
}
else
{
/* Look for a wildcard match */
c = csave;
while (c->f != NULL)
{
if (c->from_type == SLANG_VOID_TYPE)
break;
c++;
}
if (c->f == NULL)
{
_pSLang_verror (SL_TYPE_MISMATCH, "%s is not supported by this function", SLclass_get_datatype_name (from_type));
return -1;
}
/* Found it. So, typecast it to appropriate type */
if (c->typecast_to_type == SLANG_VOID_TYPE)
{
if (-1 == SLang_pop_array (&at, 1))
return -1;
}
else if (-1 == SLang_pop_array_of_type (&at, c->typecast_to_type))
return -1;
}
old_data_type = at->data_type;
if (SLANG_VOID_TYPE == (new_data_type = c->result_type))
new_data_type = old_data_type;
old_num_dims = at->num_dims;
if (use_all_dims == 0)
{
if (k < 0)
k += old_num_dims;
if ((k < 0) || (k >= (int)old_num_dims))
{
_pSLang_verror (SL_INVALID_PARM, "Dimension %d is invalid for a %d-d array",
k, old_num_dims);
SLang_free_array (at);
return -1;
}
old_dims = at->dims;
}
else
{
old_dims = old_dims_buf;
old_dims[0] = (SLindex_Type)at->num_elements;
old_num_dims = 1;
}
fcon = (SLarray_Contract_Fun_Type *) c->f;
fmap = c->f;
if (use_contraction
&& (use_all_dims || (old_num_dims == 1)))
{
SLang_Class_Type *cl;
VOID_STAR buf;
int status = 0;
cl = _pSLclass_get_class (new_data_type);
buf = cl->cl_transfer_buf;
if (at->num_elements == 0)
{
/* If there are no elements, the fcon may or may not
* compute a value. So, clear the buffer
*/
memset ((char *)buf, 0, cl->cl_sizeof_type);
}
if ((-1 == (*fcon) (at->data, 1, at->num_elements, buf))
|| (-1 == SLang_push_value (new_data_type, buf)))
status = -1;
SLang_free_array (at);
return status;
}
/* The offset for the index i_0,i_1,...i_{N-1} is
* i_0*W_0 + i_1*W_1 + ... i_{N-1}*W{N-1}
* where W_j = d_{j+1}d_{j+2}...d_{N-1}
* and d_k is the number of elements of the kth dimension.
*
* For a specified value of k, we
* So, summing over all elements in the kth dimension of the array
* means using the set of offsets given by
*
* i_k*W_k + sum(j!=k) i_j*W_j.
*
* So, we want to loop of all dimensions except for the kth using an
* offset given by sum(j!=k)i_jW_j, and an increment W_k between elements.
*/
wk = 1;
i = old_num_dims;
while (i != 0)
{
i--;
w[i] = wk;
wk *= old_dims[i];
}
wk = w[k];
/* Now set up the sub array */
j = 0;
for (i = 0; i < old_num_dims; i++)
{
if (i == (unsigned int) k)
continue;
sub_dims[j] = old_dims[i];
w[j] = w[i];
tmp_dims[j] = 0;
j++;
}
sub_num_dims = old_num_dims - 1;
if (use_contraction)
new_at = SLang_create_array1 (new_data_type, 0, NULL, sub_dims, sub_num_dims, 1);
else
new_at = SLang_create_array1 (new_data_type, 0, NULL, old_dims, old_num_dims, 1);
if (new_at == NULL)
{
SLang_free_array (at);
return -1;
}
new_data = (char *)new_at->data;
old_data = (char *)at->data;
old_sizeof_type = at->sizeof_type;
new_sizeof_type = new_at->sizeof_type;
dims_k = old_dims[k] * wk;
/* Skip this for cases such as sum(Double_Type[0,0], 1). Otherwise,
* (*fcon) will write to new_data, which has no length
*/
if (new_at->num_elements) do
{
size_t offset = 0;
int status;
for (i = 0; i < sub_num_dims; i++)
offset += w[i] * tmp_dims[i];
if (use_contraction)
{
status = (*fcon) ((VOID_STAR)(old_data + offset*old_sizeof_type), wk,
dims_k, (VOID_STAR) new_data);
new_data += new_sizeof_type;
}
else
{
status = (*fmap) (old_data_type, (VOID_STAR) (old_data + offset*old_sizeof_type),
wk, dims_k,
new_data_type, (VOID_STAR) (new_data + offset*new_sizeof_type),
clientdata);
}
if (status == -1)
{
SLang_free_array (new_at);
SLang_free_array (at);
return -1;
}
}
while (-1 != _pSLarray_next_index (tmp_dims, sub_dims, sub_num_dims));
SLang_free_array (at);
return SLang_push_array (new_at, 1);
}
