This commit was manufactured by cvs2svn to create tag 'V1_1_9_1mdk'.V1_1_9_1mdk

1 files changed, 0 insertions, 3139 deletions

diff --git a/mdk-stage1/slang/slarray.c b/mdk-stage1/slang/slarray.c
deleted file mode 100644
index 0b9a1406c..000000000
--- a/mdk-stage1/slang/slarray.c
+++ /dev/null
@@ -1,3139 +0,0 @@
-/* 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;
-}
-