slarray.c

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

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

      case SLANG_ASSOC_TYPE:
	return _SLassoc_aget (type, num_indices);

      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;
   int type;
   SLang_Array_Type *at;
   
   *at_ptr = NULL;

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

   if (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 ((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 == _SLarray_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;

      case SLANG_ASSOC_TYPE:
	return _SLassoc_aput (type, num_indices);

      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 (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))
	  {
	     int ofs = index_objs[0].v.int_val;
	     if (ofs < 0) ofs += at->dims[0];
	     if ((ofs >= at->dims[0]) || (ofs < 0))
	       ret = aput_from_indices (at, index_objs, num_indices);
	     else switch (at->data_type)
	       {
		case SLANG_INT_TYPE:
		  ret = SLang_pop_integer (((int *)at->data + ofs));
		  break;
#if SLANG_HAS_FLOAT
		case SLANG_DOUBLE_TYPE:
		  ret = SLang_pop_double ((double *)at->data + ofs, NULL, NULL);
		  break;
#endif
		default:
		  ret = aput_from_indices (at, index_objs, num_indices);
	       }
	  }
	else
#endif
	  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;

#if _SLANG_OPTIMIZE_FOR_SPEED
static int double_sort_fun (int *a, int *b)
{
   double *da, *db;
   
   da = (double *) Sort_Array->data;
   db = da + *b;
   da = da + *a;

   if (*da > *db) return 1;
   if (*da == *db) return 0;
   return -1;
}
static int int_sort_fun (int *a, int *b)
{
   int *da, *db;
   
   da = (int *) Sort_Array->data;
   db = da + *b;
   da = da + *a;

   if (*da > *db) return 1;
   if (*da == *db) return 0;
   return -1;
}
#endif

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
     {
	if (-1 == SLang_pop_array (&at, 1))
	  return;
	
#if _SLANG_OPTIMIZE_FOR_SPEED
	if (at->data_type == SLANG_DOUBLE_TYPE)
	  sort_fun = double_sort_fun;
	else if (at->data_type == SLANG_INT_TYPE)
	  sort_fun = int_sort_fun;
	else
#endif
	  sort_fun = builtin_sort_cmp_fun;

	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;