slarray.c

Go to the documentation of this file.

/* Array manipulation routines for S-Lang */
/*
Copyright (C) 2004, 2005, 2006 John E. Davis

This file is part of the S-Lang Library.

The S-Lang Library is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License as
published by the Free Software Foundation; either version 2 of the
License, or (at your option) any later version.

The S-Lang Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.  
*/


#include "slinclud.h"

/* #define SL_APP_WANTS_FOREACH */
#include "slang.h"
#include "_slang.h"

typedef struct Range_Array_Type SLarray_Range_Array_Type;

struct Range_Array_Type
{
   SLindex_Type first_index;
   SLindex_Type last_index;
   SLindex_Type delta;
   int has_first_index;
   int has_last_index;
   int (*to_linear_fun) (SLang_Array_Type *, SLarray_Range_Array_Type *, VOID_STAR);
};

static SLang_Array_Type *inline_implicit_int_array (SLindex_Type *, SLindex_Type *, SLindex_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;
   SLindex_Type 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; */  /* commented out for 2.0.5 to fix array_map NULL bug */
        /* 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 ((SLtype) type, 0, NULL, &one, 1)))
     return -1;

   if (at->flags & SLARR_DATA_VALUE_IS_POINTER)
     {
        /* The act of creating the array could have initialized the array
         * with pointers to an object of the type.  For example, this could
         * happen with user-defined structs.
         */
        if (*(VOID_STAR *)at->data != NULL)
          {
             at->cl->cl_destroy ((SLtype) type, at->data);
             *(VOID_STAR *) at->data = NULL;
          }
     }

   if (-1 == at->cl->cl_apop ((SLtype) 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, SLindex_Type *dims)
{
   size_t ofs;

   if (at->num_dims == 1)
     {
        if (*dims < 0)
          ofs = (size_t) (*dims + at->dims[0]);
        else
          ofs = (size_t)*dims;
     }
   else 
     {
        unsigned int i;
        SLindex_Type *max_dims = at->dims;
        unsigned int num_dims = at->num_dims;
        ofs = 0;
        for (i = 0; i < num_dims; i++)
          {
             SLindex_Type d = dims[i];
             
             if (d < 0)
               d = d + max_dims[i];
             
             ofs = ofs * (size_t)max_dims [i] + (size_t) d;
          }
     }
   if (ofs >= at->num_elements)
     {
        SLang_set_error (SL_Index_Error);
        return NULL;
     }
   return (VOID_STAR) ((char *)at->data + (ofs * at->sizeof_type));
}

_INLINE_
static VOID_STAR get_data_addr (SLang_Array_Type *at, SLindex_Type *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 _pSLarray_free_array_elements (SLang_Class_Type *cl, VOID_STAR s, SLuindex_Type num)
{
   size_t sizeof_type;
   void (*f) (SLtype, VOID_STAR);
   char *p;
   SLtype 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,
                            SLindex_Type *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,
                               SLindex_Type *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);
}

int _pSLarray_next_index (SLindex_Type *dims, SLindex_Type *max_dims, unsigned int num_dims)
{
   while (num_dims)
     {
        SLindex_Type 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 *,
                                                     SLindex_Type *,
                                                     VOID_STAR),
                                       VOID_STAR client_data)
{
   SLindex_Type dims [SLARRAY_MAX_DIMS];
   SLindex_Type *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 == _pSLarray_next_index (dims, max_dims, num_dims));

   return 0;
}

void SLang_free_array (SLang_Array_Type *at)
{
   unsigned int flags;

   if (at == NULL) return;

   if (at->num_refs > 1)
     {
        at->num_refs -= 1;
        return;
     }

   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);

   if (at->free_fun != NULL)
     at->free_fun (at);
   else
     SLfree ((char *) at->data);

   SLfree ((char *) at);
}

SLang_Array_Type *
SLang_create_array1 (SLtype type, int read_only, VOID_STAR data,
                     SLindex_Type *dims, unsigned int num_dims, int no_init)
{
   SLang_Class_Type *cl;
   SLang_Array_Type *at;
   SLuindex_Type i, num_elements;
   size_t sizeof_type;
   size_t 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 = _pSLclass_get_class (type);

   at = (SLang_Array_Type *) SLmalloc (sizeof(SLang_Array_Type));
   if (at == NULL)
     return NULL;

   memset ((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;

   if ((cl->cl_class_type != SLANG_CLASS_TYPE_SCALAR)
       && (cl->cl_class_type != SLANG_CLASS_TYPE_VECTOR))
     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 = (size_t) (num_elements * sizeof_type);
   if (size/sizeof_type != num_elements)
     {
        SLang_verror (SL_INVALID_PARM, "Unable to create array of the desired size");
        SLang_free_array (at);
        return NULL;
     }

   if (size == 0) size = 1;

   if (NULL == (data = (VOID_STAR) SLmalloc (size)))
     {
        SLang_free_array (at);
        return NULL;
     }

   at->data = data;

   if ((no_init == 0) || (at->flags & SLARR_DATA_VALUE_IS_POINTER))
     memset ((char *) data, 0, size);
   
   if ((no_init == 0)
       && (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 (SLtype type, int read_only, VOID_STAR data,
                    SLindex_Type *dims, unsigned int num_dims)
{
   return SLang_create_array1 (type, read_only, data, dims, num_dims, 0);
}

int SLang_add_intrinsic_array (char *name,
                               SLtype type,
                               int read_only,
                               VOID_STAR data,
                               unsigned int num_dims, ...)
{
   va_list ap;
   unsigned int i;
   SLindex_Type 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 (SLindex_Type *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 (unsigned int num_dims)
{
   SLang_Array_Type *at;
   SLtype type;
   SLindex_Type dims [SLARRAY_MAX_DIMS];
   int (*anew) (SLtype, unsigned int);

   if (-1 == SLang_pop_datatype (&type))
     return -1;

   anew = (_pSLclass_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 uninitialized 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;
   VOID_STAR vdata;
   SLuindex_Type 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;
   if ((range->has_last_index == 0) || (range->has_first_index == 0))
     {
        SLang_verror (SL_INVALID_PARM, "Invalid context for a range array of indeterminate size");
        return -1;
     }

   imax = at->num_elements;
   vdata = (VOID_STAR) SLmalloc ((imax + 1) * at->sizeof_type);
   if (vdata == NULL)
     return -1;
   (void) (*range->to_linear_fun)(at, range, vdata);
   SLfree ((char *) range);
   at->data = (VOID_STAR) vdata;
   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_Array_Type *at_to_index,
             SLang_Object_Type *index_objs, unsigned int num_indices,
             int *is_index_array)
{
   unsigned int i;

   memset((char *) index_objs, 0, num_indices * sizeof (SLang_Object_Type));

   *is_index_array = 0;

   if (num_indices != at_to_index->num_dims)
     {
        if (num_indices != 1)          /* when 1, it is an index array */
          {
             SLang_verror (SL_INVALID_PARM, "wrong number of indices for array");
             return -1;
          }
     }

   i = num_indices;
   while (i != 0)
     {
        SLang_Object_Type *obj;
        SLtype data_type;
        SLang_Array_Type *at;

        i--;
        obj = index_objs + i;
        if (SLANG_ARRAY_TYPE != _pSLang_peek_at_stack2 (&data_type))
          {
             if (-1 == _pSLang_pop_object_of_type (SLANG_ARRAY_INDEX_TYPE, obj, 0))
               goto return_error;
             
             continue;
          }
        if (data_type != SLANG_ARRAY_INDEX_TYPE)
          {
             if (-1 == SLclass_typecast (SLANG_ARRAY_INDEX_TYPE, 1, 1))
               return -1;
          }
        if (-1 == SLang_pop (obj))
          goto return_error;

        at = obj->v.array_val;
        if (at->flags & SLARR_DATA_VALUE_IS_RANGE)
          {
             SLarray_Range_Array_Type *r = (SLarray_Range_Array_Type *) at->data;
             if ((r->has_last_index == 0) || (r->has_first_index == 0))
               {
                  /* Cases to consider (positive increment)
                   *   [:]  ==> [0:n-1] all elements
                   *   [:i] ==> [0:i] for i>=0, [0:n+i] for i<0
                   *   [i:] ==> [i:n-1] for i>=0, [i+n:n-1] for i<0
                   * This will allow: [:-3] to index all but last 3, etc.
                   * Also consider cases with a negative increment:
                   *   [::-1] = [n-1,n-2,...0] = [n-1:0:-1]
                   *   [:i:-1] = [n-1,n-2,..i] = [n-1:i:-1]
                   *   [i::-1] = [i,i-1,...0] = [i:0:-1] 
                   */
                  SLang_Array_Type *new_at;
                  SLindex_Type first_index, last_index;
                  SLindex_Type delta = r->delta;
                  SLindex_Type n;

                  if (num_indices == 1)/* could be index array */
                    n = (SLindex_Type)at_to_index->num_elements;
                  else
                    n = at_to_index->dims[i];

                  if (r->has_first_index)
                    {
                       /* Case 3 */
                       first_index = r->first_index;
                       if (first_index < 0) first_index += n;
                       if (delta > 0) last_index = n-1; else last_index = 0;
                    }
                  else if (r->has_last_index)
                    {
                       /* case 2 */
                       if (delta > 0) first_index = 0; else first_index = n-1;
                       last_index = r->last_index;
                       if (last_index < 0)
                         last_index += n;
                    }
                  else
                    {
                       /* case 0 */
                       if (delta > 0)
                         {
                            first_index = 0;
                            last_index = n - 1;
                         }
                       else
                         {
                            first_index = n-1;
                            last_index = 0;
                         }
                    }

                  if (NULL == (new_at = inline_implicit_int_array (&first_index, &last_index, &delta)))
                    goto return_error;
             
                  SLang_free_array (at);
                  obj->v.array_val = new_at;
               }
          }
        if (num_indices == 1)
          {
             *is_index_array = 1;
             return 0;
          }
     }
   return 0;

   return_error:
   free_index_objects (index_objs, num_indices);
   return -1;
}

static void do_index_error (SLindex_Type i, SLindex_Type indx, SLindex_Type dim)
{
   SLang_verror (SL_Index_Error, "Array index %u (value=%ld) out of allowed range 0<=index<%ld",
                 i, (long)indx, (long)dim);
}

static int
transfer_n_elements (SLang_Array_Type *at, VOID_STAR dest_data, VOID_STAR src_data,
                     size_t sizeof_type, SLuindex_Type n, int is_ptr)
{
   SLtype 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;
}

_INLINE_
int
_pSLarray_aget_transfer_elem (SLang_Array_Type *at, SLindex_Type *indices,
                             VOID_STAR new_data, size_t sizeof_type, int is_ptr)
{
   VOID_STAR at_data;

   /* Since 1 element is being transferred, there is no need to coerce
    * the array to linear.
    */
   if (NULL == (at_data = get_data_addr (at, indices)))
     return -1;

   if (is_ptr == 0)
     {
        memcpy ((char *) new_data, (char *)at_data, sizeof_type);
        return 0;
     }

   return transfer_n_elements (at, new_data, at_data, sizeof_type, 1, is_ptr);
}

/* Here the ind_at index-array is an n-d array of indices.  This function
 * creates an n-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;
   SLindex_Type *indices, *indices_max, num_elements;
   unsigned char *new_data, *src_data;
   size_t 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 (NULL == (new_at = SLang_create_array (at->data_type, 0, NULL, ind_at->dims, ind_at->num_dims)))
     return -1;

   /* Since the index array is linear, I can address it directly */
   indices = (SLindex_Type *) ind_at->data;
   indices_max = indices + ind_at->num_elements;

   src_data = (unsigned char *) at->data;
   new_data = (unsigned char *) new_at->data;
   num_elements = (SLindex_Type) at->num_elements;
   sizeof_type = new_at->sizeof_type;
   is_ptr = (new_at->flags & SLARR_DATA_VALUE_IS_POINTER);

   while (indices < indices_max)
     {
        size_t offset;
        SLindex_Type i = *indices;

        if (i < 0) 
          {
             i += num_elements;
             if (i < 0)
               i = num_elements;
          }
        if (i >= num_elements)
          {
             SLang_set_error (SL_Index_Error);
             SLang_free_array (new_at);
             return -1;
          }

        offset = sizeof_type * (SLuindex_Type)i;
        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,
                          SLindex_Type **index_data,
                          SLindex_Type *range_buf, SLindex_Type *range_delta_buf,
                          SLindex_Type *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++)
     {
        SLang_Object_Type *obj = index_objs + i;
        range_delta_buf [i] = 0;

        if (obj->data_type == SLANG_ARRAY_INDEX_TYPE)
          {
             range_buf [i] = obj->v.index_val;
             max_dims [i] = 1;
             index_data[i] = range_buf + i;
             is_dim_array[i] = 0;
          }
#if SLANG_ARRAY_INDEX_TYPE != SLANG_INT_TYPE
        else if (obj->data_type == SLANG_INT_TYPE)
          {
             range_buf [i] = obj->v.int_val;
             max_dims [i] = 1;
             index_data[i] = range_buf + i;
             is_dim_array[i] = 0;
          }
#endif
        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;

                  r = (SLarray_Range_Array_Type *) ind_at->data;
                  range_buf[i] = r->first_index;
                  range_delta_buf [i] = r->delta;
                  max_dims[i] = (SLindex_Type) ind_at->num_elements;
               }
             else
               {
                  index_data [i] = (SLindex_Type *) ind_at->data;
                  max_dims[i] = (SLindex_Type) ind_at->num_elements;
               }
          }

        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)
{
   SLindex_Type *index_data [SLARRAY_MAX_DIMS];
   SLindex_Type range_buf [SLARRAY_MAX_DIMS];
   SLindex_Type range_delta_buf [SLARRAY_MAX_DIMS];
   SLindex_Type max_dims [SLARRAY_MAX_DIMS];
   unsigned int i, num_elements;
   SLang_Array_Type *new_at;
   SLindex_Type map_indices[SLARRAY_MAX_DIMS];
   SLindex_Type indices [SLARRAY_MAX_DIMS];
   SLindex_Type *at_dims;
   size_t 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 = _pSLclass_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
     {
        SLindex_Type i_num_elements = (SLindex_Type)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;
     }
   
   at_dims = at->dims;
   memset ((char *) map_indices, 0, sizeof(map_indices));
   while (1)
     {
        for (i = 0; i < num_indices; i++)
          {
             SLindex_Type j = map_indices[i];
             SLindex_Type indx;

             if (0 != range_delta_buf[i])
               indx = range_buf[i] + j * range_delta_buf[i];
             else
               indx = index_data [i][j];

             if (indx < 0)
               indx += at_dims[i];

             if ((indx < 0) || (indx >= at_dims[i]))
               {
                  do_index_error (i, indx, at_dims[i]);
                  SLang_free_array (new_at);
                  return -1;
               }
             indices[i] = indx;
          }

        if (-1 == _pSLarray_aget_transfer_elem (at, indices, (VOID_STAR)new_data, sizeof_type, is_ptr))
          {
             SLang_free_array (new_at);
             return -1;
          }
        new_data += sizeof_type;
        if (num_indices == 1) 
          {
             map_indices[0]++;
             if (map_indices[0] == max_dims[0])
               break;
          }
        else if (0 != _pSLarray_next_index (map_indices, max_dims, num_indices))
          break;        
     }

   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)
{
   SLindex_Type ilen;
   SLang_Array_Type *at;

   ilen = (SLindex_Type) 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 (at, index_objs, num_indices, &is_index_array))
     {
        SLang_free_array (at);
        return -1;
     }

   if (is_index_array == 0)
     {
#if SLANG_OPTIMIZE_FOR_SPEED
        if ((num_indices == 1) && (index_objs[0].data_type == SLANG_INT_TYPE)
            && (0 == (at->flags & (SLARR_DATA_VALUE_IS_RANGE|SLARR_DATA_VALUE_IS_POINTER)))
            && (1 == at->num_dims)
            && (at->data != NULL))
          {
             SLindex_Type ofs = index_objs[0].v.int_val;
             if (ofs < 0) ofs += at->dims[0];
             if ((ofs >= at->dims[0]) || (ofs < 0))
               ret = aget_from_indices (at, index_objs, num_indices);
             else switch (at->data_type)
               {
                case SLANG_CHAR_TYPE:
                  ret = SLclass_push_char_obj (SLANG_CHAR_TYPE, *((char *)at->data + ofs));
                  break;
                case SLANG_INT_TYPE:
                  ret = SLclass_push_int_obj (SLANG_INT_TYPE, *((int *)at->data + ofs));
                  break;
#if SLANG_HAS_FLOAT
                case SLANG_DOUBLE_TYPE:
                  ret = SLclass_push_double_obj (SLANG_DOUBLE_TYPE, *((double *)at->data + ofs));
                  break;
#endif
                default:
                  ret = aget_from_indices (at, index_objs, num_indices);
               }
          }
        else
#endif
        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 (SLtype 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 _pSLang_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 */

   return SLang_push_uchar (s[(unsigned int)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 array of indices.  The 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 _pSLarray_aget1 (unsigned int num_indices)
{
   int type;
   int (*aget_fun) (SLtype, unsigned int);

   type = SLang_peek_at_stack ();
   switch (type)
     {
      case -1:
        return -1;                     /* stack underflow */

      case SLANG_DATATYPE_TYPE:
        return push_create_new_array (num_indices);

      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, _pSLstring_bytelen (s));
             _pSLang_free_slstring (s);
             return ret;
          }
        break;

      case SLANG_ARRAY_TYPE:
        break;

      case SLANG_ASSOC_TYPE:
        return _pSLassoc_aget (type, num_indices);

      default:
        aget_fun = _pSLclass_get_class (type)->cl_aget;
        if (NULL != aget_fun)
          return (*aget_fun) (type, num_indices);
     }

   return aget_from_array (num_indices);
}

int _pSLarray_aget (void)
{
   return _pSLarray_aget1 ((unsigned int)(SLang_Num_Function_Args-1));
}



_INLINE_ int
_pSLarray_aput_transfer_elem (SLang_Array_Type *at, SLindex_Type *indices,
                             VOID_STAR data_to_put, size_t sizeof_type, int is_ptr)
{
   VOID_STAR at_data;

   /* 
    * A range array is not allowed here.  I should add a check for it.  At
    * the moment, one will not get here.
    */
   if (NULL == (at_data = get_data_addr (at, indices)))
     return -1;

   if (is_ptr == 0)
     {
        memcpy ((char *) at_data, (char *)data_to_put, sizeof_type);
        return 0;
     }

   return transfer_n_elements (at, at_data, data_to_put, sizeof_type, 1, is_ptr);
}

static int
aput_get_data_to_put (SLang_Class_Type *cl, unsigned int num_elements, int allow_array,
                       SLang_Array_Type **at_ptr, char **data_to_put, SLuindex_Type *data_increment)
{
   SLtype data_type;
   int type;
   SLang_Array_Type *at;
   
   *at_ptr = NULL;

   data_type = cl->cl_data_type;
   type = SLang_peek_at_stack ();

   if ((SLtype)type != data_type)
     {
        if ((type != SLANG_NULL_TYPE)
            || ((cl->cl_class_type != SLANG_CLASS_TYPE_PTR)
                && (cl->cl_class_type != SLANG_CLASS_TYPE_MMT)))
          {
             if (-1 == SLclass_typecast (data_type, 1, allow_array))
               return -1;
          }
        else
          {
             /* This bit of code allows, e.g., a[10] = NULL; */
             *data_increment = 0;
             *data_to_put = (char *) cl->cl_transfer_buf;
             *((char **)cl->cl_transfer_buf) = NULL;
             return SLdo_pop ();
          }
     }

   if (allow_array
       && (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_Index_Error, "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)
{
   SLindex_Type *index_data [SLARRAY_MAX_DIMS];
   SLindex_Type range_buf [SLARRAY_MAX_DIMS];
   SLindex_Type range_delta_buf [SLARRAY_MAX_DIMS];
   SLindex_Type max_dims [SLARRAY_MAX_DIMS];
   SLindex_Type *at_dims;
   unsigned int i, num_elements;
   SLa