/* Array manipulation routines for S-Lang */
/* Copyright (c) 1997 John E. Davis
* All rights reserved.
*
* You may distribute under the terms of either the GNU General Public
* License or the Perl Artistic License.
*/
#include "config.h"
#include "sl-feat.h"
#include <stdio.h>
#include <string.h>
#include <stdarg.h>
#include "slang.h"
#include "_slang.h"
typedef struct
{
int first_index;
int last_index;
int delta;
}
SLarray_Range_Array_Type;
/* Use SLang_pop_array when a linear array is required. */
static int pop_array (SLang_Array_Type **at_ptr, int convert_scalar)
{
SLang_Object_Type obj;
SLang_Array_Type *at;
int one = 1;
int type;
*at_ptr = NULL;
type = SLang_peek_at_stack ();
switch (type)
{
case -1:
return -1;
case SLANG_ARRAY_TYPE:
if (-1 == _SLang_pop_object_of_type (SLANG_ARRAY_TYPE, &obj))
return -1;
*at_ptr = (SLang_Array_Type *) obj.v.p_val;
return 0;
default:
if (convert_scalar == 0)
{
SLang_verror (SL_TYPE_MISMATCH, "Context requires an array. Scalar not converted");
return -1;
}
break;
}
if (NULL == (at = SLang_create_array ((unsigned char) type, 0, NULL, &one, 1)))
return -1;
if (-1 == at->cl->cl_apop ((unsigned char) type, at->data))
{
SLang_free_array (at);
return -1;
}
*at_ptr = at;
return 0;
}
static VOID_STAR linear_get_data_addr (SLang_Array_Type *at, int *dims)
{
unsigned int num_dims;
unsigned int ofs;
unsigned int i;
int *max_dims;
ofs = 0;
max_dims = at->dims;
num_dims = at->num_dims;
for (i = 0; i < num_dims; i++)
{
int d = dims[i];
/* check_index_ranges ensures that this operation is valid */
if (d < 0)
d = d + max_dims[i];
ofs = ofs * (unsigned int)max_dims [i] + (unsigned int) d;
}
return (VOID_STAR) ((char *)at->data + (ofs * at->sizeof_type));
}
static VOID_STAR get_data_addr (SLang_Array_Type *at, int *dims)
{
VOID_STAR data;
data = at->data;
if (data == NULL)
{
SLang_verror (SL_UNKNOWN_ERROR, "Array has no data");
return NULL;
}
data = (*at->index_fun) (at, dims);
if (data == NULL)
{
SLang_verror (SL_UNKNOWN_ERROR, "Unable to access array element");
return NULL;
}
return data;
}
static int destroy_element (SLang_Array_Type *at,
int *dims,
VOID_STAR data)
{
data = get_data_addr (at, dims);
if (data == NULL)
return -1;
/* This function should only get called for arrays that have
* pointer elements. Do not call the destroy method if the element
* is NULL.
*/
if (NULL != *(VOID_STAR *)data)
{
(*at->cl->cl_destroy) (at->data_type, data);
*(VOID_STAR *) data = NULL;
}
return 0;
}
/* This function only gets called when a new array is created. Thus there
* is no need to destroy the object first.
*/
static int new_object_element (SLang_Array_Type *at,
int *dims,
VOID_STAR data)
{
data = get_data_addr (at, dims);
if (data == NULL)
return -1;
return (*at->cl->cl_init_array_object) (at->data_type, data);
}
static int next_index (int *dims, int *max_dims, unsigned int num_dims)
{
while (num_dims)
{
int dims_i;
num_dims--;
dims_i = dims [num_dims] + 1;
if (dims_i != (int) max_dims [num_dims])
{
dims [num_dims] = dims_i;
return 0;
}
dims [num_dims] = 0;
}
return -1;
}
static int do_method_for_all_elements (SLang_Array_Type *at,
int (*method)(SLang_Array_Type *,
int *,
VOID_STAR),
VOID_STAR client_data)
{
int dims [SLARRAY_MAX_DIMS];
int *max_dims;
unsigned int num_dims;
if (at->num_elements == 0)
return 0;
max_dims = at->dims;
num_dims = at->num_dims;
SLMEMSET((char *)dims, 0, sizeof(dims));
do
{
if (-1 == (*method) (at, dims, client_data))
return -1;
}
while (0 == next_index (dims, max_dims, num_dims));
return 0;
}
void SLang_free_array (SLang_Array_Type *at)
{
VOID_STAR data;
unsigned int flags;
if (at == NULL) return;
if (at->num_refs > 1)
{
at->num_refs -= 1;
return;
}
data = at->data;
flags = at->flags;
if (flags & DATA_VALUE_IS_INTRINSIC)
return; /* not to be freed */
if (flags & DATA_VALUE_IS_POINTER)
(void) do_method_for_all_elements (at, destroy_element, NULL);
SLfree ((char *) data);
SLfree ((char *) at);
}
SLang_Array_Type *
SLang_create_array (unsigned char type, int read_only, VOID_STAR data,
int *dims, unsigned int num_dims)
{
SLang_Class_Type *cl;
unsigned int i;
SLang_Array_Type *at;
unsigned int num_elements;
unsigned int sizeof_type;
unsigned int size;
if (num_dims > SLARRAY_MAX_DIMS)
{
SLang_verror (SL_NOT_IMPLEMENTED, "%u dimensional arrays are not supported", num_dims);
return NULL;
}
for (i = 0; i < num_dims; i++)
{
if (dims[i] < 0)
{
SLang_verror (SL_INVALID_PARM, "Size of array dim %u is less than 0", i);
return NULL;
}
}
cl = _SLclass_get_class (type);
at = (SLang_Array_Type *) SLmalloc (sizeof(SLang_Array_Type));
if (at == NULL)
return NULL;
SLMEMSET ((char*) at, 0, sizeof(SLang_Array_Type));
at->data_type = type;
at->cl = cl;
at->num_dims = num_dims;
if (read_only) at->flags = DATA_VALUE_IS_READ_ONLY;
switch (cl->cl_class_type)
{
case SLANG_CLASS_TYPE_VECTOR:
case SLANG_CLASS_TYPE_SCALAR:
break;
default:
at->flags |= DATA_VALUE_IS_POINTER;
}
num_elements = 1;
for (i = 0; i < num_dims; i++)
{
at->dims [i] = dims[i];
num_elements = dims [i] * num_elements;
}
at->num_elements = num_elements;
at->index_fun = linear_get_data_addr;
at->sizeof_type = sizeof_type = cl->cl_sizeof_type;
if (data != NULL)
{
at->data = data;
return at;
}
size = num_elements * sizeof_type;
if (size == 0) size = 1;
if (NULL == (data = (VOID_STAR) SLmalloc (size)))
{
SLang_free_array (at);
return NULL;
}
SLMEMSET ((char *) data, 0, size);
at->data = data;
if ((cl->cl_init_array_object != NULL)
&& (-1 == do_method_for_all_elements (at, new_object_element, NULL)))
{
SLang_free_array (at);
return NULL;
}
return at;
}
int SLang_add_intrinsic_array (char *name,
unsigned char type,
int read_only,
VOID_STAR data,
unsigned int num_dims, ...)
{
va_list ap;
unsigned int i;
int dims[SLARRAY_MAX_DIMS];
SLang_Array_Type *at;
if ((num_dims > SLARRAY_MAX_DIMS)
|| (name == NULL)
|| (data == NULL))
{
SLang_verror (SL_INVALID_PARM, "Unable to create intrinsic array");
return -1;
}
va_start (ap, num_dims);
for (i = 0; i < num_dims; i++)
dims [i] = va_arg (ap, int);
va_end (ap);
at = SLang_create_array (type, read_only, data, dims, num_dims);
if (at == NULL)
return -1;
at->flags |= DATA_VALUE_IS_INTRINSIC;
/* Note: The variable that refers to the intrinsic array is regarded as
* read-only. That way, Array_Name = another_array; will fail.
*/
if (-1 == SLadd_intrinsic_variable (name, (VOID_STAR) at, SLANG_ARRAY_TYPE, 1))
{
SLang_free_array (at);
return -1;
}
return 0;
}
static int check_index_ranges (SLang_Array_Type *at,
int *dims,
unsigned int num_dims)
{
unsigned int i;
int *max_dims;
if (at->num_dims != num_dims)
{
SLang_verror (SL_TYPE_MISMATCH, "Expecting %u array indices", at->num_dims);
return -1;
}
max_dims = at->dims;
for (i = 0; i < num_dims; i++)
{
int d = dims[i];
/* This is to allow [-1] to refer to the end of the array. */
if (d < 0) d += max_dims[i];
if ((d < 0) || (d >= max_dims[i]))
{
SLang_verror (SL_INVALID_PARM,
"Array index number %u out of range (found %d, max is %d)",
i, dims[i], max_dims[i]);
return -1;
}
}
return 0;
}
static int pop_array_indices (int *dims, unsigned int num_dims)
{
unsigned int n;
int i;
if (num_dims > SLARRAY_MAX_DIMS)
{
SLang_verror (SL_INVALID_PARM, "Array size not supported");
return -1;
}
n = num_dims;
while (n != 0)
{
n--;
if (-1 == SLang_pop_integer (&i))
return -1;
dims[n] = i;
}
return 0;
}
int SLang_push_array (SLang_Array_Type *at, int free_on_error)
{
SLang_Object_Type obj;
if (at == NULL)
return _SLang_push_null (); /* Should this be an empty array?? */
at->num_refs += 1;
obj.data_type = SLANG_ARRAY_TYPE;
obj.v.p_val = (VOID_STAR) at;
if (0 == SLang_push (&obj))
return 0;
at->num_refs -= 1;
if (free_on_error) SLang_free_array (at);
return -1;
}
/* This function gets called via expressions such as Double_Type[10, 20];
*/
static int push_create_new_array (void)
{
unsigned int num_dims;
SLang_Array_Type *at;
unsigned char type;
int dims [SLARRAY_MAX_DIMS];
num_dims = (SLang_Num_Function_Args - 1);
if (-1 == _SLang_pop_datatype (&type))
return -1;
if (-1 == pop_array_indices (dims, num_dims))
return -1;
if (NULL == (at = SLang_create_array (type, 0, NULL, dims, num_dims)))
return -1;
return SLang_push_array (at, 1);
}
static int push_string_element (void)
{
char *s;
int i;
unsigned int len;
if (-1 == SLang_pop_slstring (&s))
return -1;
if (-1 == SLang_pop_integer (&i))
{
SLang_free_slstring (s);
return -1;
}
len = strlen (s);
if (i < 0) i = i + (int)len;
if ((unsigned int) i > len)
{
SLang_verror (SL_INVALID_PARM, "Index out of range for string");
SLang_free_slstring (s);
return -1;
}
i = s[(unsigned int) i];
SLang_free_slstring (s);
return SLang_push_integer (i);
}
static int push_element_at_addr (SLang_Array_Type *at,
VOID_STAR data)
{
SLang_Class_Type *cl;
cl = at->cl;
if ((at->flags & DATA_VALUE_IS_POINTER)
&& (*(VOID_STAR *) data == NULL))
{
SLang_verror (SL_VARIABLE_UNINITIALIZED,
"%s array has unitialized element", cl->cl_name);
return -1;
}
return (*cl->cl_apush)(at->data_type, data);
}
static int coerse_array_to_linear (SLang_Array_Type *at)
{
SLarray_Range_Array_Type *range;
int *data;
int xmin, dx;
unsigned int i, imax;
if (0 == (at->flags & DATA_VALUE_IS_RANGE))
return 0;
range = (SLarray_Range_Array_Type *) at->data;
xmin = range->first_index;
dx = range->delta;
imax = at->num_elements;
data = (int *) SLmalloc ((imax + 1) * sizeof (int));
if (data == NULL)
return -1;
for (i = 0; i < imax; i++)
{
data [i] = xmin;
xmin += dx;
}
SLfree ((char *) range);
at->data = (VOID_STAR) data;
at->flags &= ~DATA_VALUE_IS_RANGE;
at->index_fun = linear_get_data_addr;
return 0;
}
static void
free_index_objects (SLang_Object_Type *index_objs, unsigned int num_indices)
{
unsigned int i;
SLang_Object_Type *obj;
for (i = 0; i < num_indices; i++)
{
obj = index_objs + i;
if (obj->data_type != 0)
SLang_free_object (obj);
}
}
static int
pop_indices (SLang_Object_Type *index_objs, unsigned int num_indices,
int *is_index_array)
{
SLang_Array_Type *at;
SLang_Object_Type *obj;
unsigned int i;
SLMEMSET((char *) index_objs, 0, num_indices * sizeof (SLang_Object_Type));
*is_index_array = 0;
if (num_indices >= SLARRAY_MAX_DIMS)
{
SLang_verror (SL_INVALID_PARM, "too many indices for array");
return -1;
}
i = num_indices;
while (i != 0)
{
i--;
obj = index_objs + i;
if (-1 == SLang_pop (obj))
goto return_error;
switch (obj->data_type)
{
case SLANG_INT_TYPE:
break;
case SLANG_ARRAY_TYPE:
at = obj->v.array_val;
if (at->data_type != SLANG_INT_TYPE)
{
SLang_verror (SL_TYPE_MISMATCH, "index array must be of integer type");
goto return_error;
}
/* We only allow 1-d index arrays unless there is only one
* array index and that one must be a 2-d array of indices
*/
if (at->num_dims == 1)
break;
if ((num_indices == 1) && (at->num_dims == 2))
*is_index_array = 1;
else
{
SLang_verror (SL_INVALID_PARM, "expecting a 1-d index array");
goto return_error;
}
break;
default:
SLang_verror (SL_TYPE_MISMATCH,
"Expecting an integer array index, found %s",
SLclass_get_datatype_name (obj->data_type));
goto return_error;
}
}
return 0;
return_error:
free_index_objects (index_objs, num_indices);
return -1;
}
/* Here ind_at is a linear 2-d array of indices */
static int
check_index_array_ranges (SLang_Array_Type *at, SLang_Array_Type *ind_at)
{
int *indices, *indices_max;
unsigned int num_dims;
num_dims = at->num_dims;
if ((int)num_dims != ind_at->dims[1])
{
SLang_verror (SL_INVALID_PARM, "index-array size is incorrect");
return -1;
}
indices = (int *) ind_at->data;
indices_max = indices + ind_at->num_elements;
while (indices < indices_max)
{
if (-1 == check_index_ranges (at, indices, at->num_dims))
return -1;
indices += num_dims;
}
return 0;
}
static int
aget_transfer_element (SLang_Array_Type *at, int *indices,
VOID_STAR new_data, unsigned int sizeof_type, int is_ptr)
{
VOID_STAR at_data;
if (NULL == (at_data = get_data_addr (at, indices)))
return -1;
if (is_ptr == 0)
SLMEMCPY ((char *) new_data, (char *)at_data, sizeof_type);
else if (*(VOID_STAR *) at_data == NULL)
*(VOID_STAR *) new_data = NULL;
else
{
SLang_Class_Type *cl = at->cl;
unsigned char data_type = at->data_type;
if (-1 == cl->cl_acopy (data_type, at_data, new_data))
return -1;
}
return 0;
}
/* Here the ind_at index-array is a 2-d array of indices. This function
* creates a 1-d array of made up of values of 'at' at the locations
* specified by the indices. The result is pushed.
*/
static int
aget_from_index_array (SLang_Array_Type *at,
SLang_Array_Type *ind_at)
{
SLang_Array_Type *new_at;
unsigned int num_dims;
int *indices, *indices_max;
unsigned char *new_data;
unsigned int sizeof_type;
int is_ptr;
if (-1 == coerse_array_to_linear (ind_at))
return -1;
if (-1 == check_index_array_ranges (at, ind_at))
return -1;
if (NULL == (new_at = SLang_create_array (at->data_type, 0, NULL, ind_at->dims, 1)))
return -1;
/* Since the index array is linear, I can address it directly */
indices = (int *) ind_at->data;
indices_max = indices + ind_at->num_elements;
num_dims = at->num_dims;
new_data = (unsigned char *) new_at->data;
sizeof_type = new_at->sizeof_type;
is_ptr = (new_at->flags & DATA_VALUE_IS_POINTER);
while (indices < indices_max)
{
if (-1 == aget_transfer_element (at, indices, (VOID_STAR)new_data, sizeof_type, is_ptr))
{
SLang_free_array (new_at);
return -1;
}
new_data += sizeof_type;
indices += num_dims;
}
return SLang_push_array (new_at, 1);
}
/* This is extremely ugly. It is due to the fact that the index_objects
* may contain ranges. This is a utility function for the aget/aput
* routines
*/
static int
convert_nasty_index_objs (SLang_Array_Type *at,
SLang_Object_Type *index_objs,
unsigned int num_indices,
int **index_data,
int *range_buf, int *range_delta_buf,
int *max_dims,
unsigned int *num_elements,
int *is_array)
{
unsigned int i, total_num_elements;
SLang_Array_Type *ind_at;
if (num_indices != at->num_dims)
{
SLang_verror (SL_INVALID_PARM, "Array requires %u indices", at->num_dims);
return -1;
}
*is_array = 0;
total_num_elements = 1;
for (i = 0; i < num_indices; i++)
{
int max_index, min_index;
SLang_Object_Type *obj;
int at_dims_i;
at_dims_i = at->dims[i];
obj = index_objs + i;
range_delta_buf [i] = 0;
if (obj->data_type == SLANG_INT_TYPE)
{
range_buf [i] = min_index = max_index = obj->v.i_val;
max_dims [i] = 1;
index_data[i] = range_buf + i;
}
else
{
*is_array = 1;
ind_at = obj->v.array_val;
if (ind_at->flags & DATA_VALUE_IS_RANGE)
{
SLarray_Range_Array_Type *r;
int delta;
int first_index, last_index;
r = (SLarray_Range_Array_Type *) ind_at->data;
/* Map first/last index to positive values such that
* [-1] will index last element of array.
*/
if ((first_index = r->first_index) < 0)
first_index = at_dims_i - ((-first_index) % at_dims_i);
if ((last_index = r->last_index) < 0)
last_index = at_dims_i - ((-last_index) % at_dims_i);
delta = r->delta;
range_delta_buf [i] = delta;
range_buf[i] = first_index;
if (delta < 0)
min_index = first_index % (-delta);
else
{
min_index = first_index;
while (first_index + delta <= last_index)
first_index += delta;
}
max_index = first_index;
max_dims [i] = 1 + (max_index - min_index) / abs(delta);
}
else
{
int *tmp, *tmp_max;
if (0 == (max_dims[i] = ind_at->num_elements))
{
total_num_elements = 0;
break;
}
tmp = (int *) ind_at->data;
tmp_max = tmp + ind_at->num_elements;
index_data [i] = tmp;
min_index = max_index = *tmp;
while (tmp < tmp_max)
{
if (max_index > *tmp)
max_index = *tmp;
if (min_index < *tmp)
min_index = *tmp;
tmp++;
}
}
}
if (max_index < 0)
max_index += at_dims_i;
if (min_index < 0)
min_index += at_dims_i;
if ((min_index < 0) || (min_index >= at_dims_i)
|| (max_index < 0) || (max_index >= at_dims_i))
{
SLang_verror (SL_INVALID_PARM, "Array index %u out of range", i);
return -1;
}
total_num_elements = total_num_elements * max_dims[i];
}
*num_elements = total_num_elements;
return 0;
}
/* This routine pushes a 1-d vector of values from 'at' indexed by
* the objects 'index_objs'. These objects can either be integers or
* 1-d integer arrays. The fact that the 1-d arrays can be ranges
* makes this look ugly.
*/
static int
aget_from_indices (SLang_Array_Type *at,
SLang_Object_Type *index_objs, unsigned int num_indices)
{
int *index_data [SLARRAY_MAX_DIMS];
int range_buf [SLARRAY_MAX_DIMS];
int range_delta_buf [SLARRAY_MAX_DIMS];
int max_dims [SLARRAY_MAX_DIMS];
unsigned int i, num_elements;
SLang_Array_Type *new_at;
int map_indices[SLARRAY_MAX_DIMS];
int indices [SLARRAY_MAX_DIMS];
unsigned int sizeof_type;
int is_ptr, ret, is_array;
char *new_data;
SLang_Class_Type *cl;
if (-1 == convert_nasty_index_objs (at, index_objs, num_indices,
index_data, range_buf, range_delta_buf,
max_dims, &num_elements, &is_array))
return -1;
cl = _SLclass_get_class (at->data_type);
if ((is_array == 0) && (num_elements == 1))
{
new_data = (char *)cl->cl_transfer_buf;
new_at = NULL;
}
else
{
int i_num_elements = (int)num_elements;
new_at = SLang_create_array (at->data_type, 0, NULL, &i_num_elements, 1);
if (NULL == new_at)
return -1;
if (num_elements == 0)
return SLang_push_array (new_at, 1);
new_data = (char *)new_at->data;
}
sizeof_type = at->sizeof_type;
is_ptr = (at->flags & DATA_VALUE_IS_POINTER);
SLMEMSET((char *) map_indices, 0, sizeof(map_indices));
do
{
for (i = 0; i < num_indices; i++)
{
int j;
j = map_indices[i];
if (0 != range_delta_buf[i])
indices[i] = range_buf[i] + j * range_delta_buf[i];
else
indices[i] = index_data [i][j];
}
if (-1 == aget_transfer_element (at, indices, (VOID_STAR)new_data, sizeof_type, is_ptr))
{
SLang_free_array (new_at);
return -1;
}
new_data += sizeof_type;
}
while (0 == next_index (map_indices, max_dims, num_indices));
if (new_at != NULL)
return SLang_push_array (new_at, 1);
/* Here new_data is a whole new copy, so free it after the push */
new_data -= sizeof_type;
ret = (*cl->cl_apush) (at->data_type, (VOID_STAR)new_data);
(*cl->cl_adestroy) (at->data_type, (VOID_STAR)new_data);
return ret;
}
/* ARRAY[i, j, k] generates code: __args i j ...k ARRAY __aput/__aget
* Here i, j, ... k may be a mixture of integers and 1-d arrays, or
* a single 2-d array of indices. The 2-d index array is generated by the
* 'where' function.
*
* If ARRAY is of type DataType, then this function will create an array of
* the appropriate type. In that case, the indices i, j, ..., k must be
* integers.
*/
int _SLarray_aget (void)
{
unsigned int num_indices;
SLang_Array_Type *at;
SLang_Object_Type index_objs [SLARRAY_MAX_DIMS];
int ret;
int is_index_array;
unsigned int i;
ret = -1;
num_indices = (SLang_Num_Function_Args - 1);
switch (SLang_peek_at_stack ())
{
case SLANG_DATATYPE_TYPE:
return push_create_new_array ();
case SLANG_STRING_TYPE:
if (1 == num_indices)
return push_string_element ();
/* drop */
default:
if (-1 == pop_array (&at, 1))
return -1;
}
if (-1 == pop_indices (index_objs, num_indices, &is_index_array))
{
SLang_free_array (at);
return -1;
}
if (is_index_array == 0)
ret = aget_from_indices (at, index_objs, num_indices);
else
ret = aget_from_index_array (at, index_objs[0].v.array_val);
SLang_free_array (at);
for (i = 0; i < num_indices; i++)
SLang_free_object (index_objs + i);
return ret;
}
static int
transfer_n_ptr_elements (SLang_Array_Type *at, char *dest_data, char *src_data, unsigned int n)
{
unsigned char data_type = at->data_type;
SLang_Class_Type *cl = at->cl;
unsigned int sizeof_type = at->sizeof_type;
while (n != 0)
{
if (*(VOID_STAR *) dest_data != NULL)
{
(*cl->cl_destroy) (data_type, (VOID_STAR)dest_data);
*(VOID_STAR *) dest_data = NULL;
}
if (*(VOID_STAR *) src_data == NULL)
*(VOID_STAR *) dest_data = NULL;
else
{
if (-1 == (*cl->cl_acopy) (data_type, (VOID_STAR) src_data, (VOID_STAR) dest_data))
/* No need to destroy anything */
return -1;
}
src_data += sizeof_type;
dest_data += sizeof_type;
n--;
}
return 0;
}
static int
aput_transfer_element (SLang_Array_Type *at, int *indices,
VOID_STAR data_to_put, unsigned int sizeof_type, int is_ptr)
{
char *at_data;
if (NULL == (at_data = (char *) get_data_addr (at, indices)))
return -1;
if (is_ptr == 0)
{
SLMEMCPY (at_data, data_to_put, sizeof_type);
return 0;
}
return transfer_n_ptr_elements (at, at_data, (char *)data_to_put, 1);
}
static int
aput_get_array_to_put (SLang_Class_Type *cl, unsigned int num_elements,
SLang_Array_Type **at_ptr, char **data_to_put, unsigned int *data_increment)
{
unsigned char data_type;
SLang_Array_Type *at;
*at_ptr = NULL;
data_type = cl->cl_data_type;
if (-1 == _SLclass_typecast (data_type, 1, 1))
return -1;
if ((data_type != SLANG_ARRAY_TYPE)
&& (SLANG_ARRAY_TYPE == SLang_peek_at_stack ()))
{
if (-1 == SLang_pop_array (&at, 0))
return -1;
if ((at->num_dims != 1)
|| (at->num_elements != num_elements))
{
SLang_verror (SL_TYPE_MISMATCH, "Array size is inappropriate for use with index-array");
SLang_free_array (at);
return -1;
}
*data_to_put = (char *) at->data;
*data_increment = at->sizeof_type;
*at_ptr = at;
return 0;
}
*data_increment = 0;
*data_to_put = (char *) cl->cl_transfer_buf;
if (-1 == (*cl->cl_apop)(data_type, (VOID_STAR) *data_to_put))
return -1;
return 0;
}
static int
aput_from_indices (SLang_Array_Type *at,
SLang_Object_Type *index_objs, unsigned int num_indices)
{
int *index_data [SLARRAY_MAX_DIMS];
int range_buf [SLARRAY_MAX_DIMS];
int range_delta_buf [SLARRAY_MAX_DIMS];
int max_dims [SLARRAY_MAX_DIMS];
unsigned int i, num_elements;
SLang_Array_Type *bt;
int map_indices[SLARRAY_MAX_DIMS];
int indices [SLARRAY_MAX_DIMS];
unsigned int sizeof_type;
int is_ptr, is_array, ret;
char *data_to_put;
unsigned int data_increment;
SLang_Class_Type *cl;
if (-1 == convert_nasty_index_objs (at, index_objs, num_indices,
index_data, range_buf, range_delta_buf,
max_dims, &num_elements, &is_array))
return -1;
cl = at->cl;
if (-1 == aput_get_array_to_put (cl, num_elements,
&bt, &data_to_put, &data_increment))
return -1;
sizeof_type = at->sizeof_type;
is_ptr = (at->flags & DATA_VALUE_IS_POINTER);
ret = -1;
SLMEMSET((char *) map_indices, 0, sizeof(map_indices));
do
{
for (i = 0; i < num_indices; i++)
{
int j;
j = map_indices[i];
if (0 != range_delta_buf[i])
indices[i] = range_buf[i] + j * range_delta_buf[i];
else
indices[i] = index_data [i][j];
}
if (-1 == aput_transfer_element (at, indices, (VOID_STAR)data_to_put, sizeof_type, is_ptr))
goto return_error;
data_to_put += data_increment;
}
while (0 == next_index (map_indices, max_dims, num_indices));
ret = 0;
/* drop */
return_error:
if (bt == NULL)
{
if (is_ptr)
(*cl->cl_destroy) (cl->cl_data_type, (VOID_STAR) data_to_put);
}
else SLang_free_array (bt);
return ret;
}
static int
aput_from_index_array (SLang_Array_Type *at, SLang_Array_Type *ind_at)
{
unsigned int num_dims;
int *indices, *indices_max;
unsigned int sizeof_type;
char *data_to_put;
unsigned int data_increment;
int is_ptr;
SLang_Array_Type *bt;
SLang_Class_Type *cl;
int ret;
if (-1 == coerse_array_to_linear (ind_at))
return -1;
if (-1 == check_index_array_ranges (at, ind_at))
return -1;
sizeof_type = at->sizeof_type;
cl = at->cl;
if (-1 == aput_get_array_to_put (cl, ind_at->num_elements,
&bt, &data_to_put, &data_increment))
return -1;
/* Since the index array is linear, I can address it directly */
indices = (int *) ind_at->data;
indices_max = indices + ind_at->num_elements;
is_ptr = (at->flags & DATA_VALUE_IS_POINTER);
num_dims = at->num_dims;
ret = -1;
while (indices < indices_max)
{
if (-1 == aput_transfer_element (at, indices, (VOID_STAR)data_to_put, sizeof_type, is_ptr))
goto return_error;
indices += num_dims;
data_to_put += data_increment;
}
ret = 0;
/* Drop */
return_error:
if (bt == NULL)
{
if (is_ptr)
(*cl->cl_destroy) (cl->cl_data_type, (VOID_STAR)data_to_put);
}
else SLang_free_array (bt);
return ret;
}
/* ARRAY[i, j, k] = generates code: __args i j k ARRAY __aput
*/
int _SLarray_aput (void)
{
unsigned int num_indices;
SLang_Array_Type *at;
SLang_Object_Type index_objs [SLARRAY_MAX_DIMS];
int ret;
int is_index_array;
ret = -1;
num_indices = (SLang_Num_Function_Args - 1);
if (-1 == SLang_pop_array (&at, 0))
return -1;
if (at->flags & DATA_VALUE_IS_READ_ONLY)
{
SLang_verror (SL_READONLY_ERROR, "%s Array is read-only",
SLclass_get_datatype_name (at->data_type));
SLang_free_array (at);
return -1;
}
if (-1 == pop_indices (index_objs, num_indices, &is_index_array))
{
SLang_free_array (at);
return -1;
}
if (is_index_array == 0)
ret = aput_from_indices (at, index_objs, num_indices);
else
ret = aput_from_index_array (at, index_objs[0].v.array_val);
SLang_free_array (at);
free_index_objects (index_objs, num_indices);
return ret;
}
/* This is for 1-d matrices only. It is used by the sort function */
static int push_element_at_index (SLang_Array_Type *at, int indx)
{
VOID_STAR data;
if (NULL == (data = get_data_addr (at, &indx)))
return -1;
return push_element_at_addr (at, (VOID_STAR) data);
}
static void sort_array (void)
{
SLang_Array_Type *at_str, *at_int;
SLang_Name_Type *entry;
int l, j, ir, i, n, cmp;
int *ra, rra;
int dims[1];
char *f;
if (-1 == SLang_pop_slstring (&f))
return;
at_int = at_str = NULL;
if (NULL == (entry = SLang_get_function (f)))
{
SLang_verror (SL_UNDEFINED_NAME, "Sort function %s is undefined", f);
goto return_error;
}
if (-1 == SLang_pop_array (&at_str, 0))
goto return_error;
if (at_str->flags & DATA_VALUE_IS_READ_ONLY)
{
SLang_Error = SL_READONLY_ERROR;
goto return_error;
}
n = at_str->num_elements;
if (at_str->num_dims != 1)
{
SLang_verror (SL_INVALID_PARM, "sort is restricted to 1 dim arrays");
goto return_error;
}
dims [0] = n;
if (NULL == (at_int = SLang_create_array (SLANG_INT_TYPE, 0, NULL, dims, 1)))
goto return_error;
ra = (int *) at_int->data;
ra--;
for (i = 1; i <= n; i++) ra[i] = i;
/* heap sort from adapted from numerical recipes */
l = 1 + n / 2;
ir = n;
while (1)
{
if (l > 1) rra = ra[--l];
else
{
rra = ra[ir];
ra[ir] = ra[1];
if (--ir <= 1)
{
ra[1] = rra;
for (i = 1; i <= n; i++) ra[i] -= 1;
if (-1 == SLang_push_array (at_int, 0))
goto return_error;
at_int = NULL;
/* Break to free the other user object. */
break;
}
}
i = l;
j = 2 * l;
while (j <= ir)
{
if (j < ir)
{
push_element_at_index (at_str, ra[j] - 1);
push_element_at_index (at_str, ra[j + 1] - 1);
SLexecute_function (entry);
if (-1 == SLang_pop_integer(&cmp))
goto return_error;
if (cmp < 0) j++;
}
push_element_at_index (at_str, rra - 1);
push_element_at_index (at_str, ra[j] - 1);
SLexecute_function (entry);
if (SLang_pop_integer(&cmp))
goto return_error;
if (cmp < 0)
{
ra[i] = ra[j];
i = j;
j += j;
}
else j = ir + 1;
}
ra[i] = rra;
}
return_error:
SLang_free_array (at_str);
SLang_free_array (at_int);
SLang_free_slstring (f);
}
static void init_char_array (void)
{
SLang_Array_Type *at;
char *s;
unsigned int n, ndim;
if (SLang_pop_slstring (&s)) return;
if (-1 == SLang_pop_array (&at, 0))
goto free_and_return;
if (at->data_type != SLANG_CHAR_TYPE)
{
SLang_doerror("Operation requires character array");
goto free_and_return;
}
n = strlen (s);
ndim = at->num_elements;
if (n > ndim)
{
SLang_doerror("String too big to init array");
goto free_and_return;
}
strncpy((char *) at->data, s, ndim);
/* drop */
free_and_return:
SLang_free_array (at);
SLang_free_slstring (s);
}
static void array_info (void)
{
SLang_Array_Type *at, *bt;
int num_dims;
if (-1 == pop_array (&at, 1))
return;
num_dims = (int)at->num_dims;
if (NULL != (bt = SLang_create_array (SLANG_INT_TYPE, 0, NULL, &num_dims, 1)))
{
int *bdata;
int i;
int *a_dims;
a_dims = at->dims;
bdata = (int *) bt->data;
for (i = 0; i < num_dims; i++) bdata [i] = a_dims [i];
if (0 == SLang_push_array (bt, 1))
{
(void) SLang_push_integer (at->num_dims);
(void) _SLang_push_datatype (at->data_type);
}
}
SLang_free_array (at);
}
static VOID_STAR range_get_data_addr (SLang_Array_Type *at, int *dims)
{
static int value;
SLarray_Range_Array_Type *r;
int d;
d = *dims;
r = (SLarray_Range_Array_Type *)at->data;
if (d < 0)
d += at->dims[0];
value = r->first_index + d * r->delta;
return (VOID_STAR) &value;
}
static SLang_Array_Type *inline_implicit_int_array (int *xminptr, int *xmaxptr, int *dxptr)
{
int delta;
SLang_Array_Type *at;
int dims;
SLarray_Range_Array_Type *data;
if (dxptr == NULL) delta = 1;
else delta = *dxptr;
if (delta == 0)
{
SLang_verror (SL_INVALID_PARM, "range-array increment must be non-zero");
return NULL;
}
data = (SLarray_Range_Array_Type *) SLmalloc (sizeof (SLarray_Range_Array_Type));
if (data == NULL)
return NULL;
SLMEMSET((char *) data, 0, sizeof (SLarray_Range_Array_Type));
data->delta = delta;
dims = 0;
if (xminptr != NULL)
data->first_index = *xminptr;
else
data->first_index = 0;
if (xmaxptr != NULL)
data->last_index = *xmaxptr;
else
data->last_index = -1;
if ((xminptr != NULL) && (xmaxptr != NULL))
{
int idims;
idims = 1 + (data->last_index - data->first_index) / delta;
if (idims > 0)
dims = idims;
}
if (NULL == (at = SLang_create_array (SLANG_INT_TYPE, 0, (VOID_STAR) data, &dims, 1)))
return NULL;
at->index_fun = range_get_data_addr;
at->flags |= DATA_VALUE_IS_RANGE;
return at;
}
#if SLANG_HAS_FLOAT
static SLang_Array_Type *inline_implicit_double_array (double *xminptr, double *xmaxptr, double *dxptr)
{
int n, i;
double *ptr;
SLang_Array_Type *at;
int dims;
double xmin, xmax, dx;
if ((xminptr == NULL) || (xmaxptr == NULL))
{
SLang_verror (SL_INVALID_PARM, "range-array has unknown size");
return NULL;
}
xmin = *xminptr;
xmax = *xmaxptr;
if (dxptr == NULL) dx = 1.0;
else dx = *dxptr;
if (dx == 0.0)
{
SLang_doerror ("range-array increment must be non-zero");
return NULL;
}
n = (int)(1.0 + ((xmax - xmin) / dx));
if (n < 1)
{
SLang_verror (SL_INVALID_PARM, "inline-array size is 0");
return NULL;
}
dims = n;
if (NULL == (at = SLang_create_array (SLANG_DOUBLE_TYPE, 0, NULL, &dims, 1)))
return NULL;
ptr = (double *) at->data;
for (i = 0; i < n; i++)
{
ptr[i] = xmin;
xmin += dx;
}
return at;
}
#endif
int _SLarray_inline_implicit_array (void)
{
int int_vals[3];
#if SLANG_HAS_FLOAT
double double_vals[3];
int is_int;
#endif
int has_vals[3];
unsigned int i, count;
SLang_Array_Type *at;
count = SLang_Num_Function_Args;
if (count == 2)
has_vals [2] = 0;
else if (count != 3)
{
SLang_doerror ("wrong number of arguments to __implicit_inline_array");
return -1;
}
#if SLANG_HAS_FLOAT
is_int = 1;
#endif
i = count;
while (i)
{
i--;
if (SLANG_NULL_TYPE == SLang_peek_at_stack ())
{
has_vals[i] = 0;
(void) SLdo_pop ();
}
else
{
#if SLANG_HAS_FLOAT
int convert;
if (-1 == SLang_pop_double (double_vals + i,
&convert,
int_vals + i))
return -1;
if (convert == 0) is_int = 0;
#else
if (-1 == SLang_pop_integer (int_vals + i))
return -1;
#endif
has_vals [i] = 1;
}
}
#if SLANG_HAS_FLOAT
if (is_int == 0)
at = inline_implicit_double_array ((has_vals[0] ? &double_vals[0] : NULL),
(has_vals[1] ? &double_vals[1] : NULL),
(has_vals[2] ? &double_vals[2] : NULL));
else
#endif
at = inline_implicit_int_array ((has_vals[0] ? &int_vals[0] : NULL),
(has_vals[1] ? &int_vals[1] : NULL),
(has_vals[2] ? &int_vals[2] : NULL));
if (at == NULL)
return -1;
return SLang_push_array (at, 1);
}
static SLang_Array_Type *concat_arrays (unsigned int count)
{
SLang_Array_Type **arrays;
SLang_Array_Type *at, *bt;
unsigned int i;
int num_elements;
unsigned char type;
char *src_data, *dest_data;
int is_ptr;
unsigned int sizeof_type;
arrays = (SLang_Array_Type **)SLmalloc (count * sizeof (SLang_Array_Type *));
if (arrays == NULL)
{
SLdo_pop_n (count);
return NULL;
}
SLMEMSET((char *) arrays, 0, count * sizeof(SLang_Array_Type *));
at = NULL;
num_elements = 0;
i = count;
while (i != 0)
{
i--;
if (-1 == SLang_pop_array (&bt, 1))
goto free_and_return;
arrays[i] = bt;
num_elements += (int)bt->num_elements;
}
type = arrays[0]->data_type;
for (i = 1; i < count; i++)
{
SLang_Array_Type *ct;
bt = arrays[i];
if (type == bt->data_type)
continue;
if (1 != _SLarray_typecast (bt->data_type, (VOID_STAR) &bt, 1,
type, (VOID_STAR) &ct, 1))
goto free_and_return;
SLang_free_array (bt);
arrays [i] = ct;
}
if (NULL == (at = SLang_create_array (type, 0, NULL, &num_elements, 1)))
goto free_and_return;
is_ptr = (at->flags & DATA_VALUE_IS_POINTER);
sizeof_type = at->sizeof_type;
dest_data = (char *) at->data;
for (i = 0; i < count; i++)
{
bt = arrays[i];
src_data = (char *) bt->data;
num_elements = bt->num_elements;
if (is_ptr == 0)
SLMEMCPY(dest_data, src_data, num_elements * sizeof_type);
else
{
if (-1 == transfer_n_ptr_elements (bt, dest_data, src_data, num_elements))
{
SLang_free_array (at);
at = NULL;
goto free_and_return;
}
}
dest_data += num_elements * sizeof_type;
}
free_and_return:
for (i = 0; i < count; i++)
SLang_free_array (arrays[i]);
SLfree ((char *) arrays);
return at;
}
int _SLarray_inline_array (void)
{
SLang_Object_Type *obj;
unsigned char type, this_type;
unsigned int count;
SLang_Array_Type *at;
obj = _SLStack_Pointer;
count = SLang_Num_Function_Args;
type = 0;
while ((count > 0) && (--obj >= _SLRun_Stack))
{
this_type = obj->data_type;
if (type == 0)
type = this_type;
if ((type == this_type) || (type == SLANG_ARRAY_TYPE))
{
count--;
continue;
}
switch (this_type)
{
case SLANG_ARRAY_TYPE:
type = SLANG_ARRAY_TYPE;
break;
case SLANG_INT_TYPE:
switch (type)
{
#if SLANG_HAS_FLOAT
case SLANG_DOUBLE_TYPE:
break;
#endif
#if SLANG_HAS_COMPLEX
case SLANG_COMPLEX_TYPE:
break;
#endif
default:
goto type_mismatch;
}
break;
#if SLANG_HAS_FLOAT
case SLANG_DOUBLE_TYPE:
switch (type)
{
case SLANG_INT_TYPE:
type = SLANG_DOUBLE_TYPE;
break;
# if SLANG_HAS_COMPLEX
case SLANG_COMPLEX_TYPE:
break;
# endif
default:
goto type_mismatch;
}
break;
#endif
#if SLANG_HAS_COMPLEX
case SLANG_COMPLEX_TYPE:
switch (type)
{
case SLANG_INT_TYPE:
case SLANG_DOUBLE_TYPE:
type = SLANG_COMPLEX_TYPE;
break;
default:
goto type_mismatch;
}
break;
#endif
default:
type_mismatch:
_SLclass_type_mismatch_error (type, this_type);
return -1;
}
count--;
}
if (count != 0)
{
SLang_Error = SL_STACK_UNDERFLOW;
return -1;
}
count = SLang_Num_Function_Args;
if (count == 0)
{
SLang_verror (SL_NOT_IMPLEMENTED, "Empty inline-arrays not supported");
return -1;
}
if (type == SLANG_ARRAY_TYPE)
{
if (NULL == (at = concat_arrays (count)))
return -1;
}
else
{
SLang_Object_Type index_obj;
int icount = (int) count;
if (NULL == (at = SLang_create_array (type, 0, NULL, &icount, 1)))
return -1;
index_obj.data_type = SLANG_INT_TYPE;
while (count != 0)
{
count--;
index_obj.v.i_val = (int) count;
if (-1 == aput_from_indices (at, &index_obj, 1))
{
SLang_free_array (at);
SLdo_pop_n (count);
return -1;
}
}
}
return SLang_push_array (at, 1);
}
static int array_binary_op_result (int op, unsigned char a, unsigned char b,
unsigned char *c)
{
(void) op;
(void) a;
(void) b;
*c = SLANG_ARRAY_TYPE;
return 1;
}
static int array_binary_op (int op,
unsigned char a_type, VOID_STAR ap, unsigned int na,
unsigned char b_type, VOID_STAR bp, unsigned int nb,
VOID_STAR cp)
{
SLang_Array_Type *at, *bt, *ct;
unsigned int i, num_dims;
int (*binary_fun) (int,
unsigned char, VOID_STAR, unsigned int,
unsigned char, VOID_STAR, unsigned int,
VOID_STAR);
SLang_Class_Type *a_cl, *b_cl, *c_cl;
if (a_type == SLANG_ARRAY_TYPE)
{
if (na != 1)
{
SLang_verror (SL_NOT_IMPLEMENTED, "Binary operation on multiple arrays not implemented");
return -1;
}
at = *(SLang_Array_Type **) ap;
if (-1 == coerse_array_to_linear (at))
return -1;
ap = at->data;
a_type = at->data_type;
na = at->num_elements;
}
else
{
at = NULL;
}
if (b_type == SLANG_ARRAY_TYPE)
{
if (nb != 1)
{
SLang_verror (SL_NOT_IMPLEMENTED, "Binary operation on multiple arrays not implemented");
return -1;
}
bt = *(SLang_Array_Type **) bp;
if (-1 == coerse_array_to_linear (bt))
return -1;
bp = bt->data;
b_type = bt->data_type;
nb = bt->num_elements;
}
else
{
bt = NULL;
}
if ((at != NULL) && (bt != NULL))
{
num_dims = at->num_dims;
if (num_dims != bt->num_dims)
{
SLang_verror (SL_TYPE_MISMATCH, "Arrays must have same dim for binary operation");
return -1;
}
for (i = 0; i < num_dims; i++)
{
if (at->dims[i] != bt->dims[i])
{
SLang_verror (SL_TYPE_MISMATCH, "Arrays must be the same for binary operation");
return -1;
}
}
}
a_cl = _SLclass_get_class (a_type);
b_cl = _SLclass_get_class (b_type);
if (NULL == (binary_fun = _SLclass_get_binary_fun (op, a_cl, b_cl, &c_cl)))
return -1;
if (at != NULL) ct = at;
else ct = bt;
ct = SLang_create_array (c_cl->cl_data_type, 0, NULL, ct->dims, ct->num_dims);
if (ct == NULL)
return -1;
if (1 == (*binary_fun) (op, a_type, ap, na, b_type, bp, nb, ct->data))
{
*(SLang_Array_Type **) cp = ct;
ct->num_refs += 1;
return 1;
}
SLang_free_array (ct);
return -1;
}
static void array_where (void)
{
SLang_Array_Type *at, *bt;
int *a_data, *a_data_max, *b_data;
int dims[SLARRAY_MAX_DIMS];
unsigned int i, num_dims;
if (-1 == SLang_pop_array (&at, 1))
return;
bt = NULL;
if (at->data_type != SLANG_INT_TYPE)
{
int zero;
SLang_Array_Type *tmp_at;
tmp_at = at;
zero = 0;
if (1 != array_binary_op (SLANG_NE,
SLANG_ARRAY_TYPE, (VOID_STAR) &at, 1,
SLANG_INT_TYPE, (VOID_STAR) &zero, 1,
(VOID_STAR) &tmp_at))
goto return_error;
SLang_free_array (at);
at = tmp_at;
if (at->data_type != SLANG_INT_TYPE)
{
SLang_Error = SL_TYPE_MISMATCH;
goto return_error;
}
}
a_data = (int *) at->data;
a_data_max = a_data + at->num_elements;
i = 0;
while (a_data < a_data_max)
{
if (*a_data != 0) i++;
a_data++;
}
num_dims = at->num_dims;
dims [0] = (int)i;
dims [1] = (int) num_dims;
if (NULL == (bt = SLang_create_array (SLANG_INT_TYPE, 0, NULL, dims, 2)))
goto return_error;
SLMEMSET((char *) dims, 0, sizeof(dims));
a_data = (int *) at->data;
b_data = (int *) bt->data;
if (i) do
{
if (*a_data != 0)
{
for (i = 0; i < num_dims; i++)
b_data[i] = dims[i];
b_data += num_dims;
}
a_data++;
}
while (0 == next_index (dims, at->dims, num_dims));
if (-1 == SLang_push_array (bt, 0))
goto return_error;
SLang_free_array (at);
return;
return_error:
SLang_free_array (at);
SLang_free_array (bt);
}
static void array_reshape (void)
{
int *dims;
unsigned int i, num_dims;
unsigned int num_elements;
SLang_Array_Type *at, *ind_at;
if (-1 == SLang_pop_array (&ind_at, 1))
return;
if (-1 == SLang_pop_array (&at, 1))
return;
if ((ind_at->data_type != SLANG_INT_TYPE)
|| (ind_at->num_dims != 1))
{
SLang_verror (SL_TYPE_MISMATCH, "Expecting 1-d integer array");
SLang_free_array (ind_at);
SLang_free_array (at);
return;
}
num_dims = ind_at->num_elements;
dims = (int *) ind_at->data;
num_elements = 1;
for (i = 0; i < num_dims; i++)
{
int d = dims[i];
if (d < 0)
{
SLang_verror (SL_INVALID_PARM, "reshape: dimension is less then 0");
SLang_free_array (ind_at);
SLang_free_array (at);
return;
}
num_elements = (unsigned int) d * num_elements;
}
if ((num_elements != at->num_elements)
|| (num_dims > SLARRAY_MAX_DIMS))
{
SLang_verror (SL_INVALID_PARM, "Unable to reshape array to specified size");
SLang_free_array (ind_at);
SLang_free_array (at);
return;
}
for (i = 0; i < num_dims; i++)
at->dims [i] = dims[i];
while (i < SLARRAY_MAX_DIMS)
{
at->dims [i] = 1;
i++;
}
at->num_dims = num_dims;
SLang_free_array (ind_at);
SLang_free_array (at);
}
static SLang_Intrin_Fun_Type Array_Table [] =
{
MAKE_INTRINSIC("array_sort", sort_array, SLANG_VOID_TYPE, 0),
/* Prototype: Array array_sort (Array a, String f);
* @array_sort@ sorts the array @a@ into ascending order according to the
* function @f@ and returns an integer array that represents the result of the
* sort.
*
* The integer array returned by this function is simply an index that indicates the
* order of the sorted array. The input array @a@ is not changed. For example,
* if the input array consists of the three strings
* @ {"gamma", "alpha", "beta"}
* and the sort function @f@ is defined to be
* @ define f (a, b)
* @ { return strcmp (a, b); }
* then the index array will be returned as:
* @ {2, 0, 1}
*
* Note that the comparison cannot be an intrinsic function; it must be a
* S-Lang user defined function. The function takes two arguments
* and returns an integer that is less than zero if the first parameter is
* considered to be less than the second, zero if they are equal, and a
* value greater than zero if the first is greater than the second.
*/
MAKE_INTRINSIC("init_char_array", init_char_array, SLANG_VOID_TYPE, 0),
/* Prototype: Void init_char_array(Array_Type a, String s);
* This function may be used to initialize a character array. Here @a@
* is an array type character and @s@ is a string. This function simply
* sets the elements of the array @a@ to the corresponding characters of
* the string @s@. For example,
* @ variable a = Char_Type [10];
* @ init_char_array (a, "HelloWorld");
* creates an character array and initializes its elements to the
* characters in the string @"HelloWorld"@.
*
* Note: The character array must be large enough to hold all the
* characters of the initialization string.
* Related Functions: @strlen@, @strcat@
*/
MAKE_INTRINSIC("array_info", array_info, SLANG_VOID_TYPE, 0),
/* Prototype: Var array_info (Array a);
* This function returns information about the array @a@.
* It returns the data-type, number of dimensions, and the length of each
* dimension as integer array.
*/
MAKE_INTRINSIC("where", array_where, SLANG_VOID_TYPE, 0),
MAKE_INTRINSIC("reshape", array_reshape, SLANG_VOID_TYPE, 0),
/* Prototype: Void reshape (Array_Type a, integer-array);
*/
SLANG_END_TABLE
};
static char *array_string (unsigned char type, VOID_STAR v)
{
SLang_Array_Type *at;
char buf[512];
unsigned int i, num_dims;
int *dims;
at = *(SLang_Array_Type **) v;
type = at->data_type;
num_dims = at->num_dims;
dims = at->dims;
sprintf (buf, "Array %s [%d", SLclass_get_datatype_name (type), at->dims[0]);
for (i = 1; i < num_dims; i++)
sprintf (buf + strlen(buf), ",%d", dims[i]);
strcat (buf, "]");
return SLmake_string (buf);
}
static void array_destroy (unsigned char type, VOID_STAR v)
{
(void) type;
SLang_free_array (*(SLang_Array_Type **) v);
}
static int array_push (unsigned char type, VOID_STAR v)
{
SLang_Array_Type *at;
(void) type;
at = *(SLang_Array_Type **) v;
return SLang_push_array (at, 0);
}
/* Intrinsic arrays are not stored in a variable. So, the address that
* would contain the variable holds the array address.
*/
static int array_push_intrinsic (unsigned char type, VOID_STAR v)
{
(void) type;
return SLang_push_array ((SLang_Array_Type *) v, 0);
}
int _SLarray_add_bin_op (unsigned char type)
{
SL_OOBinary_Type *ab;
SLang_Class_Type *cl;
cl = _SLclass_get_class (type);
ab = cl->cl_binary_ops;
while (ab != NULL)
{
if (ab->data_type == SLANG_ARRAY_TYPE)
return 0;
ab = ab->next;
}
if ((-1 == SLclass_add_binary_op (SLANG_ARRAY_TYPE, type, array_binary_op, array_binary_op_result))
|| (-1 == SLclass_add_binary_op (type, SLANG_ARRAY_TYPE, array_binary_op, array_binary_op_result)))
return -1;
return 0;
}
static SLang_Array_Type *
do_array_math_op (int op, int unary_type,
SLang_Array_Type *at, unsigned int na)
{
unsigned char a_type, b_type;
int (*f) (int, unsigned char, VOID_STAR, unsigned int, VOID_STAR);
SLang_Array_Type *bt;
SLang_Class_Type *b_cl;
if (na != 1)
{
SLang_verror (SL_NOT_IMPLEMENTED, "Operation restricted to 1 array");
return NULL;
}
a_type = at->data_type;
if (NULL == (f = _SLclass_get_unary_fun (op, at->cl, &b_cl, unary_type)))
return NULL;
b_type = b_cl->cl_data_type;
if (-1 == coerse_array_to_linear (at))
return NULL;
if (NULL == (bt = SLang_create_array (b_type, 0, NULL, at->dims, at->num_dims)))
return NULL;
if (1 != (*f)(op, a_type, at->data, at->num_elements, bt->data))
{
SLang_free_array (bt);
return NULL;
}
return bt;
}
static int
array_unary_op_result (int op, unsigned char a, unsigned char *b)
{
(void) op;
(void) a;
*b = SLANG_ARRAY_TYPE;
return 1;
}
static int
array_unary_op (int op,
unsigned char a, VOID_STAR ap, unsigned int na,
VOID_STAR bp)
{
SLang_Array_Type *at;
(void) a;
at = *(SLang_Array_Type **) ap;
if (NULL == (at = do_array_math_op (op, _SLANG_BC_UNARY, at, na)))
{
if (SLang_Error) return -1;
return 0;
}
*(SLang_Array_Type **) bp = at;
at->num_refs += 1;
return 1;
}
static int
array_math_op (int op,
unsigned char a, VOID_STAR ap, unsigned int na,
VOID_STAR bp)
{
SLang_Array_Type *at;
(void) a;
at = *(SLang_Array_Type **) ap;
if (NULL == (at = do_array_math_op (op, _SLANG_BC_MATH_UNARY, at, na)))
{
if (SLang_Error) return -1;
return 0;
}
*(SLang_Array_Type **) bp = at;
at->num_refs += 1;
return 1;
}
static int
array_app_op (int op,
unsigned char a, VOID_STAR ap, unsigned int na,
VOID_STAR bp)
{
SLang_Array_Type *at;
(void) a;
at = *(SLang_Array_Type **) ap;
if (NULL == (at = do_array_math_op (op, _SLANG_BC_APP_UNARY, at, na)))
{
if (SLang_Error) return -1;
return 0;
}
*(SLang_Array_Type **) bp = at;
at->num_refs += 1;
return 1;
}
int
_SLarray_typecast (unsigned char a_type, VOID_STAR ap, unsigned int na,
unsigned char b_type, VOID_STAR bp,
int is_implicit)
{
SLang_Array_Type *at, *bt;
int (*t) (unsigned char, VOID_STAR, unsigned int, unsigned char, VOID_STAR);
if (na != 1)
{
SLang_verror (SL_NOT_IMPLEMENTED, "typecast of multiple arrays not implemented");
return -1;
}
at = *(SLang_Array_Type **) ap;
a_type = at->data_type;
if (a_type == b_type)
{
at->num_refs += 1;
*(SLang_Array_Type **) bp = at;
return 1;
}
if (NULL == (t = _SLclass_get_typecast (a_type, b_type, is_implicit)))
return -1;
if (-1 == coerse_array_to_linear (at))
return -1;
if (NULL == (bt = SLang_create_array (b_type, 0, NULL, at->dims, at->num_dims)))
return -1;
if (1 == (*t) (a_type, at->data, at->num_elements, b_type, bt->data))
{
*(SLang_Array_Type **) bp = bt;
bt->num_refs += 1;
return 1;
}
SLang_free_array (bt);
return 0;
}
static int
array_dereference (unsigned char type, VOID_STAR addr)
{
SLang_Array_Type *at;
SLang_Array_Type *bt;
char *data, *a_data;
unsigned int i, num_elements, sizeof_type;
unsigned int size;
int (*cl_acopy) (unsigned char, VOID_STAR, VOID_STAR);
at = *(SLang_Array_Type **) addr;
if (-1 == coerse_array_to_linear (at))
return -1;
type = at->data_type;
num_elements = at->num_elements;
sizeof_type = at->sizeof_type;
size = num_elements * sizeof_type;
if (NULL == (data = SLmalloc (size)))
return -1;
if (NULL == (bt = SLang_create_array (type, 0, (VOID_STAR)data, at->dims, at->num_dims)))
{
SLfree (data);
return -1;
}
a_data = (char *) at->data;
if (0 == (at->flags & DATA_VALUE_IS_POINTER))
{
SLMEMCPY (data, a_data, size);
return SLang_push_array (bt, 1);
}
SLMEMSET (data, 0, size);
cl_acopy = at->cl->cl_acopy;
for (i = 0; i < num_elements; i++)
{
if (NULL != *(VOID_STAR *) a_data)
{
if (-1 == (*cl_acopy) (type, (VOID_STAR) a_data, (VOID_STAR) data))
{
SLang_free_array (bt);
return -1;
}
}
data += sizeof_type;
a_data += sizeof_type;
}
return SLang_push_array (bt, 1);
}
/* This function gets called via, e.g., @Array_Type (Double_Type, [10,20]);
*/
static int
array_datatype_deref (unsigned char type)
{
SLang_Array_Type *ind_at;
SLang_Array_Type *at;
if (-1 == SLang_pop_array (&ind_at, 1))
return -1;
if ((ind_at->data_type != SLANG_INT_TYPE)
|| (ind_at->num_dims != 1))
{
SLang_verror (SL_TYPE_MISMATCH, "Expecting 1-d integer array");
goto return_error;
}
if (-1 == _SLang_pop_datatype (&type))
goto return_error;
if (NULL == (at = SLang_create_array (type, 0, NULL,
(int *) ind_at->data,
ind_at->num_elements)))
goto return_error;
return SLang_push_array (at, 1);
return_error:
SLang_free_array (ind_at);
return -1;
}
int
_SLarray_init_slarray (void)
{
SLang_Class_Type *cl;
if (-1 == SLadd_intrin_fun_table (Array_Table, NULL))
return -1;
if (NULL == (cl = SLclass_allocate_class ("Array_Type")))
return -1;
(void) SLclass_set_string_function (cl, array_string);
(void) SLclass_set_destroy_function (cl, array_destroy);
(void) SLclass_set_push_function (cl, array_push);
cl->cl_push_intrinsic = array_push_intrinsic;
cl->cl_dereference = array_dereference;
cl->cl_datatype_deref = array_datatype_deref;
if (-1 == SLclass_register_class (cl, SLANG_ARRAY_TYPE, sizeof (VOID_STAR),
SLANG_CLASS_TYPE_PTR))
return -1;
if ((-1 == SLclass_add_binary_op (SLANG_ARRAY_TYPE, SLANG_ARRAY_TYPE, array_binary_op, array_binary_op_result))
|| (-1 == SLclass_add_unary_op (SLANG_ARRAY_TYPE, array_unary_op, array_unary_op_result))
|| (-1 == SLclass_add_app_unary_op (SLANG_ARRAY_TYPE, array_app_op, array_unary_op_result))
|| (-1 == SLclass_add_math_op (SLANG_ARRAY_TYPE, array_math_op, array_unary_op_result))
|| (-1 == SLclass_add_math_op (SLANG_ARRAY_TYPE, array_math_op, array_unary_op_result)))
return -1;
return 0;
}
int SLang_pop_array (SLang_Array_Type **at_ptr, int convert_scalar)
{
if (-1 == pop_array (at_ptr, convert_scalar))
return -1;
if (-1 == coerse_array_to_linear (*at_ptr))
{
SLang_free_array (*at_ptr);
return -1;
}
return 0;
}
