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