int _pSLclass_obj_eqs (SLang_Object_Type *a, SLang_Object_Type *b)
{
SLang_Class_Type *a_cl, *b_cl;
VOID_STAR pa, pb;
int (*eqs)(SLtype, VOID_STAR, SLtype, VOID_STAR);
int status;
a_cl = _pSLclass_get_class (a->o_data_type);
b_cl = _pSLclass_get_class (b->o_data_type);
pa = _pSLclass_get_ptr_to_value (a_cl, a);
pb = _pSLclass_get_ptr_to_value (b_cl, b);
if ((pa == NULL) || (pb == NULL))
return -1;
if ((NULL == (eqs = a_cl->cl_eqs))
&& (NULL == (eqs = b_cl->cl_eqs)))
return do_default_eqs (a_cl, pa, b_cl, pb);
status = push_eqs_comparison (a, b);
if (status != 0)
return status;
status = (*eqs) (a->o_data_type, pa, b->o_data_type, pb);
pop_eqs_comparison ();
return status;
}
int SLclass_add_binary_op (SLtype a, SLtype b,
int (*f) (int,
SLtype, VOID_STAR, unsigned int,
SLtype, VOID_STAR, unsigned int,
VOID_STAR),
int (*r) (int, SLtype, SLtype, SLtype *))
{
SL_OOBinary_Type *ab;
SLang_Class_Type *cl;
if ((f == NULL) || (r == NULL)
|| ((a == SLANG_VOID_TYPE) && (b == SLANG_VOID_TYPE)))
{
_pSLang_verror (SL_INVALID_PARM, "SLclass_add_binary_op");
return -1;
}
if (NULL == (ab = (SL_OOBinary_Type *) SLmalloc (sizeof(SL_OOBinary_Type))))
return -1;
ab->binary_function = f;
ab->binary_result = r;
if (a == SLANG_VOID_TYPE)
{
cl = _pSLclass_get_class (b);
ab->data_type = a;
ab->next = NULL;
cl->cl_void_binary_this = ab;
}
else if (b == SLANG_VOID_TYPE)
{
cl = _pSLclass_get_class (a);
ab->data_type = b;
ab->next = NULL;
cl->cl_this_binary_void = ab;
}
else
{
cl = _pSLclass_get_class (a);
ab->next = cl->cl_binary_ops;
ab->data_type = b;
cl->cl_binary_ops = ab;
}
if ((a != SLANG_ARRAY_TYPE)
&& (b != SLANG_ARRAY_TYPE))
{
if ((-1 == _pSLarray_add_bin_op (a))
|| (-1 == _pSLarray_add_bin_op (b)))
return -1;
}
return 0;
}
/* AnyType */
int _pSLanytype_typecast (SLtype a_type, VOID_STAR ap, unsigned int na,
SLtype b_type, VOID_STAR bp)
{
SLang_Class_Type *cl;
SLang_Any_Type **any;
unsigned int i;
unsigned int sizeof_type;
(void) b_type;
any = (SLang_Any_Type **) bp;
cl = _pSLclass_get_class (a_type);
sizeof_type = cl->cl_sizeof_type;
for (i = 0; i < na; i++)
{
if ((-1 == (*cl->cl_apush) (a_type, ap))
|| (-1 == SLang_pop_anytype (&any[i])))
{
while (i != 0)
{
i--;
SLang_free_anytype (any[i]);
any[i] = NULL;
}
return -1;
}
ap = (VOID_STAR)((char *)ap + sizeof_type);
}
return 1;
}
SLFUTURE_CONST char *SLclass_get_datatype_name (SLtype stype)
{
SLang_Class_Type *cl;
cl = _pSLclass_get_class (stype);
return cl->cl_name;
}
int _pSLclass_is_same_obj (SLang_Object_Type *a, SLang_Object_Type *b)
{
SLang_Class_Type *cl;
unsigned int sizeof_type;
if (a->o_data_type != b->o_data_type)
return 0;
cl = _pSLclass_get_class (a->o_data_type);
sizeof_type = cl->cl_sizeof_type;
switch (cl->cl_class_type)
{
case SLANG_CLASS_TYPE_MMT:
case SLANG_CLASS_TYPE_PTR:
return (a->v.ptr_val == b->v.ptr_val);
case SLANG_CLASS_TYPE_SCALAR:
return !memcmp (&a->v, &b->v, sizeof_type);
case SLANG_CLASS_TYPE_VECTOR:
return !memcmp (a->v.ptr_val, b->v.ptr_val, sizeof_type);
}
return 0;
}
static int vector_apop (SLtype type, VOID_STAR ptr)
{
SLang_Class_Type *cl;
cl = _pSLclass_get_class (type);
return (*cl->cl_pop)(type, (VOID_STAR) &ptr);
}
static int length_cmd (void)
{
SLang_Class_Type *cl;
SLang_Object_Type obj;
VOID_STAR p;
unsigned int length;
int len;
if (-1 == SLang_pop (&obj))
return -1;
cl = _pSLclass_get_class (obj.o_data_type);
p = _pSLclass_get_ptr_to_value (cl, &obj);
len = 1;
if (cl->cl_length != NULL)
{
if (0 == (*cl->cl_length)(obj.o_data_type, p, &length))
len = (int) length;
else
len = -1;
}
SLang_free_object (&obj);
return len;
}
int SLclass_create_synonym (SLFUTURE_CONST char *name, SLtype type)
{
if (NULL == _pSLclass_get_class (type))
return -1;
return register_new_datatype (name, type);
}
static int class_id_intrinsic (void)
{
SLtype type;
if (-1 == SLang_pop_datatype (&type))
return -1;
return _pSLclass_get_class (type)->cl_data_type;
}
int SLang_push_datatype (SLtype data_type)
{
/* This data type could be a copy of another type, e.g., short and
* int if they are the same size (Int16 == Short). So, make sure
* we push the original and not the copy.
*/
data_type = _pSLclass_get_class (data_type)->cl_data_type;
return SLclass_push_int_obj (SLANG_DATATYPE_TYPE, data_type);
}
static int default_acopy (SLtype type, VOID_STAR from, VOID_STAR to)
{
SLang_Class_Type *cl;
cl = _pSLclass_get_class (type);
if (-1 == (*cl->cl_apush) (type, from))
return -1;
return (*cl->cl_apop) (type, to);
}
int SLclass_add_math_op (SLtype type,
int (*handler)(int,
SLtype, VOID_STAR, unsigned int,
VOID_STAR),
int (*result) (int, SLtype, SLtype *))
{
SLang_Class_Type *cl = _pSLclass_get_class (type);
cl->cl_math_op = handler;
cl->cl_math_op_result_type = result;
return 0;
}
static void datatype_intrinsic (SLtype *t)
{
SLang_Class_Type *cl;
if (0 == SLclass_is_class_defined (*t))
{
(void) SLang_push_null ();
return;
}
cl = _pSLclass_get_class (*t);
(void) SLang_push_datatype (cl->cl_data_type);
}
int (*_pSLclass_get_unary_fun (int op,
SLang_Class_Type *a_cl,
SLang_Class_Type **b_cl,
int utype))
(int, SLtype, VOID_STAR, unsigned int, VOID_STAR)
{
int (*f)(int, SLtype, VOID_STAR, unsigned int, VOID_STAR);
int (*r)(int, SLtype, SLtype *);
SLtype a;
SLtype b;
switch (utype)
{
case SLANG_BC_ARITH_UNARY:
case SLANG_BC_UNARY:
f = a_cl->cl_unary_op;
r = a_cl->cl_unary_op_result_type;
break;
case SLANG_BC_MATH_UNARY:
f = a_cl->cl_math_op;
r = a_cl->cl_math_op_result_type;
break;
case SLANG_BC_APP_UNARY:
f = a_cl->cl_app_unary_op;
r = a_cl->cl_app_unary_op_result_type;
break;
default:
f = NULL;
r = NULL;
}
a = a_cl->cl_data_type;
if ((f != NULL) && (r != NULL) && (1 == (*r) (op, a, &b)))
{
if (a == b)
*b_cl = a_cl;
else
*b_cl = _pSLclass_get_class (b);
return f;
}
_pSLang_verror (SL_TYPE_MISMATCH, "undefined unary operation/function on %s",
a_cl->cl_name);
*b_cl = NULL;
return NULL;
}
static int istruct_sput (SLtype type, SLFUTURE_CONST char *name)
{
SLang_IStruct_Field_Type *f;
VOID_STAR addr;
SLang_Class_Type *cl;
if (NULL == (f = istruct_pop_field (name, 1, &addr)))
return -1;
type = f->type;
cl = _pSLclass_get_class (type);
return (*cl->cl_pop) (type, addr);
}
static int
scalar_vector_bin_op (int op,
SLtype a_type, VOID_STAR ap, unsigned int na,
SLtype b_type, VOID_STAR bp, unsigned int nb,
VOID_STAR cp)
{
char *c;
char *a, *b;
unsigned int da, db;
unsigned int n, n_max;
unsigned int data_type_len;
SLang_Class_Type *cl;
(void) b_type;
cl = _pSLclass_get_class (a_type);
data_type_len = cl->cl_sizeof_type;
a = (char *) ap;
b = (char *) bp;
c = (char *) cp;
if (na == 1) da = 0; else da = data_type_len;
if (nb == 1) db = 0; else db = data_type_len;
if (na > nb) n_max = na; else n_max = nb;
switch (op)
{
default:
return 0;
case SLANG_NE:
for (n = 0; n < n_max; n++)
{
c[n] = (0 != SLMEMCMP(a, b, data_type_len));
a += da; b += db;
}
break;
case SLANG_EQ:
for (n = 0; n < n_max; n++)
{
c[n] = (0 == SLMEMCMP(a, b, data_type_len));
a += da; b += db;
}
break;
}
return 1;
}
static int scalar_fwrite (SLtype type, FILE *fp, VOID_STAR ptr,
unsigned int desired, unsigned int *actual)
{
unsigned int n;
char *buf = (char *)ptr;
size_t desired_bytes, actual_bytes;
size_t size = _pSLclass_get_class (type)->cl_sizeof_type;
desired_bytes = size * desired;
actual_bytes = 0;
while (desired_bytes)
{
int e;
errno = 0;
n = fwrite (buf, 1, desired_bytes, fp);
actual_bytes += n;
if (n == desired_bytes)
break;
e = errno;
desired_bytes -= n;
buf += n;
clearerr (fp);
#ifdef EINTR
if ((e == EINTR)
&& (0 == SLang_handle_interrupt ()))
continue;
#endif
_pSLerrno_errno = e;
/* Apparantly, the write can be interrupted returning a short item
* count but not set errno.
*/
if (n == 0)
break;
}
if (actual_bytes % size)
{
/* Sigh. We failed to write out a full object. */
}
*actual = actual_bytes / size;
return 0;
}
static int scalar_fread (SLtype type, FILE *fp, VOID_STAR ptr,
unsigned int desired, unsigned int *actual)
{
unsigned int n;
char *buf = (char *)ptr;
size_t desired_bytes, actual_bytes;
size_t size = _pSLclass_get_class (type)->cl_sizeof_type;
desired_bytes = size * desired;
actual_bytes = 0;
while (desired_bytes)
{
int e;
errno = 0;
n = fread (buf, 1, desired_bytes, fp);
actual_bytes += n;
if (n == desired_bytes)
break;
e = errno;
desired_bytes -= n;
buf += n;
clearerr (fp);
#ifdef EINTR
if ((e == EINTR)
&& (0 == SLang_handle_interrupt ()))
continue;
#endif
_pSLerrno_errno = e;
break;
}
if (actual_bytes % size)
{
/* Sigh. We failed to read a full object. */
}
*actual = actual_bytes / size;
return 0;
}
static void assoc_get_values (SLang_Assoc_Array_Type *a)
{
SLang_Array_Type *at;
SLindex_Type num;
char *dest_data;
SLtype type;
SLang_Class_Type *cl;
unsigned int sizeof_type;
_pSLAssoc_Array_Element_Type *e, *emax;
/* Note: If support for threads is added, then we need to modify this
* algorithm to prevent another thread from modifying the array.
* However, that should be handled in inner_interp.
*/
num = a->num_occupied - a->num_deleted;
type = a->type;
cl = _pSLclass_get_class (type);
sizeof_type = cl->cl_sizeof_type;
if (NULL == (at = SLang_create_array (type, 0, NULL, &num, 1)))
return;
dest_data = (char *)at->data;
e = a->elements;
emax = e + a->table_len;
while (e < emax)
{
if ((e->key != NULL) && (e->key != Deleted_Key))
{
if (-1 == transfer_element (cl, (VOID_STAR) dest_data, &e->value))
{
SLang_free_array (at);
return;
}
dest_data += sizeof_type;
}
e++;
}
(void) SLang_push_array (at, 1);
}
static int datatype_deref (SLtype type, VOID_STAR ptr)
{
SLang_Class_Type *cl;
int status;
/* The parser generated code for this as if a function call were to be
* made. However, we are calling the deref object routine
* instead of the function call. So, I must simulate the function call.
*/
if (-1 == _pSL_increment_frame_pointer ())
return -1;
type = (SLtype) *(int *) ptr;
cl = _pSLclass_get_class (type);
status = (*cl->cl_datatype_deref) (type);
(void) _pSL_decrement_frame_pointer ();
return status;
}
int SLclass_add_app_unary_op (SLtype type,
int (*f)(int,
SLtype, VOID_STAR, unsigned int,
VOID_STAR),
int (*r)(int, SLtype, SLtype *))
{
SLang_Class_Type *cl;
cl = _pSLclass_get_class (type);
if ((f == NULL) || (r == NULL))
{
_pSLang_verror (SL_INVALID_PARM, "SLclass_add_app_unary_op");
return -1;
}
cl->cl_app_unary_op = f;
cl->cl_app_unary_op_result_type = r;
return 0;
}
int _pSLclass_copy_class (SLtype to, SLtype from)
{
SLang_Class_Type *cl, **clp;
Class_Table_Type *t;
cl = _pSLclass_get_class (from);
if (NULL == (clp = alloc_class_slot (to, &t)))
return -1;
if (*clp != NULL)
{
_pSLang_verror (SL_APPLICATION_ERROR, "Class %d already exists", to);
SLang_exit_error ("Application error: Fatal error");
}
add_class_to_slot (t, clp, cl);
#if SLANG_OPTIMIZE_FOR_SPEED
_pSLang_set_class_info (to, cl);
#endif
return 0;
}
/* format object into a string and returns slstring */
char *_pSLstringize_object (SLang_Object_Type *obj) /*{{{*/
{
SLang_Class_Type *cl;
SLtype stype;
VOID_STAR p;
char *s, *s1;
stype = obj->o_data_type;
p = (VOID_STAR) &obj->v.ptr_val;
cl = _pSLclass_get_class (stype);
s = (*cl->cl_string) (stype, p);
if (s != NULL)
{
s1 = SLang_create_slstring (s);
SLfree (s);
s = s1;
}
return s;
}
int (*_pSLclass_get_typecast (SLtype from, SLtype to, int is_implicit))
(SLtype, VOID_STAR, unsigned int,
SLtype, VOID_STAR)
{
SL_Typecast_Type *t;
SLang_Class_Type *cl_from;
cl_from = _pSLclass_get_class (from);
t = cl_from->cl_typecast_funs;
while (t != NULL)
{
if (t->data_type != to)
{
t = t->next;
continue;
}
if (is_implicit && (t->allow_implicit == 0))
break;
return t->typecast;
}
if (to == SLANG_ANY_TYPE)
return &_pSLanytype_typecast;
if ((is_implicit == 0)
&& (cl_from->cl_void_typecast != NULL))
return cl_from->cl_void_typecast;
_pSLang_verror (SL_TYPE_MISMATCH, "Unable to typecast %s to %s",
cl_from->cl_name,
SLclass_get_datatype_name (to));
return NULL;
}
int SLang_assign_to_ref (SLang_Ref_Type *ref, SLtype type, VOID_STAR v)
{
SLang_Object_Type *stkptr;
SLang_Class_Type *cl;
cl = _pSLclass_get_class (type);
/* Use apush since this function is passing ``array'' bytes rather than the
* address of the data. I need to somehow make this more consistent. To
* see what I mean, consider:
*
* double z[2];
* char *s = "silly";
* char bytes[10]; BAD--- Don't do this
* int i;
*
* SLang_assign_to_ref (ref, SLANG_INT_TYPE, &i);
* SLang_assign_to_ref (ref, SLANG_STRING_TYPE, &s);
* SLang_assign_to_ref (ref, SLANG_COMPLEX_TYPE, z);
*
* That is, all external routines that take a VOID_STAR argument need to
* be documented such that how the function should be called with the
* various class_types.
*/
if (-1 == (*cl->cl_apush) (type, v))
return -1;
stkptr = _pSLang_get_run_stack_pointer ();
if (0 == _pSLang_deref_assign (ref))
return 0;
if (stkptr != _pSLang_get_run_stack_pointer ())
SLdo_pop ();
return -1;
}
int SLclass_dup_object (SLtype type, VOID_STAR from, VOID_STAR to)
{
SLang_Class_Type *cl = _pSLclass_get_class (type);
return cl->cl_acopy (type, from, to);
}
void _pSLunpack (char *format, SLang_BString_Type *bs)
{
Format_Type ft;
unsigned char *b;
unsigned int len;
unsigned int num_bytes;
check_native_byte_order ();
if (-1 == compute_size_for_format (format, &num_bytes))
return;
b = SLbstring_get_pointer (bs, &len);
if (b == NULL)
return;
if (len < num_bytes)
{
_pSLang_verror (SL_INVALID_PARM,
"unpack format %s is too large for input string",
format);
return;
}
while (1 == parse_a_format (&format, &ft))
{
char *str, *s;
if (ft.repeat == 0)
continue;
if (ft.data_type == 0)
{ /* skip padding */
b += ft.repeat;
continue;
}
if (ft.is_scalar)
{
SLang_Array_Type *at;
SLindex_Type dims;
if (ft.repeat == 1)
{
SLang_Class_Type *cl;
cl = _pSLclass_get_class (ft.data_type);
memcpy ((char *)cl->cl_transfer_buf, (char *)b, ft.sizeof_type);
if (ft.byteorder != NATIVE_ORDER)
byteswap (ft.byteorder, (unsigned char *)cl->cl_transfer_buf, ft.sizeof_type, 1);
if (-1 == (cl->cl_apush (ft.data_type, cl->cl_transfer_buf)))
return;
b += ft.sizeof_type;
continue;
}
dims = (SLindex_Type) ft.repeat;
at = SLang_create_array (ft.data_type, 0, NULL, &dims, 1);
if (at == NULL)
return;
num_bytes = ft.repeat * ft.sizeof_type;
memcpy ((char *)at->data, (char *)b, num_bytes);
if (ft.byteorder != NATIVE_ORDER)
byteswap (ft.byteorder, (unsigned char *)at->data, ft.sizeof_type, ft.repeat);
if (-1 == SLang_push_array (at, 1))
return;
b += num_bytes;
continue;
}
/* string type: s, S, or Z */
if (ft.format_type == 's')
len = ft.repeat;
else
len = get_unpadded_strlen ((char *)b, ft.pad, ft.repeat);
str = SLmalloc (len + 1);
if (str == NULL)
return;
memcpy ((char *) str, (char *)b, len);
str [len] = 0;
/* Avoid a bstring if possible */
s = SLmemchr (str, 0, len);
if (s == NULL)
{
if (-1 == SLang_push_malloced_string (str))
return;
}
else
{
SLang_BString_Type *new_bs;
new_bs = SLbstring_create_malloced ((unsigned char *)str, len, 1);
if (new_bs == NULL)
return;
if (-1 == SLang_push_bstring (new_bs))
{
SLfree (str);
return;
}
SLbstring_free (new_bs);
}
b += ft.repeat;
}
}
static void get_exception_info_intrinsic (void)
{
#define NUM_EXCEPT_FIELDS 8
static SLFUTURE_CONST char *field_names[NUM_EXCEPT_FIELDS] =
{
"error", "descr", "file", "line", "function", "object", "message", "traceback"
};
SLtype field_types[NUM_EXCEPT_FIELDS];
VOID_STAR field_values[NUM_EXCEPT_FIELDS];
int err;
SLCONST char *desc;
SLCONST char *file;
SLCONST char *function;
SLCONST char *errmsg;
SLCONST char *tbmsg;
int linenum;
err = _pSLerr_get_last_error ();
if (err == 0)
{
(void) SLang_push_null ();
return;
}
desc = SLerr_strerror (err);
(void) _pSLerr_get_last_error_line_info (&file, &linenum, &function);
field_types[0] = SLANG_INT_TYPE;
field_values[0] = (VOID_STAR) &err;
field_types[1] = SLANG_STRING_TYPE;
field_values[1] = (VOID_STAR) &desc;
field_types[2] = SLANG_STRING_TYPE;
field_values[2] = (VOID_STAR) &file;
field_types[3] = SLANG_INT_TYPE;
field_values[3] = (VOID_STAR) &linenum;
field_types[4] = SLANG_STRING_TYPE;
field_values[4] = (VOID_STAR) &function;
if ((Error_Context == NULL)
|| (Error_Context->object_was_thrown == 0))
{
char *null = NULL;
field_types[5] = SLANG_NULL_TYPE;
field_values[5] = (VOID_STAR) &null;
}
else
{
SLtype data_type = Error_Context->object_thrown.o_data_type;
field_types[5] = data_type;
field_values[5] = _pSLclass_get_ptr_to_value (_pSLclass_get_class (data_type),
&Error_Context->object_thrown);
}
errmsg = get_error_msg_from_queue (_SLERR_MSG_ERROR);
if ((errmsg == NULL) || (*errmsg == 0))
errmsg = desc;
field_types[6] = SLANG_STRING_TYPE;
field_values[6] = (VOID_STAR) &errmsg;
tbmsg = get_error_msg_from_queue (_SLERR_MSG_TRACEBACK);
field_types[7] = (tbmsg == NULL) ? SLANG_NULL_TYPE : SLANG_STRING_TYPE;
field_values[7] = (VOID_STAR) &tbmsg;
(void) SLstruct_create_struct (NUM_EXCEPT_FIELDS, field_names, field_types, field_values);
if (errmsg != desc)
SLang_free_slstring ((char *) errmsg);
SLang_free_slstring ((char *)tbmsg);
}
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);
}
static int
use_cmp_bin_op (int op,
SLtype a_type, VOID_STAR ap, unsigned int na,
SLtype b_type, VOID_STAR bp, unsigned int nb,
VOID_STAR cp)
{
int *c;
char *a, *b;
unsigned int da, db;
unsigned int n, n_max;
unsigned int data_type_len;
SLang_Class_Type *cl;
int (*cmp)(SLtype, VOID_STAR, VOID_STAR, int *);
(void) b_type;
cl = _pSLclass_get_class (a_type);
cmp = cl->cl_cmp;
data_type_len = cl->cl_sizeof_type;
a = (char *) ap;
b = (char *) bp;
c = (int *) cp;
if (na == 1) da = 0; else da = data_type_len;
if (nb == 1) db = 0; else db = data_type_len;
if (na > nb) n_max = na; else n_max = nb;
switch (op)
{
int result;
default:
return 0;
case SLANG_NE:
for (n = 0; n < n_max; n++)
{
if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result))
return -1;
c[n] = (result != 0);
a += da; b += db;
}
break;
case SLANG_EQ:
for (n = 0; n < n_max; n++)
{
if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result))
return -1;
c[n] = (result == 0);
a += da; b += db;
}
break;
case SLANG_GT:
for (n = 0; n < n_max; n++)
{
if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result))
return -1;
c[n] = (result > 0);
a += da; b += db;
}
break;
case SLANG_GE:
for (n = 0; n < n_max; n++)
{
if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result))
return -1;
c[n] = (result >= 0);
a += da; b += db;
}
break;
case SLANG_LT:
for (n = 0; n < n_max; n++)
{
if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result))
return -1;
c[n] = (result < 0);
a += da; b += db;
}
break;
case SLANG_LE:
for (n = 0; n < n_max; n++)
{
if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result))
return -1;
c[n] = (result <= 0);
a += da; b += db;
}
break;
}
return 1;
}
