/* 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 #include #include #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; }