i can compile slang and newt with dietlibc now

1 files changed, 3139 insertions, 0 deletions

diff --git a/mdk-stage1/slang/slarray.c b/mdk-stage1/slang/slarray.c
new file mode 100644
index 000000000..0b9a1406c
--- /dev/null
+++ b/mdk-stage1/slang/slarray.c
@@ -0,0 +1,3139 @@
+/* Array manipulation routines for S-Lang */
+/* Copyright (c) 1997, 1999, 2001 John E. Davis
+ * This file is part of the S-Lang library.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Perl Artistic License.
+ */
+
+#include "slinclud.h"
+
+#define SL_APP_WANTS_FOREACH
+#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_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:
+	return SLclass_pop_ptr_obj (SLANG_ARRAY_TYPE, (VOID_STAR *) at_ptr);
+
+      case SLANG_NULL_TYPE:
+	convert_scalar = 0;
+	/* drop */
+      default:
+	if (convert_scalar == 0)
+	  {
+	     SLdo_pop ();
+	     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];
+
+	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;
+}
+
+void _SLarray_free_array_elements (SLang_Class_Type *cl, VOID_STAR s, unsigned int num)
+{
+   unsigned int sizeof_type;
+   void (*f) (unsigned char, VOID_STAR);
+   char *p;
+   unsigned char type;
+
+   if ((cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR)
+       || (cl->cl_class_type == SLANG_CLASS_TYPE_VECTOR))
+     return;
+
+   f = cl->cl_destroy;
+   sizeof_type = cl->cl_sizeof_type;
+   type = cl->cl_data_type;
+
+   p = (char *) s;
+   while (num != 0)
+     {
+	if (NULL != *(VOID_STAR *)p)
+	  {
+	     (*f) (type, (VOID_STAR)p);
+	     *(VOID_STAR *) p = NULL;
+	  }
+	p += sizeof_type;
+	num--;
+     }
+}
+
+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 & SLARR_DATA_VALUE_IS_INTRINSIC)
+     return;			       /* not to be freed */
+
+   if (flags & SLARR_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_array1 (unsigned char type, int read_only, VOID_STAR data,
+		     int *dims, unsigned int num_dims, int no_init)
+{
+   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;
+   at->num_refs = 1;
+
+   if (read_only) at->flags = SLARR_DATA_VALUE_IS_READ_ONLY;
+   switch (cl->cl_class_type)
+     {
+      case SLANG_CLASS_TYPE_VECTOR:
+      case SLANG_CLASS_TYPE_SCALAR:
+	break;
+
+      default:
+	at->flags |= SLARR_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;
+     }
+
+   /* Now set the rest of the unused dimensions to 1.  This makes it easier
+    * when transposing arrays.
+    */
+   while (i < SLARRAY_MAX_DIMS)
+     at->dims[i++] = 1;
+
+   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;
+     }
+
+   if (no_init == 0)
+     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;
+}
+
+SLang_Array_Type *
+SLang_create_array (unsigned char type, int read_only, VOID_STAR data,
+		    int *dims, unsigned int num_dims)
+{
+   return SLang_create_array1 (type, read_only, data, dims, num_dims, 0);
+}
+
+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 |= SLARR_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 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_flag)
+{
+   if (at == NULL)
+     return SLang_push_null ();
+
+   at->num_refs += 1;
+
+   if (0 == SLclass_push_ptr_obj (SLANG_ARRAY_TYPE, (VOID_STAR) at))
+     {
+	if (free_flag)
+	  SLang_free_array (at);
+	return 0;
+     }
+
+   at->num_refs -= 1;
+
+   if (free_flag) 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];
+   int (*anew) (unsigned char, unsigned int);
+
+   num_dims = (SLang_Num_Function_Args - 1);
+
+   if (-1 == _SLang_pop_datatype (&type))
+     return -1;
+
+   anew = (_SLclass_get_class (type))->cl_anew;
+   if (anew != NULL)
+     return (*anew) (type, num_dims);
+
+   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_element_at_addr (SLang_Array_Type *at,
+				 VOID_STAR data, int allow_null)
+{
+   SLang_Class_Type *cl;
+
+   cl = at->cl;
+   if ((at->flags & SLARR_DATA_VALUE_IS_POINTER)
+       && (*(VOID_STAR *) data == NULL))
+     {
+	if (allow_null)
+	  return SLang_push_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;
+
+   /* FIXME: Priority = low.  This assumes that if an array is not linear, then
+    * it is a range.
+    */
+   if (0 == (at->flags & SLARR_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 &= ~SLARR_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)
+{
+   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)
+     {
+	SLang_Object_Type *obj;
+
+	i--;
+	obj = index_objs + i;
+	if (-1 == _SLang_pop_object_of_type (SLANG_INT_TYPE, obj, 1))
+	  goto return_error;
+
+	if (obj->data_type == SLANG_ARRAY_TYPE)
+	  {
+	     SLang_Array_Type *at = obj->v.array_val;
+
+	     if (at->num_dims == 1)
+	       {
+		  if ((num_indices == 1)
+		      && (0 == (at->flags & SLARR_DATA_VALUE_IS_RANGE)))
+		    *is_index_array = 1;
+	       }
+	     else
+	       {
+		  SLang_verror (SL_INVALID_PARM, "expecting a 1-d index array");
+		  goto return_error;
+	       }
+	  }
+     }
+
+   return 0;
+
+   return_error:
+   free_index_objects (index_objs, num_indices);
+   return -1;
+}
+
+/* Here ind_at is a linear 1-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_elements;
+
+   num_elements = at->num_elements;
+   indices = (int *) ind_at->data;
+   indices_max = indices + ind_at->num_elements;
+
+   while (indices < indices_max)
+     {
+	unsigned int d;
+
+	d = (unsigned int) *indices++;
+	if (d >= num_elements)
+	  {
+	     SLang_verror (SL_INVALID_PARM,
+			   "index-array is out of range");
+	     return -1;
+	  }
+     }
+   return 0;
+}
+
+static int
+transfer_n_elements (SLang_Array_Type *at, VOID_STAR dest_data, VOID_STAR src_data,
+		     unsigned int sizeof_type, unsigned int n, int is_ptr)
+{
+   unsigned char data_type;
+   SLang_Class_Type *cl;
+
+   if (is_ptr == 0)
+     {
+	SLMEMCPY ((char *) dest_data, (char *)src_data, n * sizeof_type);
+	return 0;
+     }
+
+   data_type = at->data_type;
+   cl = at->cl;
+
+   while (n != 0)
+     {
+	if (*(VOID_STAR *)dest_data != NULL)
+	  {
+	     (*cl->cl_destroy) (data_type, 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, src_data, dest_data))
+	       /* No need to destroy anything */
+	       return -1;
+	  }
+
+	src_data = (VOID_STAR) ((char *)src_data + sizeof_type);
+	dest_data = (VOID_STAR) ((char *)dest_data + sizeof_type);
+
+	n--;
+     }
+
+   return 0;
+}
+
+int
+_SLarray_aget_transfer_elem (SLang_Array_Type *at, int *indices,
+			     VOID_STAR new_data, unsigned int sizeof_type, int is_ptr)
+{
+   VOID_STAR at_data;
+
+   /* Since 1 element is being transferred, there is not need to coerse
+    * the array to linear.
+    */
+   if (NULL == (at_data = get_data_addr (at, indices)))
+     return -1;
+
+   return transfer_n_elements (at, new_data, at_data, sizeof_type, 1, is_ptr);
+}
+
+/* Here the ind_at index-array is a 1-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;
+   int *indices, *indices_max;
+   unsigned char *new_data, *src_data;
+   unsigned int sizeof_type;
+   int is_ptr;
+   
+   if (-1 == coerse_array_to_linear (at))
+     return -1;
+
+   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;
+
+   src_data = (unsigned char *) at->data;
+   new_data = (unsigned char *) new_at->data;
+   sizeof_type = new_at->sizeof_type;
+   is_ptr = (new_at->flags & SLARR_DATA_VALUE_IS_POINTER);
+
+   while (indices < indices_max)
+     {
+	unsigned int offset;
+
+	offset = sizeof_type * (unsigned int)*indices;
+	if (-1 == transfer_n_elements (at, (VOID_STAR) new_data,
+				       (VOID_STAR) (src_data + offset),
+				       sizeof_type, 1, is_ptr))
+	  {
+	     SLang_free_array (new_at);
+	     return -1;
+	  }
+
+	new_data += sizeof_type;
+	indices++;
+     }
+
+   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, int is_dim_array[SLARRAY_MAX_DIMS])
+{
+   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.int_val;
+	     max_dims [i] = 1;
+	     index_data[i] = range_buf + i;
+	     is_dim_array[i] = 0;
+	  }
+	else
+	  {
+	     *is_array = 1;
+	     is_dim_array[i] = 1;
+	     ind_at = obj->v.array_val;
+
+	     if (ind_at->flags & SLARR_DATA_VALUE_IS_RANGE)
+	       {
+		  SLarray_Range_Array_Type *r;
+		  int delta;
+		  int first_index, last_index;
+
+		  r = (SLarray_Range_Array_Type *) ind_at->data;
+
+		  /* In an array indexing context, range arrays have different
+		   * semantics.  Consider a[[0:10]].  Clearly this means elements
+		   * 0-10 of a.  But what does a[[0:-1]] mean?  By itself,
+		   * [0:-1] is a null matrix [].  But, it is useful in an
+		   * indexing context to allow -1 to refer to the last element
+		   * of the array.  Similarly, [-3:-1] refers to the last 3
+		   * elements.
+		   * 
+		   * However, [-1:-3] does not refer to any of the elements.
+		   */
+		  if ((first_index = r->first_index) < 0)
+		    {
+		       if (at_dims_i != 0)
+			 first_index = (at_dims_i + first_index) % at_dims_i;
+		    }
+
+		  if ((last_index = r->last_index) < 0)
+		    {
+		       if (at_dims_i != 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)
+		    {
+		       if (first_index > last_index)
+			 max_dims[i] = min_index = max_index = 0;
+		       else
+			 {
+			    max_index = min_index = first_index;
+			    while (max_index + delta <= last_index)
+			      max_index += delta;
+			    max_dims [i] = 1 + (max_index - min_index) / delta;
+			 }
+		    }
+		  else
+		    {
+		       if (first_index < last_index)
+			 max_dims[i] = min_index = max_index = 0;
+		       else
+			 {
+			    min_index = max_index = first_index;
+			    while (min_index + delta >= last_index)
+			      min_index += delta;
+			    max_dims [i] = 1 + (max_index - min_index) / (-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 ((at_dims_i == 0) && (max_dims[i] == 0))
+	  {
+	     total_num_elements = 0;
+	     continue;
+	  }
+
+	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 ([%d:%d]) out of allowed range [0->%d]",
+			   i, min_index, max_index, at_dims_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;
+   int is_dim_array[SLARRAY_MAX_DIMS];
+
+   if (-1 == convert_nasty_index_objs (at, index_objs, num_indices,
+				       index_data, range_buf, range_delta_buf,
+				       max_dims, &num_elements, &is_array,
+				       is_dim_array))
+     return -1;
+
+   is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER);
+   sizeof_type = at->sizeof_type;
+
+   cl = _SLclass_get_class (at->data_type);
+
+   if ((is_array == 0) && (num_elements == 1))
+     {
+	new_data = (char *)cl->cl_transfer_buf;
+	memset (new_data, 0, sizeof_type);
+	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;
+     }
+
+   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 == _SLarray_aget_transfer_elem (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)
+     {
+	int num_dims = 0;
+	/* Fixup dimensions on array */
+	for (i = 0; i < num_indices; i++)
+	  {
+	     if (is_dim_array[i]) /* was: (max_dims[i] > 1) */
+	       {
+		  new_at->dims[num_dims] = max_dims[i];
+		  num_dims++;
+	       }
+	  }
+
+	if (num_dims != 0) new_at->num_dims = num_dims;
+	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;
+   if (is_ptr && (*(VOID_STAR *)new_data == NULL))
+     ret = SLang_push_null ();
+   else
+     {
+	ret = (*cl->cl_apush) (at->data_type, (VOID_STAR)new_data);
+	(*cl->cl_adestroy) (at->data_type, (VOID_STAR)new_data);
+     }
+
+   return ret;
+}
+
+static int push_string_as_array (unsigned char *s, unsigned int len)
+{
+   int ilen;
+   SLang_Array_Type *at;
+
+   ilen = (int) len;
+
+   at = SLang_create_array (SLANG_UCHAR_TYPE, 0, NULL, &ilen, 1);
+   if (at == NULL)
+     return -1;
+
+   memcpy ((char *)at->data, (char *)s, len);
+   return SLang_push_array (at, 1);
+}
+
+static int pop_array_as_string (char **sp)
+{
+   SLang_Array_Type *at;
+   int ret;
+
+   *sp = NULL;
+
+   if (-1 == SLang_pop_array_of_type (&at, SLANG_UCHAR_TYPE))
+     return -1;
+
+   ret = 0;
+
+   if (NULL == (*sp = SLang_create_nslstring ((char *) at->data, at->num_elements)))
+     ret = -1;
+
+   SLang_free_array (at);
+   return ret;
+}
+
+static int pop_array_as_bstring (SLang_BString_Type **bs)
+{
+   SLang_Array_Type *at;
+   int ret;
+
+   *bs = NULL;
+
+   if (-1 == SLang_pop_array_of_type (&at, SLANG_UCHAR_TYPE))
+     return -1;
+
+   ret = 0;
+
+   if (NULL == (*bs = SLbstring_create ((unsigned char *) at->data, at->num_elements)))
+     ret = -1;
+
+   SLang_free_array (at);
+   return ret;
+}
+
+static int aget_from_array (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;
+
+   if (num_indices > SLARRAY_MAX_DIMS)
+     {
+	SLang_verror (SL_INVALID_PARM, "Number of dims must be less than %d", SLARRAY_MAX_DIMS);
+	return -1;
+     }
+
+   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 push_string_element (unsigned char type, unsigned char *s, unsigned int len)
+{
+   int i;
+
+   if (SLang_peek_at_stack () == SLANG_ARRAY_TYPE)
+     {
+	char *str;
+
+	/* The indices are array values.  So, do this: */
+	if (-1 == push_string_as_array (s, len))
+	  return -1;
+
+	if (-1 == aget_from_array (1))
+	  return -1;
+
+	if (type == SLANG_BSTRING_TYPE)
+	  {
+	     SLang_BString_Type *bs;
+	     int ret;
+
+	     if (-1 == pop_array_as_bstring (&bs))
+	       return -1;
+
+	     ret = SLang_push_bstring (bs);
+	     SLbstring_free (bs);
+	     return ret;
+	  }
+
+	if (-1 == pop_array_as_string (&str))
+	  return -1;
+	return _SLang_push_slstring (str);   /* frees s upon error */
+     }
+
+   if (-1 == SLang_pop_integer (&i))
+     return -1;
+
+   if (i < 0) i = i + (int)len;
+   if ((unsigned int) i > len)
+     i = len;			       /* get \0 character --- bstrings include it as well */
+
+   i = s[(unsigned int) i];
+
+   return SLang_push_integer (i);
+}
+
+/* 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;
+   int type;
+   int (*aget_fun) (unsigned char, unsigned int);
+
+   num_indices = (SLang_Num_Function_Args - 1);
+
+   type = SLang_peek_at_stack ();
+   switch (type)
+     {
+      case -1:
+	return -1;		       /* stack underflow */
+
+      case SLANG_DATATYPE_TYPE:
+	return push_create_new_array ();
+
+      case SLANG_BSTRING_TYPE:
+	if (1 == num_indices)
+	  {
+	     SLang_BString_Type *bs;
+	     int ret;
+	     unsigned int len;
+	     unsigned char *s;
+
+	     if (-1 == SLang_pop_bstring (&bs))
+	       return -1;
+
+	     if (NULL == (s = SLbstring_get_pointer (bs, &len)))
+	       ret = -1;
+	     else
+	       ret = push_string_element (type, s, len);
+
+	     SLbstring_free (bs);
+	     return ret;
+	  }
+	break;
+
+      case SLANG_STRING_TYPE:
+	if (1 == num_indices)
+	  {
+	     char *s;
+	     int ret;
+
+	     if (-1 == SLang_pop_slstring (&s))
+	       return -1;
+
+	     ret = push_string_element (type, (unsigned char *)s, strlen (s));
+	     SLang_free_slstring (s);
+	     return ret;
+	  }
+	break;
+
+      case SLANG_ARRAY_TYPE:
+	break;
+
+      default:
+	aget_fun = _SLclass_get_class (type)->cl_aget;
+	if (NULL != aget_fun)
+	  return (*aget_fun) (type, num_indices);
+     }
+
+   return aget_from_array (num_indices);
+}
+
+int
+_SLarray_aput_transfer_elem (SLang_Array_Type *at, int *indices,
+			     VOID_STAR data_to_put, unsigned int sizeof_type, int is_ptr)
+{
+   VOID_STAR at_data;
+
+   /* Since 1 element is being transferred, there is no need to coerse
+    * the array to linear.
+    */
+   if (NULL == (at_data = get_data_addr (at, indices)))
+     return -1;
+
+   return transfer_n_elements (at, at_data, data_to_put, sizeof_type, 1, is_ptr);
+}
+
+static int
+aput_get_array_to_put (SLang_Class_Type *cl, unsigned int num_elements, int allow_array,
+		       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, allow_array))
+     return -1;
+
+   if ((data_type != SLANG_ARRAY_TYPE)
+       && (data_type != SLANG_ANY_TYPE)
+       && (SLANG_ARRAY_TYPE == SLang_peek_at_stack ()))
+     {
+	if (-1 == SLang_pop_array (&at, 0))
+	  return -1;
+
+	if ((at->num_elements != num_elements)
+#if 0
+	    || (at->num_dims != 1)
+#endif
+	    )
+	  {
+	     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;
+   int is_dim_array [SLARRAY_MAX_DIMS];
+
+   if (-1 == convert_nasty_index_objs (at, index_objs, num_indices,
+				       index_data, range_buf, range_delta_buf,
+				       max_dims, &num_elements, &is_array,
+				       is_dim_array))
+     return -1;
+
+   cl = at->cl;
+
+   if (-1 == aput_get_array_to_put (cl, num_elements, is_array,
+				    &bt, &data_to_put, &data_increment))
+     return -1;
+
+   sizeof_type = at->sizeof_type;
+   is_ptr = (at->flags & SLARR_DATA_VALUE_IS_POINTER);
+
+   ret = -1;
+
+   SLMEMSET((char *) map_indices, 0, sizeof(map_indices));
+   if (num_elements) 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 == _SLarray_aput_transfer_elem (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)
+{
+   int *indices, *indices_max;
+   unsigned int sizeof_type;
+   char *data_to_put, *dest_data;
+   unsigned int data_increment;
+   int is_ptr;
+   SLang_Array_Type *bt;
+   SLang_Class_Type *cl;
+   int ret;
+
+   if (-1 == coerse_array_to_linear (at))
+     return -1;
+
+   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;
+
+   /* Note that if bt is returned as non NULL, then the array is a linear
+    * one.
+    */
+   if (-1 == aput_get_array_to_put (cl, ind_at->num_elements, 1,
+				    &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 & SLARR_DATA_VALUE_IS_POINTER);
+   dest_data = (char *) at->data;
+
+   ret = -1;
+   while (indices < indices_max)
+     {
+	unsigned int offset;
+
+	offset = sizeof_type * (unsigned int)*indices;
+
+	if (-1 == transfer_n_elements (at, (VOID_STAR) (dest_data + offset),
+				       (VOID_STAR) data_to_put, sizeof_type, 1,
+				       is_ptr))
+	  goto return_error;
+
+	indices++;
+	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;
+   int (*aput_fun) (unsigned char, unsigned int);
+   int type;
+
+   ret = -1;
+   num_indices = (SLang_Num_Function_Args - 1);
+
+   type = SLang_peek_at_stack ();
+   switch (type)
+     {
+      case -1:
+	return -1;
+
+      case SLANG_ARRAY_TYPE:
+	break;
+
+      default:
+	if (NULL != (aput_fun = _SLclass_get_class (type)->cl_aput))
+	  return (*aput_fun) (type, num_indices);
+	break;
+     }
+
+   if (-1 == SLang_pop_array (&at, 0))
+     return -1;
+
+   if (at->flags & SLARR_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, 1);
+}
+
+static SLang_Name_Type *Sort_Function;
+static SLang_Array_Type *Sort_Array;
+
+static int sort_cmp_fun (int *a, int *b)
+{
+   int cmp;
+
+   if (SLang_Error
+       || (-1 == push_element_at_index (Sort_Array, *a))
+       || (-1 == push_element_at_index (Sort_Array, *b))
+       || (-1 == SLexecute_function (Sort_Function))
+       || (-1 == SLang_pop_integer (&cmp)))
+     {
+	/* DO not allow qsort to loop forever.  Return something meaningful */
+	if (*a > *b) return 1;
+	if (*a < *b) return -1;
+	return 0;
+     }
+
+   return cmp;
+}
+
+static int builtin_sort_cmp_fun (int *a, int *b)
+{
+   VOID_STAR a_data;
+   VOID_STAR b_data;
+   SLang_Class_Type *cl;
+   
+   cl = Sort_Array->cl;
+
+   if ((SLang_Error == 0)
+       && (NULL != (a_data = get_data_addr (Sort_Array, a)))
+       && (NULL != (b_data = get_data_addr (Sort_Array, b))))
+     {
+	int cmp;
+
+	if ((Sort_Array->flags & SLARR_DATA_VALUE_IS_POINTER)
+	    && ((*(VOID_STAR *) a_data == NULL) || (*(VOID_STAR *) a_data == NULL)))
+	  {
+	     SLang_verror (SL_VARIABLE_UNINITIALIZED,
+			   "%s array has unitialized element", cl->cl_name);
+	  }
+	else if (0 == (*cl->cl_cmp)(Sort_Array->data_type, a_data, b_data, &cmp))
+	  return cmp;
+     }
+       
+       
+   if (*a > *b) return 1;
+   if (*a == *b) return 0;
+   return -1;
+}
+
+static void sort_array_internal (SLang_Array_Type *at_str, 
+				 SLang_Name_Type *entry,
+				 int (*sort_fun)(int *, int *))
+{
+   SLang_Array_Type *ind_at;
+   /* This is a silly hack to make up for braindead compilers and the lack of
+    * uniformity in prototypes for qsort.
+    */
+   void (*qsort_fun) (char *, unsigned int, int, int (*)(int *, int *));
+   int *indx;
+   int i, n;
+   int dims[1];
+
+   if (Sort_Array != NULL)
+     {
+	SLang_verror (SL_NOT_IMPLEMENTED, "array_sort is not recursive");
+	return;
+     }
+
+   n = at_str->num_elements;
+
+   if (at_str->num_dims != 1)
+     {
+	SLang_verror (SL_INVALID_PARM, "sort is restricted to 1 dim arrays");
+	return;
+     }
+
+   dims [0] = n;
+
+   if (NULL == (ind_at = SLang_create_array (SLANG_INT_TYPE, 0, NULL, dims, 1)))
+     return;
+
+   indx = (int *) ind_at->data;
+   for (i = 0; i < n; i++) indx[i] = i;
+
+   if (n > 1)
+     {
+	qsort_fun = (void (*)(char *, unsigned int, int, int (*)(int *,
+								 int *)))
+	  qsort;
+
+	Sort_Array = at_str;
+	Sort_Function = entry;
+	(*qsort_fun) ((char *) indx, n, sizeof (int), sort_fun);
+     }
+
+   Sort_Array = NULL;
+   (void) SLang_push_array (ind_at, 1);
+}
+
+static void sort_array (void)
+{
+   SLang_Name_Type *entry;
+   SLang_Array_Type *at;
+   int (*sort_fun) (int *, int *);
+
+   if (SLang_Num_Function_Args != 1)
+     {
+	sort_fun = sort_cmp_fun;
+
+	if (NULL == (entry = SLang_pop_function ()))
+	  return;
+
+	if (-1 == SLang_pop_array (&at, 1))
+	  return;
+     }
+   else
+     {
+	sort_fun = builtin_sort_cmp_fun;
+	if (-1 == SLang_pop_array (&at, 1))
+	  return;
+	if (at->cl->cl_cmp == NULL)
+	  {
+	     SLang_verror (SL_NOT_IMPLEMENTED, 
+			   "%s does not have a predefined sorting method",
+			   at->cl->cl_name);
+	     SLang_free_array (at);
+	     return;
+	  }
+	entry = NULL;
+     }
+
+   sort_array_internal (at, entry, sort_fun);
+   SLang_free_array (at);
+   SLang_free_function (entry);
+}
+
+static void bstring_to_array (SLang_BString_Type *bs)
+{
+   unsigned char *s;
+   unsigned int len;
+   
+   if (NULL == (s = SLbstring_get_pointer (bs, &len)))
+     (void) SLang_push_null ();
+   else
+     (void) push_string_as_array (s, len);
+}
+
+static void array_to_bstring (SLang_Array_Type *at)
+{
+   unsigned int nbytes;
+   SLang_BString_Type *bs;
+
+   nbytes = at->num_elements * at->sizeof_type;
+   bs = SLbstring_create ((unsigned char *)at->data, nbytes);
+   (void) SLang_push_bstring (bs);
+   SLbstring_free (bs);
+}
+
+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 ((int) 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, idims;
+   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))
+     { */
+	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 |= SLARR_DATA_VALUE_IS_RANGE;
+
+   return at;
+}
+
+#if SLANG_HAS_FLOAT
+static SLang_Array_Type *inline_implicit_floating_array (unsigned char type,
+							 double *xminptr, double *xmaxptr, double *dxptr)
+{
+   int n, i;
+   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;
+     }
+
+   /* I have convinced myself that it is better to use semi-open intervals
+    * because of less ambiguities.  So, [a:b:c] will represent the set of
+    * values a, a + c, a + 2c ... a + nc
+    * such that a + nc < b.  That is, b lies outside the interval.
+    */
+
+   /* Allow for roundoff by adding 0.5 before truncation */
+   n = (int)(1.5 + ((xmax - xmin) / dx));
+   if (n <= 0)
+     n = 0;
+   else
+     {
+	double last = xmin + (n-1) * dx;
+
+	if (dx > 0.0)
+	  {
+	     if (last >= xmax)
+	       n -= 1;
+	  }
+	else if (last <= xmax)
+	  n -= 1;
+     }
+
+   dims = n;
+   if (NULL == (at = SLang_create_array1 (type, 0, NULL, &dims, 1, 1)))
+     return NULL;
+
+   if (type == SLANG_DOUBLE_TYPE)
+     {
+	double *ptr;
+
+	ptr = (double *) at->data;
+
+	for (i = 0; i < n; i++)
+	  ptr[i] = xmin + i * dx;
+     }
+   else
+     {
+	float *ptr;
+
+	ptr = (float *) at->data;
+
+	for (i = 0; i < n; i++)
+	  ptr[i] = (float) (xmin + i * dx);
+     }
+   return at;
+}
+#endif
+
+/* FIXME: Priority=medium
+ * This needs to be updated to work with all integer types.
+ */
+int _SLarray_inline_implicit_array (void)
+{
+   int int_vals[3];
+#if SLANG_HAS_FLOAT
+   double double_vals[3];
+#endif
+   int has_vals[3];
+   unsigned int i, count;
+   SLang_Array_Type *at;
+   int precedence;
+   unsigned char type;
+   int is_int;
+
+   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
+
+   type = 0;
+   precedence = 0;
+
+   i = count;
+   while (i--)
+     {
+	int this_type, this_precedence;
+
+	if (-1 == (this_type = SLang_peek_at_stack ()))
+	  return -1;
+
+	this_precedence = _SLarith_get_precedence ((unsigned char) this_type);
+	if (precedence < this_precedence)
+	  {
+	     type = (unsigned char) this_type;
+	     precedence = this_precedence;
+	  }
+
+	has_vals [i] = 1;
+
+	switch (this_type)
+	  {
+	   case SLANG_NULL_TYPE:
+	     has_vals[i] = 0;
+	     (void) SLdo_pop ();
+	     break;
+
+#if SLANG_HAS_FLOAT
+	   case SLANG_DOUBLE_TYPE:
+	   case SLANG_FLOAT_TYPE:
+	     if (-1 == SLang_pop_double (double_vals + i, NULL, NULL))
+	       return -1;
+	     is_int = 0;
+	     break;
+#endif
+	   default:
+	     if (-1 == SLang_pop_integer (int_vals + i))
+	       return -1;
+	     double_vals[i] = (double) int_vals[i];
+	  }
+     }
+
+#if SLANG_HAS_FLOAT
+   if (is_int == 0)
+     at = inline_implicit_floating_array (type,
+					  (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);
+}
+
+int _SLarray_wildcard_array (void)
+{
+   SLang_Array_Type *at;
+     
+   if (NULL == (at = inline_implicit_int_array (NULL, NULL, 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;
+   int max_dims, min_dims, max_rows, min_rows;
+
+   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;
+   max_dims = min_dims = arrays[0]->num_dims;
+   min_rows = max_rows = arrays[0]->dims[0];
+
+   for (i = 1; i < count; i++)
+     {
+	SLang_Array_Type *ct;
+	int num;
+
+	bt = arrays[i];
+
+	num = bt->num_dims;
+	if (num > max_dims) max_dims = num;
+	if (num < min_dims) min_dims = num;
+
+	num = bt->dims[0];
+	if (num > max_rows) max_rows = num;
+	if (num < min_rows) min_rows = num;
+
+	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 & SLARR_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 (-1 == transfer_n_elements (bt, (VOID_STAR)dest_data, (VOID_STAR)src_data, sizeof_type,
+				       num_elements, is_ptr))
+	  {
+	     SLang_free_array (at);
+	     at = NULL;
+	     goto free_and_return;
+	  }
+
+	dest_data += num_elements * sizeof_type;
+     }
+
+   /* If the arrays are all 1-d, and all the same size, then reshape to a
+    * 2-d array.  This will allow us to do, e.g.
+    * a = [[1,2], [3,4]]
+    * to specifiy a 2-d.
+    * Someday I will generalize this.
+    */
+   if ((max_dims == min_dims) && (max_dims == 1) && (min_rows == max_rows))
+     {
+	at->num_dims = 2;
+	at->dims[0] = count;
+	at->dims[1] = min_rows;
+     }
+
+   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.int_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;
+   int no_init;
+
+   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, 1)))
+     return -1;
+
+   no_init = ((c_cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR)
+	      || (c_cl->cl_class_type == SLANG_CLASS_TYPE_VECTOR));
+
+   ct = NULL;
+#if _SLANG_USE_TMP_OPTIMIZATION
+   /* If we are dealing with scalar (or vector) objects, and if the object
+    * appears to be owned by the stack, then use it instead of creating a 
+    * new version.  This can happen with code such as:
+    * @  x = [1,2,3,4];
+    * @  x = __tmp(x) + 1;
+    */
+   if (no_init)
+     {
+	if ((at != NULL) 
+	    && (at->num_refs == 1)
+	    && (at->data_type == c_cl->cl_data_type))
+	  {
+	     ct = at;
+	     ct->num_refs = 2;
+	  }
+	else if ((bt != NULL) 
+	    && (bt->num_refs == 1)
+	    && (bt->data_type == c_cl->cl_data_type))
+	  {
+	     ct = bt;
+	     ct->num_refs = 2;
+	  }
+     }
+#endif				       /* _SLANG_USE_TMP_OPTIMIZATION */
+   
+   if (ct == NULL)
+     {
+	if (at != NULL) ct = at; else ct = bt;
+	ct = SLang_create_array1 (c_cl->cl_data_type, 0, NULL, ct->dims, ct->num_dims, no_init);
+	if (ct == NULL)
+	  return -1;
+     }
+
+
+   if ((na == 0) || (nb == 0)	       /* allow empty arrays */
+       || (1 == (*binary_fun) (op, a_type, ap, na, b_type, bp, nb, ct->data)))
+     {
+	*(SLang_Array_Type **) cp = ct;
+	return 1;
+     }
+
+   SLang_free_array (ct);
+   return -1;
+}
+
+static void array_where (void)
+{
+   SLang_Array_Type *at, *bt;
+   char *a_data;
+   int *b_data;
+   unsigned int i, num_elements;
+   int b_num;
+
+   if (-1 == SLang_pop_array (&at, 1))
+     return;
+
+   bt = NULL;
+
+   if (at->data_type != SLANG_CHAR_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_CHAR_TYPE, (VOID_STAR) &zero, 1,
+				  (VOID_STAR) &tmp_at))
+	    goto return_error;
+
+	SLang_free_array (at);
+	at = tmp_at;
+	if (at->data_type != SLANG_CHAR_TYPE)
+	  {
+	     SLang_Error = SL_TYPE_MISMATCH;
+	     goto return_error;
+	  }
+     }
+
+   a_data = (char *) at->data;
+   num_elements = at->num_elements;
+
+   b_num = 0;
+   for (i = 0; i < num_elements; i++)
+     if (a_data[i] != 0) b_num++;
+
+   if (NULL == (bt = SLang_create_array1 (SLANG_INT_TYPE, 0, NULL, &b_num, 1, 1)))
+     goto return_error;
+
+   b_data = (int *) bt->data;
+
+   i = 0;
+   while (b_num)
+     {
+	if (a_data[i] != 0)
+	  {
+	     *b_data++ = i;
+	     b_num--;
+	  }
+
+	i++;
+     }
+
+   (void) SLang_push_array (bt, 0);
+   /* drop */
+
+   return_error:
+   SLang_free_array (at);
+   SLang_free_array (bt);
+}
+
+static int do_array_reshape (SLang_Array_Type *at, SLang_Array_Type *ind_at)
+{
+   int *dims;
+   unsigned int i, num_dims;
+   unsigned int num_elements;
+
+   if ((ind_at->data_type != SLANG_INT_TYPE)
+       || (ind_at->num_dims != 1))
+     {
+	SLang_verror (SL_TYPE_MISMATCH, "Expecting 1-d integer array");
+	return -1;
+     }
+
+   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");
+	     return -1;
+	  }
+
+	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");
+	return -1;
+     }
+
+   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;
+   return 0;
+}
+
+static void array_reshape (SLang_Array_Type *at, SLang_Array_Type *ind_at)
+{
+   (void) do_array_reshape (at, ind_at);
+}
+
+static void _array_reshape (SLang_Array_Type *ind_at)
+{
+   SLang_Array_Type *at;
+   SLang_Array_Type *new_at;
+
+   if (-1 == SLang_pop_array (&at, 1))
+     return;
+
+   /* FIXME: Priority=low: duplicate_array could me modified to look at num_refs */
+
+   /* Now try to avoid the overhead of creating a new array if possible */
+   if (at->num_refs == 1)
+     {
+	/* Great, we are the sole owner of this array. */
+	if ((-1 == do_array_reshape (at, ind_at))
+	    || (-1 == SLclass_push_ptr_obj (SLANG_ARRAY_TYPE, (VOID_STAR)at)))
+	  SLang_free_array (at);
+	return;
+     }
+
+   new_at = SLang_duplicate_array (at);
+   if (new_at != NULL)
+     {
+	if (0 == do_array_reshape (new_at, ind_at))
+	  (void) SLang_push_array (new_at, 0);
+	
+	SLang_free_array (new_at);
+     }
+   SLang_free_array (at);
+}
+
+typedef struct
+{
+   SLang_Array_Type *at;
+   unsigned int increment;
+   char *addr;
+}
+Map_Arg_Type;
+/* Usage: array_map (Return-Type, func, args,....); */
+static void array_map (void)
+{
+   Map_Arg_Type *args;
+   unsigned int num_args;
+   unsigned int i, i_control;
+   SLang_Name_Type *nt;
+   unsigned int num_elements;
+   SLang_Array_Type *at;
+   char *addr;
+   unsigned char type;
+
+   at = NULL;
+   args = NULL;
+   nt = NULL;
+
+   if (SLang_Num_Function_Args < 3)
+     {
+	SLang_verror (SL_INVALID_PARM,
+		      "Usage: array_map (Return-Type, &func, args...)");
+	SLdo_pop_n (SLang_Num_Function_Args);
+	return;
+     }
+
+   num_args = (unsigned int)SLang_Num_Function_Args - 2;
+   args = (Map_Arg_Type *) SLmalloc (num_args * sizeof (Map_Arg_Type));
+   if (args == NULL)
+     {
+	SLdo_pop_n (SLang_Num_Function_Args);
+	return;
+     }
+   memset ((char *) args, 0, num_args * sizeof (Map_Arg_Type));
+   i = num_args;
+   i_control = 0;
+   while (i > 0)
+     {
+	i--;
+	if (-1 == SLang_pop_array (&args[i].at, 1))
+	  {
+	     SLdo_pop_n (i + 2);
+	     goto return_error;
+	  }
+	if (args[i].at->num_elements > 1)
+	  i_control = i;
+     }
+
+   if (NULL == (nt = SLang_pop_function ()))
+     {
+	SLdo_pop_n (1);
+	goto return_error;
+     }
+
+   num_elements = args[i_control].at->num_elements;
+
+   if (-1 == _SLang_pop_datatype (&type))
+     goto return_error;
+
+   if (type == SLANG_UNDEFINED_TYPE)   /* Void_Type */
+     at = NULL;
+   else
+     {
+	at = args[i_control].at;
+
+	if (NULL == (at = SLang_create_array (type, 0, NULL, at->dims, at->num_dims)))
+	  goto return_error;
+     }
+   
+
+   for (i = 0; i < num_args; i++)
+     {
+	SLang_Array_Type *ati = args[i].at;
+	/* FIXME: Priority = low: The actual dimensions should be compared. */
+	if (ati->num_elements == num_elements)
+	  args[i].increment = ati->sizeof_type;
+	/* memset already guarantees increment to be zero */
+
+	if (ati->num_elements == 0)
+	  {
+	     SLang_verror (0, "array_map: function argument %d of %d is an empty array", 
+			   i+1, num_args);
+	     goto return_error;
+	  }
+
+	args[i].addr = (char *) ati->data;
+     }
+
+   if (at == NULL)
+     addr = NULL;
+   else
+     addr = (char *)at->data;
+
+   for (i = 0; i < num_elements; i++)
+     {
+	unsigned int j;
+
+	if (-1 == SLang_start_arg_list ())
+	  goto return_error;
+
+	for (j = 0; j < num_args; j++)
+	  {
+	     if (-1 == push_element_at_addr (args[j].at, 
+					     (VOID_STAR) args[j].addr,
+					     1))
+	       {
+		  SLdo_pop_n (j);
+		  goto return_error;
+	       }
+
+	     args[j].addr += args[j].increment;
+	  }
+
+	if (-1 == SLang_end_arg_list ())
+	  {
+	     SLdo_pop_n (num_args);
+	     goto return_error;
+	  }
+
+	if (-1 == SLexecute_function (nt))
+	  goto return_error;
+
+	if (at == NULL)
+	  continue;
+
+	if (-1 == at->cl->cl_apop (type, (VOID_STAR) addr))
+	  goto return_error;
+
+	addr += at->sizeof_type;
+     }
+
+   if (at != NULL)
+     (void) SLang_push_array (at, 0);
+
+   /* drop */
+
+   return_error:
+   SLang_free_array (at);
+   SLang_free_function (nt);
+   if (args != NULL)
+     {
+	for (i = 0; i < num_args; i++)
+	  SLang_free_array (args[i].at);
+
+	SLfree ((char *) args);
+     }
+}
+
+static SLang_Intrin_Fun_Type Array_Table [] =
+{
+   MAKE_INTRINSIC_0("array_map", array_map, SLANG_VOID_TYPE),
+   MAKE_INTRINSIC_0("array_sort", sort_array, SLANG_VOID_TYPE),
+   MAKE_INTRINSIC_1("array_to_bstring", array_to_bstring, SLANG_VOID_TYPE, SLANG_ARRAY_TYPE),
+   MAKE_INTRINSIC_1("bstring_to_array", bstring_to_array, SLANG_VOID_TYPE, SLANG_BSTRING_TYPE),
+   MAKE_INTRINSIC("init_char_array", init_char_array, SLANG_VOID_TYPE, 0),
+   MAKE_INTRINSIC("array_info", array_info, SLANG_VOID_TYPE, 0),
+   MAKE_INTRINSIC("where", array_where, SLANG_VOID_TYPE, 0),
+   MAKE_INTRINSIC_2("reshape", array_reshape, SLANG_VOID_TYPE, SLANG_ARRAY_TYPE, SLANG_ARRAY_TYPE),
+   MAKE_INTRINSIC_1("_reshape", _array_reshape, SLANG_VOID_TYPE, SLANG_ARRAY_TYPE),
+   SLANG_END_INTRIN_FUN_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, "%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;
+   int no_init;
+
+   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;
+
+   no_init = ((b_cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR)
+	      || (b_cl->cl_class_type == SLANG_CLASS_TYPE_VECTOR));
+
+#if _SLANG_USE_TMP_OPTIMIZATION
+   /* If we are dealing with scalar (or vector) objects, and if the object
+    * appears to be owned by the stack, then use it instead of creating a 
+    * new version.  This can happen with code such as:
+    * @  x = [1,2,3,4];
+    * @  x = UNARY_OP(__tmp(x));
+    */
+   if (no_init
+       && (at->num_refs == 1)
+       && (at->data_type == b_cl->cl_data_type))
+     {
+	bt = at;
+	bt->num_refs = 2;
+     }
+   else
+#endif				       /* _SLANG_USE_TMP_OPTIMIZATION */
+     if (NULL == (bt = SLang_create_array1 (b_type, 0, NULL, at->dims, at->num_dims, no_init)))
+       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;
+   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;
+   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;
+   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;
+   SLang_Class_Type *b_cl;
+   int no_init;
+   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;
+
+   b_cl = _SLclass_get_class (b_type);
+
+   no_init = ((b_cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR)
+	      || (b_cl->cl_class_type == SLANG_CLASS_TYPE_VECTOR));
+
+   if (NULL == (bt = SLang_create_array1 (b_type, 0, NULL, at->dims, at->num_dims, no_init)))
+     return -1;
+
+   if (1 == (*t) (a_type, at->data, at->num_elements, b_type, bt->data))
+     {
+	*(SLang_Array_Type **) bp = bt;
+	return 1;
+     }
+
+   SLang_free_array (bt);
+   return 0;
+}
+
+SLang_Array_Type *SLang_duplicate_array (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);
+   unsigned char type;
+
+   if (-1 == coerse_array_to_linear (at))
+     return NULL;
+
+   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 NULL;
+
+   if (NULL == (bt = SLang_create_array (type, 0, (VOID_STAR)data, at->dims, at->num_dims)))
+     {
+	SLfree (data);
+	return NULL;
+     }
+
+   a_data = (char *) at->data;
+   if (0 == (at->flags & SLARR_DATA_VALUE_IS_POINTER))
+     {
+	SLMEMCPY (data, a_data, size);
+	return bt;
+     }
+
+   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 NULL;
+	       }
+	  }
+
+	data += sizeof_type;
+	a_data += sizeof_type;
+     }
+
+   return bt;
+}
+
+static int array_dereference (unsigned char type, VOID_STAR addr)
+{
+   SLang_Array_Type *at;
+
+   (void) type;
+   at = SLang_duplicate_array (*(SLang_Array_Type **) addr);
+   if (at == NULL) return -1;
+   return SLang_push_array (at, 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 0
+   /* The parser generated code for this as if a function call were to be
+    * made.  However, the interpreter simply called the deref object routine
+    * instead of the function call.  So, I must simulate the function call.
+    * This needs to be formalized to hide this detail from applications
+    * who wish to do the same.  So...
+    * FIXME: Priority=medium
+    */
+   if (0 == _SL_increment_frame_pointer ())
+     (void) _SL_decrement_frame_pointer ();
+#endif
+
+   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;
+
+   SLang_free_array (ind_at);
+   return SLang_push_array (at, 1);
+
+   return_error:
+   SLang_free_array (ind_at);
+   return -1;
+}
+
+static int array_length (unsigned char type, VOID_STAR v, unsigned int *len)
+{
+   SLang_Array_Type *at;
+
+   (void) type;
+   at = *(SLang_Array_Type **) v;
+   *len = at->num_elements;
+   return 0;
+}
+
+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;
+   cl->cl_length = array_length;
+
+   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;
+}
+
+int SLang_pop_array_of_type (SLang_Array_Type **at, unsigned char type)
+{
+   if (-1 == SLclass_typecast (type, 1, 1))
+     return -1;
+
+   return SLang_pop_array (at, 1);
+}
+
+void (*_SLang_Matrix_Multiply)(void);
+
+int _SLarray_matrix_multiply (void)
+{
+   if (_SLang_Matrix_Multiply != NULL)
+     {
+	(*_SLang_Matrix_Multiply)();
+	return 0;
+     }
+   SLang_verror (SL_NOT_IMPLEMENTED, "Matrix multiplication not available");
+   return -1;
+}
+
+struct _SLang_Foreach_Context_Type
+{
+   SLang_Array_Type *at;
+   unsigned int next_element_index;
+};
+
+SLang_Foreach_Context_Type *
+_SLarray_cl_foreach_open (unsigned char type, unsigned int num)
+{
+   SLang_Foreach_Context_Type *c;
+
+   if (num != 0)
+     {
+	SLdo_pop_n (num + 1);
+	SLang_verror (SL_NOT_IMPLEMENTED,
+		      "%s does not support 'foreach using' form",
+		      SLclass_get_datatype_name (type));
+	return NULL;
+     }
+
+   if (NULL == (c = (SLang_Foreach_Context_Type *) SLmalloc (sizeof (SLang_Foreach_Context_Type))))
+     return NULL;
+
+   memset ((char *) c, 0, sizeof (SLang_Foreach_Context_Type));
+
+   if (-1 == pop_array (&c->at, 1))
+     {
+	SLfree ((char *) c);
+	return NULL;
+     }
+
+   return c;
+}
+
+void _SLarray_cl_foreach_close (unsigned char type, SLang_Foreach_Context_Type *c)
+{
+   (void) type;
+   if (c == NULL) return;
+   SLang_free_array (c->at);
+   SLfree ((char *) c);
+}
+
+int _SLarray_cl_foreach (unsigned char type, SLang_Foreach_Context_Type *c)
+{
+   SLang_Array_Type *at;
+   VOID_STAR data;
+
+   (void) type;
+
+   if (c == NULL)
+     return -1;
+
+   at = c->at;
+   if (at->num_elements == c->next_element_index)
+     return 0;
+
+   /* FIXME: Priority = low.  The following assumes linear arrays
+    * or Integer range arrays.  Fixing it right requires a method to get the
+    * nth element of a multidimensional array.
+    */
+
+   if (at->flags & SLARR_DATA_VALUE_IS_RANGE)
+     {
+	int d = (int) c->next_element_index;
+	data = range_get_data_addr (at, &d);
+     }
+   else
+     data = (VOID_STAR) ((char *)at->data + (c->next_element_index * at->sizeof_type));
+
+   c->next_element_index += 1;
+
+   if ((at->flags & SLARR_DATA_VALUE_IS_POINTER)
+       && (*(VOID_STAR *) data == NULL))
+     {
+	if (-1 == SLang_push_null ())
+	  return -1;
+     }
+   else if (-1 == (*at->cl->cl_apush)(at->data_type, data))
+     return -1;
+
+   /* keep going */
+   return 1;
+}
+