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