bool TrigonometricFunction::unaryCot(ExecutionContext *context, QString *err)
{
switch (context->obligArg().type()) {
case PretexVariant::Int:
context->setReturnValue(ctan(context->obligArg().toInt()));
break;
case PretexVariant::Real:
context->setReturnValue(ctan(context->obligArg().toReal()));
break;
case PretexVariant::String:
default:
return bRet(err, tr("Invalid argument type", "error"), false);
}
return bRet(err, QString(), true);
}
//## Complex Complex.ctan();
static KMETHOD Complex_ctan(KonohaContext *kctx, KonohaStack *sfp)
{
kComplex *kc = (kComplex *) sfp[0].asObject;
double _Complex z = kc->z;
double ret = ctan(z);
KReturnFloatValue(ret);
}
//## Complex Complex.ctanl();
static KMETHOD Complex_ctanl(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 = ctanl(zl);
#else
long double ret = ctan(zl);
#endif
KReturnFloatValue(ret);
}
static double complex z_tan(double complex z)
{
double y = cimag(z);
double complex r = ctan(z);
if(R_FINITE(y) && fabs(y) > 25.0) {
/* at this point the real part is nearly zero, and the
imaginary part is one: but some OSes get the imag as NaN */
#if __GNUC__
__imag__ r = y < 0 ? -1.0 : 1.0;
#else
r = creal(r) + (y < 0 ? -1.0 : 1.0) * I;
#endif
}
return r;
}
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 double complex ctanh(double complex z)
{
return -I * ctan(z * I); /* A&S 4.5.9 */
}
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
}
void test3(__complex__ double x, __complex__ double y, int i)
{
if (carg(x) != atan2(__imag__ x, __real__ x))
link_error ();
if (ccos(x) != ccos(-x))
link_error();
if (ccos(ctan(x)) != ccos(ctan(-x)))
link_error();
if (ctan(x-y) != -ctan(y-x))
link_error();
if (ccos(x/y) != ccos(-x/y))
link_error();
if (ccos(x/y) != ccos(x/-y))
link_error();
if (ccos(x/ctan(y)) != ccos(-x/ctan(-y)))
link_error();
if (ccos(x*y) != ccos(-x*y))
link_error();
if (ccos(x*y) != ccos(x*-y))
link_error();
if (ccos(ctan(x)*y) != ccos(ctan(-x)*-y))
link_error();
if (ccos(ctan(x/y)) != ccos(-ctan(x/-y)))
link_error();
if (ccos(i ? x : y) != ccos(i ? -x : y))
link_error();
if (ccos(i ? x : y) != ccos(i ? x : -y))
link_error();
if (ccos(i ? x : ctan(y/x)) != ccos(i ? -x : -ctan(-y/x)))
link_error();
if (~x != -~-x)
link_error();
if (ccos(~x) != ccos(-~-x))
link_error();
if (ctan(~(x-y)) != -ctan(~(y-x)))
link_error();
if (ctan(~(x/y)) != -ctan(~(x/-y)))
link_error();
}
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) d = cacosh(d); f = cacoshf(f); ld = cacoshl(ld); TEST_TRACE(C99 7.3.6.2) d = casinh(d); f = casinhf(f); ld = casinhl(ld); TEST_TRACE(C99 7.3.6.3) d = catanh(d); f = catanhf(f); ld = catanhl(ld); TEST_TRACE(C99 7.3.6.4)
long double complex ctanl(long double complex z)
{
return ctan(z);
}
CAMLprim value math_ctan(value x) {
CAMLparam1(x);
CAMLreturn(caml_copy_complex(ctan(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;
}
TEST(complex, ctan) {
ASSERT_EQ(0.0, ctan(0));
}