static int is_numeric_intrinsic (void)
{
int type;
if (-1 == (type = SLang_peek_at_stack1 ()))
return -1;
(void) SLdo_pop ();
return is_numeric ((SLtype) type);
}
static int pop_array_or_scalar (Array_Or_Scalar_Type *ast)
{
SLang_Array_Type *at;
ast->at = NULL;
ast->inc = 0;
ast->num = 1;
switch (SLang_peek_at_stack1 ())
{
case -1:
return -1;
case SLANG_FLOAT_TYPE:
ast->is_float = 1;
if (SLang_peek_at_stack () == SLANG_ARRAY_TYPE)
{
if (-1 == SLang_pop_array_of_type (&at, SLANG_FLOAT_TYPE))
return -1;
ast->fptr = (float *) at->data;
ast->inc = 1;
ast->num = at->num_elements;
ast->at = at;
return 0;
}
ast->fptr = &ast->f;
if (-1 == SLang_pop_float (ast->fptr))
return -1;
return 0;
default:
ast->is_float = 0;
if (SLang_peek_at_stack () == SLANG_ARRAY_TYPE)
{
if (-1 == SLang_pop_array_of_type (&at, SLANG_DOUBLE_TYPE))
return -1;
ast->dptr = (double *) at->data;
ast->inc = 1;
ast->num = at->num_elements;
ast->at = at;
return 0;
}
ast->dptr = &ast->d;
if (-1 == SLang_pop_double (ast->dptr))
return -1;
return 0;
}
}
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 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);
}
/* This routines takes two arrays A_i..j and B_j..k and produces a third
* via C_i..k = A_i..j B_j..k.
*
* If A is a vector, and B is a 2-d matrix, then regard A as a 2-d matrix
* with 1-column.
*/
static void do_inner_product (void)
{
SLang_Array_Type *a, *b, *c;
void (*fun)(SLang_Array_Type *, SLang_Array_Type *, SLang_Array_Type *,
unsigned int, unsigned int, unsigned int, unsigned int,
unsigned int);
SLtype c_type;
SLindex_Type dims[SLARRAY_MAX_DIMS];
int status;
unsigned int a_loops, b_loops, b_inc, a_stride;
int ai_dims, i, j;
unsigned int num_dims, a_num_dims, b_num_dims;
int ai, bi;
/* The result of a inner_product will be either a float, double, or
* a complex number.
*
* If an integer array is used, it will be promoted to a float.
*/
switch (SLang_peek_at_stack1 ())
{
case SLANG_DOUBLE_TYPE:
if (-1 == SLang_pop_array_of_type (&b, SLANG_DOUBLE_TYPE))
return;
break;
#if SLANG_HAS_COMPLEX
case SLANG_COMPLEX_TYPE:
if (-1 == SLang_pop_array_of_type (&b, SLANG_COMPLEX_TYPE))
return;
break;
#endif
case SLANG_FLOAT_TYPE:
default:
if (-1 == SLang_pop_array_of_type (&b, SLANG_FLOAT_TYPE))
return;
break;
}
switch (SLang_peek_at_stack1 ())
{
case SLANG_DOUBLE_TYPE:
status = SLang_pop_array_of_type (&a, SLANG_DOUBLE_TYPE);
break;
#if SLANG_HAS_COMPLEX
case SLANG_COMPLEX_TYPE:
status = SLang_pop_array_of_type (&a, SLANG_COMPLEX_TYPE);
break;
#endif
case SLANG_FLOAT_TYPE:
default:
status = SLang_pop_array_of_type (&a, SLANG_FLOAT_TYPE);
break;
}
if (status == -1)
{
SLang_free_array (b);
return;
}
ai = -1; /* last index of a */
bi = 0; /* first index of b */
if ((-1 == get_inner_product_parms (a, &ai, &a_loops, &a_stride))
|| (-1 == get_inner_product_parms (b, &bi, &b_loops, &b_inc)))
{
_pSLang_verror (SL_TYPE_MISMATCH, "Array dimensions are not compatible for inner-product");
goto free_and_return;
}
a_num_dims = a->num_dims;
b_num_dims = b->num_dims;
/* Coerse a 1-d vector to 2-d */
if ((a_num_dims == 1)
&& (b_num_dims == 2)
&& (a->num_elements))
{
a_num_dims = 2;
ai = 1;
a_loops = a->num_elements;
a_stride = 1;
}
if ((ai_dims = a->dims[ai]) != b->dims[bi])
{
_pSLang_verror (SL_TYPE_MISMATCH, "Array dimensions are not compatible for inner-product");
goto free_and_return;
}
num_dims = a_num_dims + b_num_dims - 2;
if (num_dims > SLARRAY_MAX_DIMS)
{
_pSLang_verror (SL_NOT_IMPLEMENTED,
"Inner-product result exceeds maximum allowed dimensions");
goto free_and_return;
}
if (num_dims)
{
j = 0;
for (i = 0; i < (int)a_num_dims; i++)
if (i != ai) dims [j++] = a->dims[i];
for (i = 0; i < (int)b_num_dims; i++)
if (i != bi) dims [j++] = b->dims[i];
}
else
{
/* a scalar */
num_dims = 1;
dims[0] = 1;
}
c_type = 0; fun = NULL;
switch (a->data_type)
{
case SLANG_FLOAT_TYPE:
switch (b->data_type)
{
case SLANG_FLOAT_TYPE:
c_type = SLANG_FLOAT_TYPE;
fun = innerprod_float_float;
break;
case SLANG_DOUBLE_TYPE:
c_type = SLANG_DOUBLE_TYPE;
fun = innerprod_float_double;
break;
#if SLANG_HAS_COMPLEX
case SLANG_COMPLEX_TYPE:
c_type = SLANG_COMPLEX_TYPE;
fun = innerprod_float_complex;
break;
#endif
}
break;
case SLANG_DOUBLE_TYPE:
switch (b->data_type)
{
case SLANG_FLOAT_TYPE:
c_type = SLANG_DOUBLE_TYPE;
fun = innerprod_double_float;
break;
case SLANG_DOUBLE_TYPE:
c_type = SLANG_DOUBLE_TYPE;
fun = innerprod_double_double;
break;
#if SLANG_HAS_COMPLEX
case SLANG_COMPLEX_TYPE:
c_type = SLANG_COMPLEX_TYPE;
fun = innerprod_double_complex;
break;
#endif
}
break;
#if SLANG_HAS_COMPLEX
case SLANG_COMPLEX_TYPE:
c_type = SLANG_COMPLEX_TYPE;
switch (b->data_type)
{
case SLANG_FLOAT_TYPE:
fun = innerprod_complex_float;
break;
case SLANG_DOUBLE_TYPE:
fun = innerprod_complex_double;
break;
case SLANG_COMPLEX_TYPE:
fun = innerprod_complex_complex;
break;
}
break;
#endif
default:
break;
}
if (NULL == (c = SLang_create_array (c_type, 0, NULL, dims, num_dims)))
goto free_and_return;
(*fun)(a, b, c, a_loops, a_stride, b_loops, b_inc, ai_dims);
(void) SLang_push_array (c, 1);
/* drop */
free_and_return:
SLang_free_array (a);
SLang_free_array (b);
}
