slarrfun.c

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

	     c_type = SLANG_COMPLEX_TYPE;
	     fun = innerprod_float_complex;
	     break;
#endif
	  }
	break;
      case SLANG_DOUBLE_TYPE:
	switch (b->data_type)
	  {
	   case SLANG_FLOAT_TYPE:
	     c_type = SLANG_DOUBLE_TYPE;
	     fun = innerprod_double_float;
	     break;
	   case SLANG_DOUBLE_TYPE:
	     c_type = SLANG_DOUBLE_TYPE;
	     fun = innerprod_double_double;
	     break;
#if SLANG_HAS_COMPLEX
	   case SLANG_COMPLEX_TYPE:
	     c_type = SLANG_COMPLEX_TYPE;
	     fun = innerprod_double_complex;
	     break;
#endif
	  }
	break;
#if SLANG_HAS_COMPLEX
      case SLANG_COMPLEX_TYPE:
	c_type = SLANG_COMPLEX_TYPE;
	switch (b->data_type)
	  {
	   case SLANG_FLOAT_TYPE:
	     fun = innerprod_complex_float;
	     break;
	   case SLANG_DOUBLE_TYPE:
	     fun = innerprod_complex_double;
	     break;
	   case SLANG_COMPLEX_TYPE:
	     fun = innerprod_complex_complex;
	     break;
	  }
	break;
#endif
      default:
	break;
     }

   if (NULL == (c = SLang_create_array (c_type, 0, NULL, dims, num_dims)))
     goto free_and_return;

   (*fun)(a, b, c, a_loops, a_stride, b_loops, b_inc, ai_dims);

   (void) SLang_push_array (c, 1);
   /* drop */

   free_and_return:
   SLang_free_array (a);
   SLang_free_array (b);
}
#endif

static int map_or_contract_array (SLCONST SLarray_Map_Type *c, int use_contraction,
				  int dim_specified, int *use_this_dim, 
				  VOID_STAR clientdata)
{
   int k, use_all_dims;
   SLang_Array_Type *at, *new_at;
   int *old_dims;
   int old_dims_buf[SLARRAY_MAX_DIMS];
   int sub_dims[SLARRAY_MAX_DIMS];
   int tmp_dims[SLARRAY_MAX_DIMS];
   unsigned int i, j, old_num_dims, sub_num_dims;
   SLtype new_data_type, old_data_type;
   char *old_data, *new_data;
   int w[SLARRAY_MAX_DIMS], wk;
   unsigned int old_sizeof_type, new_sizeof_type;
   unsigned int dims_k;
   int from_type;
   SLCONST SLarray_Map_Type *csave;
   SLarray_Map_Fun_Type *fmap;
   SLarray_Contract_Fun_Type *fcon;

   use_all_dims = 1;
   k = 0;
   if (dim_specified)
     {
	if (use_this_dim != NULL)
	  {
	     k = *use_this_dim;
	     use_all_dims = 0;
	  }
     }
   else if (SLang_Num_Function_Args == 2)
     {
	if (-1 == SLang_pop_integer (&k))
	  return -1;

	use_all_dims = 0;
     }

   if (-1 == (from_type = SLang_peek_at_stack1 ()))
     return -1;

   csave = c;
   while (c->f != NULL)
     {
	if (c->from_type == (SLtype) from_type)
	  break;
	c++;
     }

   /* Look for a more generic version */
   if (c->f != NULL)
     {
	if (-1 == SLang_pop_array_of_type (&at, c->typecast_to_type))
	  return -1;
     }
   else
     {
	/* Look for a wildcard match */
	c = csave;
	while (c->f != NULL)
	  {
	     if (c->from_type == SLANG_VOID_TYPE)
	       break;
	     c++;
	  }
	if (c->f == NULL)
	  {
	     SLang_verror (SL_TYPE_MISMATCH, "%s is not supported by this function", SLclass_get_datatype_name (from_type));
	     return -1;
	  }
	
	/* Found it. So, typecast it to appropriate type */
	if (c->typecast_to_type == SLANG_VOID_TYPE)
	  {
	     if (-1 == SLang_pop_array (&at, 1))
	       return -1;
	  }
	else if (-1 == SLang_pop_array_of_type (&at, c->typecast_to_type))
	  return -1;
     }

   old_data_type = at->data_type;
   if (SLANG_VOID_TYPE == (new_data_type = c->result_type))
     new_data_type = old_data_type;

   old_num_dims = at->num_dims;

   if (use_all_dims == 0)
     {
	if (k < 0)
	  k += old_num_dims;

	if ((k < 0) || (k >= (int)old_num_dims))
	  {
	     SLang_verror (SL_INVALID_PARM, "Dimension %d is invalid for a %d-d array",
			   k, old_num_dims);
	     SLang_free_array (at);
	     return -1;
	  }
	old_dims = at->dims;
     }
   else
     {
	old_dims = old_dims_buf;
	old_dims[0] = at->num_elements;
	old_num_dims = 1;
     }
   
   fcon = (SLarray_Contract_Fun_Type *) c->f;
   fmap = c->f;

   if (use_contraction 
       && (use_all_dims || (old_num_dims == 1)))
     {
	SLang_Class_Type *cl;
	VOID_STAR buf;
	int status = 0;
	
	cl = _SLclass_get_class (new_data_type);
	buf = cl->cl_transfer_buf;

	if ((-1 == (*fcon) (at->data, 1, at->num_elements, buf))
	    || (-1 == SLang_push_value (new_data_type, buf)))
	  status = -1;
	
	SLang_free_array (at);
	return status;
     }

   /* The offset for the index i_0,i_1,...i_{N-1} is
    * i_0*W_0 + i_1*W_1 + ... i_{N-1}*W{N-1}
    * where W_j = d_{j+1}d_{j+2}...d_{N-1}
    * and d_k is the number of elements of the kth dimension.
    * 
    * For a specified value of k, we
    * So, summing over all elements in the kth dimension of the array
    * means using the set of offsets given by 
    *  
    *   i_k*W_k + sum(j!=k) i_j*W_j.
    *
    * So, we want to loop of all dimensions except for the kth using an 
    * offset given by sum(j!=k)i_jW_j, and an increment W_k between elements.
    */

   wk = 1;
   i = old_num_dims;
   while (i != 0)
     {
	i--;
	w[i] = wk;
	wk *= old_dims[i];
     }
   wk = w[k];
   
   /* Now set up the sub array */
   j = 0;
   for (i = 0; i < old_num_dims; i++)
     {
	if (i == (unsigned int) k)
	  continue;
	
	sub_dims[j] = old_dims[i];
	w[j] = w[i];
	tmp_dims[j] = 0;
	j++;
     }
   sub_num_dims = old_num_dims - 1;

   if (use_contraction)
     new_at = SLang_create_array1 (new_data_type, 0, NULL, sub_dims, sub_num_dims, 1);
   else
     new_at = SLang_create_array1 (new_data_type, 0, NULL, old_dims, old_num_dims, 1);

   if (new_at == NULL)
     {
	SLang_free_array (at);
	return -1;
     }

   new_data = (char *)new_at->data;
   old_data = (char *)at->data;
   old_sizeof_type = at->sizeof_type;
   new_sizeof_type = new_at->sizeof_type;
   dims_k = old_dims[k] * wk;

   do
     {
	unsigned int offset = 0;
	int status;

	for (i = 0; i < sub_num_dims; i++)
	  offset += w[i] * tmp_dims[i];
	
	if (use_contraction)
	  {
	     status = (*fcon) ((VOID_STAR)(old_data + offset*old_sizeof_type), wk,
			       dims_k, (VOID_STAR) new_data);
	     new_data += new_sizeof_type;
	  }
	else 
	  {
	     status = (*fmap) (old_data_type, (VOID_STAR) (old_data + offset*old_sizeof_type),
			       wk, dims_k,
			       new_data_type, (VOID_STAR) (new_data + offset*new_sizeof_type),
			       clientdata);
	  }
	
	if (status == -1)
	  {
	     SLang_free_array (new_at);
	     SLang_free_array (at);
	     return -1;
	  }
     }
   while (-1 != _SLarray_next_index (tmp_dims, sub_dims, sub_num_dims));

   SLang_free_array (at);
   return SLang_push_array (new_at, 1);
}

   
int SLarray_map_array (SLCONST SLarray_Map_Type *m)
{
   return map_or_contract_array (m, 0, 0, NULL, NULL);
}

int SLarray_map_array_1 (SLCONST SLarray_Map_Type *m, int *use_this_dim, 
			 VOID_STAR clientdata)
{
   return map_or_contract_array (m, 0, 1, use_this_dim, clientdata);
}

int SLarray_contract_array (SLCONST SLarray_Contract_Type *c)
{
   return map_or_contract_array ((SLarray_Map_Type *)c, 1, 0, NULL, NULL);
}

#if SLANG_HAS_COMPLEX
static int sum_complex (VOID_STAR zp, unsigned int inc, unsigned int num, VOID_STAR sp)
{
   double *z, *zmax;
   double sr, si;
   double *s;

   z = (double *)zp;
   zmax = z + 2*num;
   inc *= 2;
   sr = si = 0.0;
   while (z < zmax)
     {
	sr += z[0];
	si += z[1];
	z += inc;
     }
   s = (double *)sp;
   s[0] = sr;
   s[1] = si;
   return 0;
}

static int cumsum_complex (SLtype xtype, VOID_STAR xp, unsigned int inc, 
			   unsigned int num,
			   SLtype ytype, VOID_STAR yp, VOID_STAR clientdata)
{
   double *z, *zmax;
   double cr, ci;
   double *s;

   (void) xtype; (void) ytype; (void) clientdata;
   z = (double *)xp;
   zmax = z + 2*num;
   s = (double *)yp;
   inc *= 2;
   cr = ci = 0.0;
   while (z < zmax)
     {
	cr += z[0];
	ci += z[1];
	s[0] = cr;
	s[1] = ci;
	z += inc;
	s += inc;
     }
   return 0;
}
#endif
#if SLANG_HAS_FLOAT
static SLCONST SLarray_Contract_Type Sum_Functions [] =
{
     {SLANG_CHAR_TYPE, SLANG_CHAR_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_chars},
     {SLANG_UCHAR_TYPE, SLANG_UCHAR_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_uchars},
     {SLANG_SHORT_TYPE, SLANG_SHORT_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_shorts},
     {SLANG_USHORT_TYPE, SLANG_USHORT_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_ushorts},
     {SLANG_UINT_TYPE, SLANG_UINT_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_uints},
     {SLANG_INT_TYPE, SLANG_INT_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_ints},
     {SLANG_LONG_TYPE, SLANG_LONG_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_longs},
     {SLANG_ULONG_TYPE, SLANG_ULONG_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_ulongs},
     {SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Contract_Fun_Type *) sum_floats},
     {SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) sum_doubles},
#if SLANG_HAS_COMPLEX
     {SLANG_COMPLEX_TYPE, SLANG_COMPLEX_TYPE, SLANG_COMPLEX_TYPE, (SLarray_Contract_Fun_Type *) sum_complex},
#endif
     {0, 0, 0, NULL}
};

static void array_sum (void)
{
   (void) SLarray_contract_array (Sum_Functions);
}
#endif

static SLCONST SLarray_Contract_Type Array_Min_Funs [] = 
{
     {SLANG_CHAR_TYPE, SLANG_CHAR_TYPE, SLANG_CHAR_TYPE, (SLarray_Contract_Fun_Type *) min_chars},
     {SLANG_UCHAR_TYPE, SLANG_UCHAR_TYPE, SLANG_UCHAR_TYPE, (SLarray_Contract_Fun_Type *) min_uchars},
     {SLANG_SHORT_TYPE, SLANG_SHORT_TYPE, SLANG_SHORT_TYPE, (SLarray_Contract_Fun_Type *) min_shorts},
     {SLANG_USHORT_TYPE, SLANG_USHORT_TYPE, SLANG_USHORT_TYPE, (SLarray_Contract_Fun_Type *) min_ushorts},
     {SLANG_INT_TYPE, SLANG_INT_TYPE, SLANG_INT_TYPE, (SLarray_Contract_Fun_Type *) min_ints},
     {SLANG_UINT_TYPE, SLANG_UINT_TYPE, SLANG_UINT_TYPE, (SLarray_Contract_Fun_Type *) min_uints},
     {SLANG_LONG_TYPE, SLANG_LONG_TYPE, SLANG_LONG_TYPE, (SLarray_Contract_Fun_Type *) min_longs},
     {SLANG_ULONG_TYPE, SLANG_ULONG_TYPE, SLANG_ULONG_TYPE, (SLarray_Contract_Fun_Type *) min_ulongs},
#if SLANG_HAS_FLOAT
     {SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Contract_Fun_Type *) min_floats},
     {SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) min_doubles},
#endif
     {0, 0, 0, NULL}
};
   
static void 
array_min (void)
{
   (void) SLarray_contract_array (Array_Min_Funs);
}

static SLCONST SLarray_Contract_Type Array_Max_Funs [] =
{
     {SLANG_CHAR_TYPE, SLANG_CHAR_TYPE, SLANG_CHAR_TYPE, (SLarray_Contract_Fun_Type *) max_chars},
     {SLANG_UCHAR_TYPE, SLANG_UCHAR_TYPE, SLANG_UCHAR_TYPE, (SLarray_Contract_Fun_Type *) max_uchars},
     {SLANG_SHORT_TYPE, SLANG_SHORT_TYPE, SLANG_SHORT_TYPE, (SLarray_Contract_Fun_Type *) max_shorts},
     {SLANG_USHORT_TYPE, SLANG_USHORT_TYPE, SLANG_USHORT_TYPE, (SLarray_Contract_Fun_Type *) max_ushorts},
     {SLANG_INT_TYPE, SLANG_INT_TYPE, SLANG_INT_TYPE, (SLarray_Contract_Fun_Type *) max_ints},
     {SLANG_UINT_TYPE, SLANG_UINT_TYPE, SLANG_UINT_TYPE, (SLarray_Contract_Fun_Type *) max_uints},
     {SLANG_LONG_TYPE, SLANG_LONG_TYPE, SLANG_LONG_TYPE, (SLarray_Contract_Fun_Type *) max_longs},
     {SLANG_ULONG_TYPE, SLANG_ULONG_TYPE, SLANG_ULONG_TYPE, (SLarray_Contract_Fun_Type *) max_ulongs},
#if SLANG_HAS_FLOAT
     {SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Contract_Fun_Type *) max_floats},
     {SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Contract_Fun_Type *) max_doubles},
#endif
     {0, 0, 0, NULL}
};

static void 
array_max (void)
{
   (void) SLarray_contract_array (Array_Max_Funs);
}


static SLCONST SLarray_Map_Type CumSum_Functions [] =
{
     {SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Map_Fun_Type *) cumsum_doubles},
     {SLANG_INT_TYPE, SLANG_INT_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Map_Fun_Type *) cumsum_ints},
     {SLANG_LONG_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Map_Fun_Type *) cumsum_doubles},
     {SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Map_Fun_Type *) cumsum_floats},
     {SLANG_UINT_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Map_Fun_Type *) cumsum_doubles},
     {SLANG_ULONG_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Map_Fun_Type *) cumsum_doubles},
     {SLANG_CHAR_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Map_Fun_Type *) cumsum_floats},
     {SLANG_UCHAR_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Map_Fun_Type *) cumsum_floats},
     {SLANG_SHORT_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Map_Fun_Type *) cumsum_floats},
     {SLANG_USHORT_TYPE, SLANG_FLOAT_TYPE, SLANG_FLOAT_TYPE, (SLarray_Map_Fun_Type *) cumsum_floats},
     {SLANG_VOID_TYPE, SLANG_DOUBLE_TYPE, SLANG_DOUBLE_TYPE, (SLarray_Map_Fun_Type *) cumsum_doubles},
#if SLANG_HAS_COMPLEX
     {SLANG_COMPLEX_TYPE, SLANG_COMPLEX_TYPE, SLANG_COMPLEX_TYPE, (SLarray_Map_Fun_Type *) cumsum_complex},
#endif
     {0, 0, 0, NULL}
};

static void array_cumsum (void)
{
   (void) SLarray_map_array (CumSum_Functions);
}

static SLang_Intrin_Fun_Type Array_Fun_Table [] =
{
   MAKE_INTRINSIC_1("transpose", array_transpose, SLANG_VOID_TYPE, SLANG_ARRAY_TYPE),
   SLANG_END_INTRIN_FUN_TABLE
};

static SLang_Intrin_Fun_Type Array_Math_Fun_Table [] =
{
#if SLANG_HAS_FLOAT
   MAKE_INTRINSIC_0("sum", array_sum, SLANG_VOID_TYPE),
   MAKE_INTRINSIC_0("cumsum", array_cumsum, SLANG_VOID_TYPE),
#endif
   MAKE_INTRINSIC_0("min", array_min, SLANG_VOID_TYPE),
   MAKE_INTRINSIC_0("max", array_max, SLANG_VOID_TYPE),
   SLANG_END_INTRIN_FUN_TABLE
};

int SLang_init_array (void)
{
   if (-1 == SLadd_intrin_fun_table (Array_Fun_Table, "__SLARRAY__"))
     return -1;
#if SLANG_HAS_FLOAT
   _SLang_Matrix_Multiply = do_inner_product;
#endif
   return 0;
}

int SLang_init_array_extra (void)
{
   if (-1 == SLadd_intrin_fun_table (Array_Math_Fun_Table, "__SLARRAY__"))
     return -1;
   return 0;
}