slarray.c

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

	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 is_null_intrinsic (SLang_Array_Type *at)
{
   SLang_Array_Type *bt;

   bt = SLang_create_array (SLANG_CHAR_TYPE, 0, NULL, at->dims, at->num_dims);
   if (bt == NULL)
     return;

   if (at->flags & SLARR_DATA_VALUE_IS_POINTER)
     {
	char *cdata, *cdata_max;
	char **data;

	if (-1 == coerse_array_to_linear (at))
	  {
	     SLang_free_array (bt);
	     return;
	  }
	
	cdata = (char *)bt->data;
	cdata_max = cdata + bt->num_elements;
	data = (char **)at->data;
	
	while (cdata < cdata_max)
	  {
	     if (*data == NULL)
	       *cdata = 1;
	     
	     data++;
	     cdata++;
	  }
     }
   
   SLang_push_array (bt, 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 */

	/* FIXME: array_map on an empty array should return an empty array
	 * and not generate an error.
	 */
	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_1("_isnull", is_null_intrinsic, SLANG_VOID_TYPE, SLANG_ARRAY_TYPE),
   MAKE_INTRINSIC_0("array_info", array_info, SLANG_VOID_TYPE),
   MAKE_INTRINSIC_0("where", array_where, SLANG_VOID_TYPE),
   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