slarray.c

一个C格式的脚本处理函数库源代码,可让你的C程序具有执行C格式的脚本文件

/* Array manipulation routines for S-Lang */
/* Copyright (c) 1997, 1999, 2001, 2002, 2003 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);
}

int _SLarray_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 == _SLarray_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 (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_Array_Type *at_to_index,
	     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)
	       {
		  /* Note: Suppose a = Int_Type[10, 10].  Then the check
		   * on the range flag prevents this from being indexed by
		   * a range such as 'a[[0:99]]'
		   */
		  if (num_indices == 1)
		    {
		       if ((at_to_index->num_dims > 1)
			   || (0 == (at->flags & SLARR_DATA_VALUE_IS_RANGE)))
			 *is_index_array = 1;
		    }
	       }
	     else
	       {