Beispiel #1
0
static int
complex_typecast (SLtype from_type, VOID_STAR from, SLuindex_Type num,
		  SLtype to_type, VOID_STAR to)
{
   double *z;
   double *d;
   char *i;
   SLuindex_Type n;
   unsigned int sizeof_i;
   SLang_To_Double_Fun_Type to_double;

   (void) to_type;

   z = (double *) to;

   switch (from_type)
     {
      default:
	if (NULL == (to_double = SLarith_get_to_double_fun (from_type, &sizeof_i)))
	  return 0;
	i = (char *) from;
	for (n = 0; n < num; n++)
	  {
	     *z++ = to_double ((VOID_STAR) i);
	     *z++ = 0.0;

	     i += sizeof_i;
	  }
	break;

      case SLANG_DOUBLE_TYPE:
	d = (double *) from;
	for (n = 0; n < num; n++)
	  {
	     *z++ = d[n];
	     *z++ = 0.0;
	  }
	break;
     }

   return 1;
}
Beispiel #2
0
static int generic_complex_binary (int op,
				   SLtype a_type, VOID_STAR ap, SLuindex_Type na,
				   SLtype b_type, VOID_STAR bp, SLuindex_Type nb,
				   VOID_STAR cp)
{
   double *b, *c;
   char *a, *ic;
   SLuindex_Type n, n_max;
   SLuindex_Type da, db;
   unsigned int sizeof_a;
   SLang_To_Double_Fun_Type to_double;

   if (NULL == (to_double = SLarith_get_to_double_fun (a_type, &sizeof_a)))
     return 0;

   (void) b_type;

   a = (char *) ap;
   b = (double *) bp;
   c = (double *) cp;
   ic = (char *) cp;

   if (na == 1) da = 0; else da = sizeof_a;
   if (nb == 1) db = 0; else db = 2;

   if (na > nb) n_max = na; else n_max = nb;
   n_max = 2 * n_max;

   switch (op)
     {
      default:
	return 0;
      case SLANG_POW:
	for (n = 0; n < n_max; n += 2)
	  {
	     dcomplex_pow (c + n, to_double((VOID_STAR)a), b);
	     a += da; b += db;
	  }
	break;

      case SLANG_PLUS:
	for (n = 0; n < n_max; n += 2)
	  {
	     c[n] = to_double((VOID_STAR)a) + b[0];
	     c[n + 1] = b[1];
	     a += da; b += db;
	  }
	break;

      case SLANG_MINUS:
	for (n = 0; n < n_max; n += 2)
	  {
	     c[n] = to_double((VOID_STAR)a) - b[0];
	     c[n + 1] = -b[1];
	     a += da; b += db;
	  }
	break;

      case SLANG_TIMES:
	for (n = 0; n < n_max; n += 2)
	  {
	     double a0 = to_double((VOID_STAR)a);
	     c[n] = a0 * b[0];
	     c[n + 1] = a0 * b[1];
	     a += da; b += db;
	  }
	break;

      case SLANG_DIVIDE:	       /* / */
	for (n = 0; n < n_max; n += 2)
	  {
	     double z[2];
#if 0
	     if ((b[0] == 0.0) && (b[1] == 0.0))
	       {
		  SLang_set_error (SL_DIVIDE_ERROR);
		  return -1;
	       }
#endif
	     z[0] = to_double((VOID_STAR)a);
	     z[1] = 0.0;
	     SLcomplex_divide (c + n, z, b);
	     a += da; b += db;
	  }
	break;

      case SLANG_EQ: 		       /* == */
	for (n = 0; n < n_max; n += 2)
	  {
	     ic[n/2] = ((to_double((VOID_STAR)a) == b[0]) && (0.0 == b[1]));
	     a += da; b += db;
	  }
	break;

      case SLANG_NE:		       /* != */
	for (n = 0; n < n_max; n += 2)
	  {
	     ic[n/2] = ((to_double((VOID_STAR)a) != b[0]) || (0.0 != b[1]));
	     a += da; b += db;
	  }
	break;
     }

   return 1;
}
Beispiel #3
0
static int complex_generic_binary (int op,
				   SLtype a_type, VOID_STAR ap, SLuindex_Type na,
				   SLtype b_type, VOID_STAR bp, SLuindex_Type nb,
				   VOID_STAR cp)
{
   char *ic;
   char *b;
   double *a, *c;
   SLuindex_Type n, n_max;
   SLuindex_Type da, db;
   unsigned int sizeof_b;
   SLang_To_Double_Fun_Type to_double;

   if (NULL == (to_double = SLarith_get_to_double_fun (b_type, &sizeof_b)))
     return 0;

   (void) a_type;

   a = (double *) ap;
   b = (char *) bp;
   c = (double *) cp;
   ic = (char *) cp;

   if (na == 1) da = 0; else da = 2;
   if (nb == 1) db = 0; else db = sizeof_b;

   if (na > nb) n_max = na; else n_max = nb;
   n_max = 2 * n_max;

   switch (op)
     {
      default:
	return 0;

      case SLANG_POW:
	for (n = 0; n < n_max; n += 2)
	  {
	     complex_dpow (c + n, a, to_double((VOID_STAR)b));
	     a += da; b += db;
	  }
	break;

      case SLANG_PLUS:
	for (n = 0; n < n_max; n += 2)
	  {
	     c[n] = a[0] + to_double((VOID_STAR)b);
	     c[n + 1] = a[1];
	     a += da; b += db;
	  }
	break;

      case SLANG_MINUS:
	for (n = 0; n < n_max; n += 2)
	  {
	     c[n] = a[0] - to_double((VOID_STAR)b);
	     c[n + 1] = a[1];
	     a += da; b += db;
	  }
	break;

      case SLANG_TIMES:
	for (n = 0; n < n_max; n += 2)
	  {
	     double b0 = to_double((VOID_STAR)b);
	     c[n] = a[0] * b0;
	     c[n + 1] = a[1] * b0;
	     a += da; b += db;
	  }
	break;

      case SLANG_DIVIDE:	       /* / */
	for (n = 0; n < n_max; n += 2)
	  {
	     double b0 = to_double((VOID_STAR)b);
#if 0
	     if (b0 == 0)
	       {
		  SLang_set_error (SL_DIVIDE_ERROR);
		  return -1;
	       }
#endif
	     c[n] = a[0] / b0;
	     c[n + 1] = a[1] / b0;
	     a += da; b += db;
	  }
	break;

      case SLANG_EQ: 		       /* == */
	for (n = 0; n < n_max; n += 2)
	  {
	     ic[n/2] = ((a[0] == to_double((VOID_STAR)b)) && (a[1] == 0.0));
	     a += da; b += db;
	  }
	break;

      case SLANG_NE:		       /* != */
	for (n = 0; n < n_max; n += 2)
	  {
	     ic[n/2] = ((a[0] != to_double((VOID_STAR)b)) || (a[1] != 0.0));
	     a += da; b += db;
	  }
	break;
     }

   return 1;
}
Beispiel #4
0
static int generic_math_op (int op,
			    SLtype type, VOID_STAR ap, unsigned int na,
			    VOID_STAR bp)
{
   double *b;
   unsigned int i;
   SLang_To_Double_Fun_Type to_double;
   unsigned int da;
   char *a, *c;

   if (NULL == (to_double = SLarith_get_to_double_fun (type, &da)))
     return 0;

   b = (double *) bp;
   a = (char *) ap;

   switch (op)
     {
      default:
	return 0;

      case SLMATH_SINH:
	for (i = 0; i < na; i++) 
	  {
	     b[i] = sinh (to_double ((VOID_STAR) a));
	     a += da;
	  }
	break;
      case SLMATH_COSH:
	for (i = 0; i < na; i++) 
	  {
	     b[i] = cosh (to_double ((VOID_STAR) a));
	     a += da;
	  }
	break;
      case SLMATH_TANH:
	for (i = 0; i < na; i++) 
	  {
	     b[i] = tanh (to_double ((VOID_STAR) a));
	     a += da;
	  }
	break;
      case SLMATH_TAN:
	for (i = 0; i < na; i++) 
	  {
	     b[i] = tan (to_double ((VOID_STAR) a));
	     a += da;
	  }
	break;
      case SLMATH_ASIN:
	for (i = 0; i < na; i++) 
	  {
	     b[i] = asin (to_double ((VOID_STAR) a));
	     a += da;
	  }
	break;
      case SLMATH_ACOS:
	for (i = 0; i < na; i++) 
	  {
	     b[i] = acos (to_double ((VOID_STAR) a));
	     a += da;
	  }
	break;
      case SLMATH_ATAN:
	for (i = 0; i < na; i++) 
	  {
	     b[i] = atan (to_double ((VOID_STAR) a));
	     a += da;
	  }
	break;
      case SLMATH_EXP:
	for (i = 0; i < na; i++) 
	  {
	     b[i] = exp (to_double ((VOID_STAR) a));
	     a += da;
	  }
	break;
      case SLMATH_LOG:
	for (i = 0; i < na; i++) 
	  {
	     b[i] = log (to_double ((VOID_STAR) a));
	     a += da;
	  }
	break;
      case SLMATH_LOG10:
	for (i = 0; i < na; i++) 
	  {
	     b[i] = log10 (to_double ((VOID_STAR) a));
	     a += da;
	  }
	break;
      case SLMATH_SQRT:
	for (i = 0; i < na; i++) 
	  {
	     b[i] = sqrt (to_double ((VOID_STAR) a));
	     a += da;
	  }
	break;
      case SLMATH_SIN:
	for (i = 0; i < na; i++) 
	  {
	     b[i] = sin (to_double ((VOID_STAR) a));
	     a += da;
	  }
	break;
      case SLMATH_COS:
	for (i = 0; i < na; i++) 
	  {
	     b[i] = cos (to_double ((VOID_STAR) a));
	     a += da;
	  }
	break;

      case SLMATH_ASINH:
	for (i = 0; i < na; i++) 
	  {
	     b[i] = ASINH_FUN (to_double ((VOID_STAR) a));
	     a += da;
	  }
	break;
      case SLMATH_ATANH:
	for (i = 0; i < na; i++) 
	  {
	     b[i] = ATANH_FUN (to_double ((VOID_STAR) a));
	     a += da;
	  }
	break;
      case SLMATH_ACOSH:
	for (i = 0; i < na; i++) 
	  {
	     b[i] = ACOSH_FUN (to_double ((VOID_STAR) a));
	     a += da;
	  }
	break;


      case SLMATH_CONJ:
      case SLMATH_REAL:
	for (i = 0; i < na; i++)
	  {
	     b[i] = to_double((VOID_STAR) a);
	     a += da;
	  }
	return 1;

      case SLMATH_IMAG:
	for (i = 0; i < na; i++)
	  b[i] = 0.0;
	return 1;

      case SLMATH_ISINF:
	c = (char *) bp;
	for (i = 0; i < na; i++)
	  {
	     c[i] = (char) ISINF_FUN(to_double((VOID_STAR) a));
	     a += da;
	  }
	return 1;
      case SLMATH_ISNAN:
	c = (char *) bp;
	for (i = 0; i < na; i++)
	  {
	     c[i] = (char) ISNAN_FUN(to_double((VOID_STAR) a));
	     a += da;
	  }
	return 1;
      case SLMATH_FLOOR:
	for (i = 0; i < na; i++) 
	  {
	     b[i] = floor (to_double ((VOID_STAR) a));
	     a += da;
	  }
	break;
      case SLMATH_CEIL:
	for (i = 0; i < na; i++) 
	  {
	     b[i] = ceil (to_double ((VOID_STAR) a));
	     a += da;
	  }
	break;
      case SLMATH_ROUND:
	for (i = 0; i < na; i++) 
	  {
	     b[i] = ROUND_FUN (to_double ((VOID_STAR) a));
	     a += da;
	  }
	break;
     }
   
   return 1;
}
Beispiel #5
0
static int generic_math_op (int op,
			    unsigned char type, VOID_STAR ap, unsigned int na,
			    VOID_STAR bp)
{
   double *b;
   unsigned int i;
   SLang_To_Double_Fun_Type to_double;
   double (*fun) (double);
   unsigned int da;
   char *a;

   if (NULL == (to_double = SLarith_get_to_double_fun (type, &da)))
     return 0;

   b = (double *) bp;
   a = (char *) ap;

   switch (op)
     {
      default:
	return 0;

      case SLMATH_SINH:
	fun = sinh;
	break;
      case SLMATH_COSH:
	fun = cosh;
	break;
      case SLMATH_TANH:
	fun = tanh;
	break;
      case SLMATH_TAN:
	fun = tan;
	break;
      case SLMATH_ASIN:
	fun = asin;
	break;
      case SLMATH_ACOS:
	fun = acos;
	break;
      case SLMATH_ATAN:
	fun = atan;
	break;
      case SLMATH_EXP:
	fun = exp;
	break;
      case SLMATH_LOG:
	fun = log;
	break;
      case SLMATH_LOG10:
	fun = log10;
	break;
      case SLMATH_SQRT:
	fun = sqrt;
	break;
      case SLMATH_SIN:
	fun = sin;
	break;
      case SLMATH_COS:
	fun = cos;
	break;

      case SLMATH_ASINH:
	fun = ASINH_FUN;
	break;
      case SLMATH_ATANH:
	fun = ATANH_FUN;
	break;
      case SLMATH_ACOSH:
	fun = ACOSH_FUN;
	break;


      case SLMATH_CONJ:
      case SLMATH_REAL:
	for (i = 0; i < na; i++)
	  {
	     b[i] = to_double((VOID_STAR) a);
	     a += da;
	  }
	return 1;

      case SLMATH_IMAG:
	for (i = 0; i < na; i++)
	  b[i] = 0.0;
	return 1;
     }

   for (i = 0; i < na; i++)
     {
	b[i] = (*fun) (to_double ((VOID_STAR) a));
	a += da;
     }
   
   return 1;
}