slarray.c

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

     }

   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];
   int is_int;
#endif
   int has_vals[3];
   unsigned int i, count;
   SLang_Array_Type *at;
   int precedence;
   unsigned char type;

   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;
#if SLANG_HAS_FLOAT
	     double_vals[i] = (double) int_vals[i];
#endif
	  }
     }

#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 0   
   /* 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.
    */
   /* This is a bad idea.  Everyone using it expects concatenation to happen.
    * Perhaps I will extend the syntax to allow a 2-d array to be expressed
    * as [[1,2];[3,4]].
    */
   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;
     }
#endif
   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, *objmin;
   unsigned char type, this_type;
   unsigned int count;
   SLang_Array_Type *at;

   obj = _SLang_get_run_stack_pointer ();
   objmin = _SLang_get_run_stack_base ();

   count = SLang_Num_Function_Args;
   type = 0;

   while ((count > 0) && (--obj >= objmin))
     {
	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;
#if SLANG_HAS_COMPLEX
	   case SLANG_COMPLEX_TYPE:
	     if (0 == _SLang_is_arith_type (type))
	       goto type_mismatch;
	     
	     type = this_type;
	     break;
#endif
	   default:
	     if (0 == _SLang_is_arith_type(this_type))
	       goto type_mismatch;
	     
	     if (type == SLANG_COMPLEX_TYPE)
	       break;
	     
	     if (0 == _SLang_is_arith_type (type))
	       goto type_mismatch;
	     
	     if (_SLarith_get_precedence (this_type) > _SLarith_get_precedence (type))
	       type = this_type;
	     break;
	  }
	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);

   type_mismatch:
   _SLclass_type_mismatch_error (type, this_type);
   return -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)
     {