//## Complex Complex.catan();
static KMETHOD Complex_catan(KonohaContext *kctx, KonohaStack *sfp)
{
kComplex *kc = (kComplex *) sfp[0].asObject;
double _Complex z = kc->z;
double ret = catan(z);
KReturnFloatValue(ret);
}
void
ovm_dd_atan2(oregister_t *l, oregister_t *r)
{
switch (r->t) {
case t_void:
goto flt;
case t_word:
if (r->v.w) {
real(r->v.dd) = r->v.w;
imag(r->v.dd) = 0.0;
goto cdd;
}
flt:
l->t = t_float;
l->v.d = real(l->v.dd) >= 0.0 ? M_PI_2 : -M_PI_2;
break;
case t_float:
if (r->v.d) {
real(r->v.dd) = r->v.d;
imag(r->v.dd) = 0.0;
goto cdd;
}
goto flt;
case t_mpz:
real(r->v.dd) = mpz_get_d(ozr(r));
imag(r->v.dd) = 0.0;
goto cdd;
case t_rat:
real(r->v.dd) = rat_get_d(r->v.r);
imag(r->v.dd) = 0.0;
goto cdd;
case t_mpq:
real(r->v.dd) = mpq_get_d(oqr(r));
imag(r->v.dd) = 0.0;
goto cdd;
case t_mpr:
mpc_set_fr(occ(r), orr(r), thr_rndc);
goto mpc;
case t_cdd:
cdd:
l->v.dd = catan(l->v.dd / r->v.dd);
check_cdd(l);
break;
case t_cqq:
real(r->v.dd) = mpq_get_d(oqr(r));
imag(r->v.dd) = mpq_get_d(oqi(r));
goto cdd;
case t_mpc:
mpc:
l->t = t_mpc;
mpc_set_d_d(occ(l), real(l->v.dd), imag(l->v.dd), thr_rndc);
mpc_div(occ(l), occ(l), occ(r), thr_rndc);
mpc_atan(occ(l), occ(l), thr_rndc);
check_mpc(l);
break;
default:
ovm_raise(except_not_a_number);
}
}
double complex
catanh(double complex z)
{
double complex w;
w = -1.0 * I * catan (z * I);
return (w);
}
static double complex z_atan(double complex z)
{
if(creal(z) == 0 && fabs(cimag(z)) > 1) {
double y = cimag(z), rr, ri;
rr = (y > 0) ? M_PI_2 : -M_PI_2;
ri = 0.25 * log(((y + 1) * (y + 1))/((y - 1) * (y - 1)));
return rr + ri*I;
}
return catan(z);
}
//## Complex Complex.catanl();
static KMETHOD Complex_catanl(KonohaContext *kctx, KonohaStack *sfp)
{
kComplex *kc = (kComplex *) sfp[0].asObject;
long double _Complex zl = (long double _Complex)kc->z;
#if !defined(__CYGWIN__)
long double ret = catanl(zl);
#else
long double ret = catan(zl);
#endif
KReturnFloatValue(ret);
}
void
cmplx (double _Complex z)
{
cabs (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 129 } */
cacos (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 131 } */
cacosh (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 133 } */
carg (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 135 } */
casin (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 137 } */
casinh (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 139 } */
catan (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 141 } */
catanh (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 143 } */
ccos (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 145 } */
ccosh (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 147 } */
cexp (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 149 } */
cimag (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 151 } */
clog (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 153 } */
conj (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 155 } */
cpow (z, z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 157 } */
cproj (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 159 } */
creal (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 161 } */
csin (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 163 } */
csinh (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 165 } */
csqrt (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 167 } */
ctan (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 169 } */
ctanh (z); /* { dg-warning "incompatible implicit" } */
/* { dg-message "include ..complex.h.." "" { target *-*-* } 171 } */
}
static void z_atan2(Rcomplex *r, Rcomplex *csn, Rcomplex *ccs)
{
double complex dr, dcsn = toC99(csn), dccs = toC99(ccs);
if (dccs == 0) {
if(dcsn == 0) {
r->r = NA_REAL; r->i = NA_REAL; /* Why not R_NaN? */
return;
} else {
double y = creal(dcsn);
if (ISNAN(y)) dr = y;
else dr = ((y >= 0) ? M_PI_2 : -M_PI_2);
}
} else {
dr = catan(dcsn / dccs);
if(creal(dccs) < 0) dr += M_PI;
if(creal(dr) > M_PI) dr -= 2 * M_PI;
}
SET_C99_COMPLEX(r, 0, dr);
}
void
docomplex (void)
{
#ifndef NO_DOUBLE
complex double ca, cb, cc;
double f1;
ca = 1.0 + 1.0 * I;
cb = 1.0 - 1.0 * I;
f1 = cabs (ca);
fprintf (stdout, "cabs : %f\n", f1);
cc = cacos (ca);
fprintf (stdout, "cacos : %f %fi\n", creal (cc),
cimag (cc));
cc = cacosh (ca);
fprintf (stdout, "cacosh : %f %fi\n", creal (cc),
cimag (cc));
f1 = carg (ca);
fprintf (stdout, "carg : %f\n", f1);
cc = casin (ca);
fprintf (stdout, "casin : %f %fi\n", creal (cc),
cimag (cc));
cc = casinh (ca);
fprintf (stdout, "casinh : %f %fi\n", creal (cc),
cimag (cc));
cc = catan (ca);
fprintf (stdout, "catan : %f %fi\n", creal (cc),
cimag (cc));
cc = catanh (ca);
fprintf (stdout, "catanh : %f %fi\n", creal (cc),
cimag (cc));
cc = ccos (ca);
fprintf (stdout, "ccos : %f %fi\n", creal (cc),
cimag (cc));
cc = ccosh (ca);
fprintf (stdout, "ccosh : %f %fi\n", creal (cc),
cimag (cc));
cc = cexp (ca);
fprintf (stdout, "cexp : %f %fi\n", creal (cc),
cimag (cc));
f1 = cimag (ca);
fprintf (stdout, "cimag : %f\n", f1);
cc = clog (ca);
fprintf (stdout, "clog : %f %fi\n", creal (cc),
cimag (cc));
cc = conj (ca);
fprintf (stdout, "conj : %f %fi\n", creal (cc),
cimag (cc));
cc = cpow (ca, cb);
fprintf (stdout, "cpow : %f %fi\n", creal (cc),
cimag (cc));
cc = cproj (ca);
fprintf (stdout, "cproj : %f %fi\n", creal (cc),
cimag (cc));
f1 = creal (ca);
fprintf (stdout, "creal : %f\n", f1);
cc = csin (ca);
fprintf (stdout, "csin : %f %fi\n", creal (cc),
cimag (cc));
cc = csinh (ca);
fprintf (stdout, "csinh : %f %fi\n", creal (cc),
cimag (cc));
cc = csqrt (ca);
fprintf (stdout, "csqrt : %f %fi\n", creal (cc),
cimag (cc));
cc = ctan (ca);
fprintf (stdout, "ctan : %f %fi\n", creal (cc),
cimag (cc));
cc = ctanh (ca);
fprintf (stdout, "ctanh : %f %fi\n", creal (cc),
cimag (cc));
#endif
}
// The type imaginary is not supported.
TEST_GROUP(Complex)
float complex f = I;
double complex d = I;
long double complex ld = I;
TEST_RESOLVED(MIPS, "http://ellcc.org/bugzilla/show_bug.cgi?id=59") {
TEST_TRACE(C99 7.3.5.1)
d = cacos(d);
f = cacosf(f);
ld = cacosl(ld);
TEST_TRACE(C99 7.3.5.2)
d = casin(d);
f = casinf(f);
ld = casinl(ld);
TEST_TRACE(C99 7.3.5.3)
d = catan(d);
f = catanf(f);
ld = catanl(ld);
TEST_TRACE(C99 7.3.5.4)
d = ccos(d);
f = ccosf(f);
ld = ccosl(ld);
TEST_TRACE(C99 7.3.5.5)
d = csin(d);
f = csinf(f);
ld = csinl(ld);
TEST_TRACE(C99 7.3.5.6)
d = ctan(d);
f = ctanf(f);
ld = ctanl(ld);
TEST_TRACE(C99 7.3.6.1)
CAMLprim value math_catan(value x) {
CAMLparam1(x);
CAMLreturn(caml_copy_complex(catan(Complex_val(x))));
}
void test06 ( )
/******************************************************************************/
/*
Purpose:
TEST06: intrinsic functions for double complex variables.
Licensing:
This code is distributed under the GNU LGPL license.
Modified:
07 November 2010
Author:
John Burkardt
*/
{
double complex a = {1.0 + 2.0 * I};
printf ( "\n" );
printf ( "TEST06\n" );
printf ( " Apply intrinsic functions to DOUBLE COMPLEX variables\n" );
/*
Print them.
*/
printf ( "\n" );
/*
Note that "I" by itself is NOT a complex number, nor is it the
imaginary unit. You have to cast it to ( complex ) or ( double complex )
or multiply it by a float or double before it results in a numerical
result.
*/
printf ( " ( double complex ) I = (%14.6g,%14.6g)\n", ( double complex ) I );
printf ( " a = (%14.6g,%14.6g)\n", a );
printf ( " - a = (%14.6g,%14.6g)\n", - a );
printf ( " a + 3 = (%14.6g,%14.6g)\n", a + 3 );
printf ( " a + (0,5) = (%14.6g,%14.6g)\n", a + ( 0, 5 ) );
printf ( " 4 * a = (%14.6g,%14.6g)\n", 4 * a );
printf ( " a / 8 = (%14.6g,%14.6g)\n", a / 8 );
printf ( " a * a = (%14.6g,%14.6g)\n", a * a );
printf ( " cpow ( a, 2 ) = (%14.6g,%14.6g)\n", cpow ( a, 2 ) );
printf ( " cpow ( 2, a ) = (%14.6g,%14.6g)\n", cpow ( 2, a ) );
printf ( " cpow ( a, a ) = (%14.6g,%14.6g)\n", cpow ( a, a ) );
printf ( " 1/a = (%14.6g,%14.6g)\n", 1.0 / a );
printf ( "\n" );
printf ( " cabs(a) = %14.6g\n", cabs ( a ) );
printf ( " cacos(a) = (%14.6g,%14.6g)\n", cacos ( a ) );
printf ( " cacosh(a) = (%14.6g,%14.6g)\n", cacosh ( a ) );
printf ( " carg(a) = %14.6g\n", carg ( a ) );
printf ( " casin(a) = (%14.6g,%14.6g)\n", casin ( a ) );
printf ( " casinh(a) = (%14.6g,%14.6g)\n", casinh ( a ) );
printf ( " catan(a) = (%14.6g,%14.6g)\n",
creal ( catan ( a ) ), cimag ( catan ( a ) ) );
printf ( " catanh(a) = (%14.6g,%14.6g)\n",
creal ( catanh ( a ) ), cimag ( catanh ( a ) ) );
printf ( " ccos(a) = (%14.6g,%14.6g)\n",
creal ( ccos ( a ) ), cimag ( ccos ( a ) ) );
printf ( " ccosh(a) = (%14.6g,%14.6g)\n",
creal ( ccosh ( a ) ), cimag ( ccosh ( a ) ) );
printf ( " cexp(a) = (%14.6g,%14.6g)\n",
creal ( cexp ( a ) ), cimag ( cexp ( a ) ) );
printf ( " cimag(a) = %14.6g\n", cimag ( a ) );
printf ( " clog(a) = (%14.6g,%14.6g)\n",
creal ( clog ( a ) ), cimag ( clog ( a ) ) );
printf ( " (double complex)(1) = (%14.6g,%14.6g)\n",
creal ( ( double complex ) ( 1 ) ), cimag ( ( double complex ) ( 1 ) ) );
printf ( " (double complex)(4.0) = (%14.6g,%14.6g)\n",
creal ( ( double complex ) ( 4.0 ) ), cimag ( ( double complex ) ( 4.0 ) ) );
printf ( " conj(a) = (%14.6g,%14.6g)\n",
creal ( conj ( a ) ), cimag ( conj ( a ) ) );
printf ( " cproj(a) = (%14.6g,%14.6g)\n",
creal ( cproj ( a ) ), cimag ( cproj ( a ) ) );
printf ( " creal(a) = %14.6g\n", creal ( a ) );
printf ( " csin(a) = (%14.6g,%14.6g)\n",
creal ( csin ( a ) ), cimag ( csin ( a ) ) );
printf ( " csinh(a) = (%14.6g,%14.6g)\n",
creal ( csinh ( a ) ), cimag ( csinh ( a ) ) );
printf ( " csqrt(a) = (%14.6g,%14.6g)\n",
creal ( csqrt ( a ) ), cimag ( csqrt ( a ) ) );
printf ( " ctan(a) = (%14.6g,%14.6g)\n",
creal ( ctan ( a ) ), cimag ( ctan ( a ) ) );
printf ( " ctanh(a) = (%14.6g,%14.6g)\n",
creal ( ctanh ( a ) ), cimag ( ctanh ( a ) ) );
printf ( " (int)(a) = %10d\n", ( int ) ( a ) );
return;
}
static status_t
uforth_execute_step(uforth_context_t *uf_ctx,
simulation_context_t *sc,
simulation_t *simulation,
uforth_heap_t *heap,
yana_complex_t *resultp,
int i)
{
uforth_token_t *l_stack[16];
int l_stack_pos = 0;
status_t status = SUCCESS;
uforth_token_t *token;
yana_real_t r1, r2, r3;
yana_complex_t c1, c2;
yana_real_t f = sc?simulation_context_get_f(sc, i):0.L;
int s = sc?simulation_context_get_n_samples(sc):0;
uforth_token_type_t head_type;
bool printed = false;
bool end = false;
bool free_heap = false;
if ( NULL == heap )
{
free_heap = true;
heap = uforth_heap_new();
}
for ( token = uf_ctx->first ;
token && !end;
token = token->next )
{
switch (token->type)
{
case UF_FREEAIR:
POP_REAL("( x X -- x ) FREEAIR", r2);
POP_REAL("( X x -- x ) FREEAIR", r1);
PUSH_COMPLEX("FREEAIR", free_air_impedance(f, r1, r2));
break;
case UF_DIRIMP:
POP_REAL("( x x X -- x ) FREEAIR", r3); // theta
POP_REAL("( x X x -- x ) FREEAIR", r2); // r
POP_REAL("( X x x -- x ) FREEAIR", r1); // Sd
PUSH_COMPLEX("FREEAIR", free_air_dir_impedance(f, r2, r1, r3));
break;
case UF_MUL:
POP_COMPLEX("( x X -- x ) MUL", c2);
POP_COMPLEX("( X x -- x ) MUL", c1);
PUSH_COMPLEX("MUL", c1*c2);
break;
case UF_DIV:
POP_COMPLEX("( x X -- x ) DIV", c2);
POP_COMPLEX("( X x -- x ) DIV", c1);
PUSH_COMPLEX("DIV", c1/c2);
break;
case UF_ADD:
POP_COMPLEX("( x X -- x ) ADD", c2);
POP_COMPLEX("( X x -- x ) ADD", c1);
PUSH_COMPLEX("ADD", c1+c2);
break;
case UF_SUB:
POP_COMPLEX("( x X -- x ) SUB", c2);
POP_COMPLEX("( X x -- x ) SUB", c1);
PUSH_COMPLEX("SUB", c1-c2);
break;
case UF_NEG:
POP_COMPLEX("( X -- x ) NEG", c1);
PUSH_COMPLEX("NEG", -c1);
break;
case UF_EXP:
POP_COMPLEX("( X -- x ) EXP", c1);
PUSH_COMPLEX("EXP", cexp(c1));
break;
case UF_POW:
POP_COMPLEX("( x X -- x ) POW", c2);
POP_COMPLEX("( X x -- x ) POW", c1);
PUSH_COMPLEX("POW", cpow(c1, c2));
break;
case UF_SQRT:
POP_COMPLEX("( X -- x ) SQRT", c1);
PUSH_COMPLEX("SQRT", csqrt(c1));
break;
case UF_LN:
POP_COMPLEX("( X -- x ) LN", c1);
PUSH_COMPLEX("LN", clog(c1));
break;
case UF_COS:
POP_COMPLEX("( X -- x ) COS", c1);
PUSH_COMPLEX("COS", ccos(c1));
break;
case UF_SIN:
POP_COMPLEX("( X -- x ) SIN", c1);
PUSH_COMPLEX("SIN", csin(c1));
break;
case UF_TAN:
POP_COMPLEX("( X -- x ) TAN", c1);
PUSH_COMPLEX("TAN", ctan(c1));
break;
case UF_ACOS:
POP_COMPLEX("( X -- x ) ACOS", c1);
PUSH_COMPLEX("ACOS", cacos(c1));
break;
case UF_ASIN:
POP_COMPLEX("( X -- x ) ASIN", c1);
PUSH_COMPLEX("ASIN", casin(c1));
break;
case UF_ATAN:
POP_COMPLEX("( X -- x ) ATAN", c1);
PUSH_COMPLEX("ATAN", catan(c1));
break;
case UF_LOG:
POP_COMPLEX("( X -- x ) LOG", c1);
PUSH_COMPLEX("LOG", clog10(c1));
break;
case UF_PAR:
POP_COMPLEX("( x X -- x ) PAR", c2);
POP_COMPLEX("( X x -- x ) PAR", c1);
PUSH_COMPLEX("PAR", (c1*c2)/(c1+c2) );
break;
case UF_ABS:
POP_COMPLEX("( X -- x ) ABS", c1);
PUSH_REAL("ABS", cabs(c1));
break;
case UF_ARG:
POP_COMPLEX("( X -- x ) ARG", c1);
PUSH_REAL("ARG", carg(c1));
break;
case UF_DEG:
POP_REAL("( X -- x ) DEG", r1);
PUSH_REAL("DEG", 180. * r1 / M_PI );
break;
case UF_ANGLE:
POP_REAL("( x X -- x ) ANGLE", r2);
POP_REAL("( X x -- x ) ANGLE", r1);
if ( fabs(r1-r2-2.*M_PI) > fabs(r1-r2) )
{
if ( fabs(r1-r2+2.*M_PI) > fabs(r1-r2) )
PUSH_REAL("ANGLE", r1-r2);
else
PUSH_REAL("ANGLE", r1-r2+2.*M_PI);
}
else
{
if ( fabs(r1-r2+2.*M_PI) > fabs(r1-r2-2.*M_PI) )
PUSH_REAL("ANGLE", r1-r2-2.*M_PI);
else
PUSH_REAL("ANGLE", r1-r2+2.*M_PI);
}
break;
case UF_PDELAY:
POP_REAL("( X -- x ) PDELAY", r1);
PUSH_REAL("PDELAY", - r1 /( 2. * M_PI * f ) );
break;
case UF_PREV_STEP:
if ( 0 == i )
{
end = true;
break;
}
--i;
f = simulation_context_get_f(sc, i);
break;
case UF_NEXT_STEP:
if ( s-1 == i )
{
end = true;
break;
}
++i;
f = simulation_context_get_f(sc, i);
break;
case UF_IMAG:
POP_COMPLEX("( X -- x ) IMAG", c1);
PUSH_REAL("IMAG", cimag(c1));
break;
case UF_REAL:
POP_COMPLEX("( X -- x ) REAL", c1);
PUSH_REAL("REAL", creal(c1));
break;
case UF_PI:
PUSH_REAL("PI", M_PI);
break;
case UF_RHO:
PUSH_REAL("PI", YANA_RHO);
break;
case UF_C:
PUSH_REAL("PI", YANA_C);
break;
case UF_MU:
PUSH_REAL("PI", YANA_MU);
break;
case UF_F:
PUSH_REAL("F", f);
break;
case UF_S:
PUSH_REAL("F", i);
break;
case UF_I:
PUSH_COMPLEX("I", 0. + I * 1.);
break;
case UF_DB:
POP_COMPLEX("( X -- x ) DB", c1);
PUSH_REAL("DB", 20. * log10(cabs(c1)));
break;
case UF_DBSPL:
POP_COMPLEX("( X -- x ) DB", c1);
PUSH_REAL("DB", 20. * log10(cabs(c1)/20e-6));
break;
case UF_DOT:
HEAD_TYPE(head_type);
if ( UF_VALUE_REAL == head_type )
{
POP_REAL("( X -- ) DOT", r1);
fprintf(stdout, "%1.12g\t", (double)r1);
}
else if ( UF_VALUE_COMPLEX == head_type )
{
POP_COMPLEX("( X -- ) DOT", c1);
fprintf(stdout, "%1.12g\t", (double)cabs(c1));
}
printed=true;
break;
case UF_DUP:
POP_COMPLEX("( X -- x x ) DUP", c1);
PUSH_COMPLEX("DUP", c1);
PUSH_COMPLEX("DUP", c1);
break;
case UF_TO:
token=token->next;
if ( NULL == token )
{
ERROR("TO: end of instructions stream");
status = FAILURE;
goto loop_exit;
}
if ( token->type != UF_VALUE_SIMULATION )
{
ERROR("TO: %s is not a valid word to be set", token->symbol);
status = FAILURE;
goto loop_exit;
}
POP_COMPLEX("(X -- ) TO", c1);
uforth_heap_set(heap, token->symbol, c1);
break;
case UF_SWAP:
if ( uf_ctx->stack_pos < 2 )
{
ERROR("SWAP: Stack underflow");
status = FAILURE;
goto loop_exit;
}
token_swap(&uf_ctx->stack[uf_ctx->stack_pos-1],
&uf_ctx->stack[uf_ctx->stack_pos-2]);
break;
case UF_DROP:
POP_COMPLEX("(X -- ) DROP", c1);
break;
case UF_IF:
POP_COMPLEX("(X -- ) IF", c1);
if ( 0. == c1 )
{
int depth=-1;
uforth_token_t *orig_position = token;
while ( ( token->type != UF_ELSE && token->type != UF_THEN ) || depth != 0 )
{
if ( token->type == UF_IF ) ++depth;
if ( token->type == UF_THEN ) --depth;
token = token->next;
if ( NULL == token )
{
ERROR("IF: no matching ELSE or THEN found");
token = orig_position;
status = FAILURE;
goto loop_exit;
}
}
}
break;
case UF_ELSE:
{
int depth=0;
uforth_token_t *orig_position = token;
while ( token->type != UF_THEN || depth != 0 )
{
if ( token->type == UF_IF ) ++depth;
if ( token->type == UF_THEN ) --depth;
token = token->next;
if ( NULL == token )
{
ERROR("ELSE: no matching THEN found");
token = orig_position;
status = FAILURE;
goto loop_exit;
}
}
}
break;
case UF_THEN:
//noop
break;
case UF_BEGIN:
L_PUSH(token);
break;
case UF_WHILE:
POP_COMPLEX("(X -- ) WHILE", c1);
if ( 0. == c1 )
{
L_DROP();
int depth=0;
uforth_token_t *orig_position = token;
while ( token->type != UF_REPEAT || 0 != depth)
{
if ( token->type == UF_BEGIN ) ++depth;
if ( token->type == UF_UNTIL ) --depth;
if ( token->type == UF_REPEAT ) --depth;
if ( token->type == UF_AGAIN ) --depth;
token=token->next;
if ( NULL == token )
{
ERROR("WHILE: no matching REPEAT found");
token = orig_position;
status = FAILURE;
goto loop_exit;
}
}
}
break;
case UF_REPEAT:
L_HEAD(token);
break;
case UF_UNTIL:
POP_COMPLEX("(X -- ) UNTIL", c1);
if ( 0. == c1 )
L_HEAD(token);
else
L_DROP();
break;
case UF_AGAIN:
L_HEAD(token);
break;
case UF_LEAVE:
{
int depth = 0;
L_DROP();
uforth_token_t *orig_position = token;
while ( ! ( ( token->type == UF_UNTIL ||
token->type == UF_REPEAT ||
token->type == UF_AGAIN ) && depth == 0 ) )
{
if ( token->type == UF_BEGIN ) ++depth;
if ( token->type == UF_UNTIL ) --depth;
if ( token->type == UF_REPEAT ) --depth;
if ( token->type == UF_AGAIN ) --depth;
token = token->next;
if ( NULL == token )
{
ERROR("LEAVE: no matching UNTIL|REPEAT|AGAIN found");
token = orig_position;
status = FAILURE;
goto loop_exit;
}
}
}
break;
case UF_DEPTH:
PUSH_REAL("DEPTH", uf_ctx->stack_pos);
break;
case UF_LT:
case UF_LE:
case UF_EQ:
case UF_NE:
case UF_GE:
case UF_GT:
POP_COMPLEX("(x X -- ) IF", c2);
POP_COMPLEX("(X x -- ) IF", c1);
if ( cimag(c1) != 0.L || cimag(c2) != 0.L )
{
ERROR("comparison between complex numbers");
status = FAILURE;
goto loop_exit;
}
r1=creal(c1);
r2=creal(c2);
PUSH_REAL("comparison",
UF_LT == token->type ? ( r1<r2)
: UF_LE == token->type ? (r1<=r2)
: UF_EQ == token->type ? (r1==r2)
: UF_NE == token->type ? (r1!=r2)
: UF_GE == token->type ? (r1>=r2)
: UF_GT == token->type ? (r1>r2)
: 0);
break;
case UF_VALUE_REAL:
PUSH_REAL("real literal", token->r);
break;
case UF_VALUE_COMPLEX:
assert(!"not possible");
PUSH_REAL("complex literal", token->c);
break;
case UF_VALUE_SIMULATION:
{
yana_complex_t *sim_array;
const uforth_token_t *heap_token = heap_token = uforth_heap_get(heap, token->symbol);
if ( NULL != heap_token )
{
PUSH_COMPLEX("heap word", heap_token->c);
}
else
{
if ( token->symbol[0] != 'v' && token->symbol[0] != 'I' )
{
ERROR("Unknown symbol '%s'\n", token->symbol);
if ( sc )
HINT("dipoles start with 'I' and nodes start with 'v'");
status = FAILURE;
goto loop_exit;
}
sim_array = simulation_result(simulation, token->symbol+1);
if ( NULL == sim_array )
{
ERROR("Unknown symbol '%s'", token->symbol);
status = FAILURE;
goto loop_exit;
}
PUSH_COMPLEX("sim", sim_array[i]);
}
}
break;
}
}
loop_exit:
if (printed)
fprintf(stdout, "\n");
if ( SUCCESS != status && NULL != token )
{
fputs("ERROR: is here: ", stderr);
uforth_token_t *t;
for ( t = uf_ctx->first ;
t != NULL ;
t = t->next )
{
if ( t == token )
{
fprintf(stderr, ">>>%s<<<", t->symbol);
break;
}
else
{
fprintf(stderr, "%s ", t->symbol);
}
}
fputs("\n", stderr);
}
else if ( l_stack_pos != 0 )
{
ERROR("loop stack not empty at the end of the processing");
status = FAILURE;
}
else if ( uf_ctx->stack_pos != 0 && NULL == resultp )
{
if ( !end )
WARNING("stack not empty at the end of the processing");
uf_ctx->stack_pos = 0;
}
if ( SUCCESS == status && NULL != resultp)
{
if ( uf_ctx->stack_pos != 1 )
{
ERROR("one result was expected and stack size is %d",
uf_ctx->stack_pos);
status = FAILURE;
}
else
POP_COMPLEX("RESULT", *resultp);
}
if ( free_heap )
uforth_heap_free(heap);
return status;
}
void
ovm_q_atan2(oregister_t *l, oregister_t *r)
{
switch (r->t) {
case t_void:
if (!cfg_float_format) {
l->t = t_float;
l->v.d = atan2(mpq_get_d(oqr(l)), 0.0);
}
else {
mpfr_set_ui(orr(r), 0, thr_rnd);
goto mpr;
}
break;
case t_word:
if (!cfg_float_format) {
l->t = t_float;
l->v.d = atan2(mpq_get_d(oqr(l)), r->v.w);
}
else {
mpfr_set_si(orr(r), r->v.w, thr_rnd);
goto mpr;
}
break;
case t_float:
l->t = t_float;
l->v.d = atan2(mpq_get_d(oqr(l)), r->v.d);
break;
case t_mpz:
if (!cfg_float_format) {
l->t = t_float;
l->v.d = atan2(mpq_get_d(oqr(l)), mpz_get_d(ozr(r)));
}
else {
mpfr_set_z(orr(r), ozr(r), thr_rnd);
goto mpr;
}
break;
case t_rat:
if (!cfg_float_format) {
l->t = t_float;
l->v.d = atan2(mpq_get_d(oqr(l)), rat_get_d(r->v.r));
}
else {
mpq_set_si(oqr(r), rat_num(r->v.r), rat_den(r->v.r));
mpfr_set_q(orr(r), oqr(r), thr_rnd);
goto mpr;
}
break;
case t_mpq:
if (!cfg_float_format) {
l->t = t_float;
l->v.d = atan2(mpq_get_d(oqr(l)), mpq_get_d(oqr(r)));
}
else {
mpfr_set_q(orr(r), oqr(r), thr_rnd);
goto mpr;
}
break;
case t_mpr:
mpr:
mpfr_set_q(orr(l), oqr(l), thr_rnd);
l->t = t_mpr;
mpfr_atan2(orr(l), orr(l), orr(r), thr_rnd);
break;
case t_cdd:
cdd:
l->t = t_cdd;
real(l->v.dd) = mpq_get_d(oqr(l));
imag(l->v.dd) = 0.0;
l->v.dd = catan(l->v.dd / r->v.dd);
check_cdd(l);
break;
case t_cqq:
if (!cfg_float_format) {
real(r->v.dd) = mpq_get_d(oqr(r));
imag(r->v.dd) = mpq_get_d(oqi(r));
goto cdd;
}
mpc_set_q_q(occ(r), oqr(r), oqi(r), thr_rndc);
case t_mpc:
l->t = t_mpc;
mpc_set_q(occ(l), oqr(l), thr_rndc);
mpc_div(occ(l), occ(l), occ(r), thr_rndc);
mpc_atan(occ(l), occ(l), thr_rndc);
check_mpc(l);
break;
default:
ovm_raise(except_not_a_number);
}
}
TEST(complex, catan) {
ASSERT_EQ(0.0, catan(0));
}
double complex catanh(double complex z)
{
z = catan(CMPLX(-cimag(z), creal(z)));
return CMPLX(cimag(z), -creal(z));
}