int main (void)
{
double complex z = casin (-2);
printf ("casin(-2+0i) = %f%+fi\n", creal (z), cimag (z));
double complex z2 = casin (conj (-2)); // or CMPLX(-2, -0.0)
printf ("casin(-2-0i) (the other side of the cut) = %f%+fi\n", creal (z2), cimag (z2));
// for any z, asin(z) = acos(-z) - pi/2
double pi = acos (-1);
double complex z3 = csin (cacos (conj (-2)) - pi / 2);
printf ("csin(cacos(-2-0i)-pi/2) = %f%+fi\n", creal (z3), cimag (z3));
return 0;
}
//## Complex Complex.casin();
static KMETHOD Complex_casin(KonohaContext *kctx, KonohaStack *sfp)
{
kComplex *kc = (kComplex *) sfp[0].asObject;
double _Complex z = kc->z;
double ret = casin(z);
KReturnFloatValue(ret);
}
double complex
casinh(double complex z)
{
double complex w;
w = -1.0 * I * casin (z * I);
return (w);
}
double complex
cacos(double complex z)
{
double complex w;
w = casin (z);
w = (M_PI_2 - creal (w)) - cimag (w) * I;
return (w);
}
double complex cacosh (double complex Z)
{
double complex Tmp;
double complex Res;
Tmp = casin (Z);
__real__ Res = __imag__ Tmp;
__imag__ Res = M_PI_2 - __real__ Tmp;
return Res;
}
//## Complex Complex.casinl();
static KMETHOD Complex_casinl(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 = casinl(zl);
#else
long double ret = casin(zl);
#endif
KReturnFloatValue(ret);
}
dcomplex
casinh(dcomplex z) {
dcomplex w, r, ans;
D_RE(w) = -D_IM(z);
D_IM(w) = D_RE(z);
r = casin(w);
D_RE(ans) = D_IM(r);
D_IM(ans) = -D_RE(r);
return (ans);
}
double complex
cacos(double complex z)
{
double complex w;
/* FIXME: The original NetBSD code results in an ICE when trying to
build this function on ARM/Thumb using gcc 4.5.1. For now we use
a hopefully temporary workaround. */
#if 0
w = casin(z);
w = (M_PI_2 - creal(w)) - cimag(w) * I;
#else
double complex tmp0, tmp1;
tmp0 = casin(z);
tmp1 = M_PI_2 - creal(tmp0);
w = tmp1 - (cimag(tmp0) * I);
#endif
return w;
}
static double complex z_asin(double complex z)
{
if(cimag(z) == 0 && fabs(creal(z)) > 1) {
double alpha, t1, t2, x = creal(z), ri;
t1 = 0.5 * fabs(x + 1);
t2 = 0.5 * fabs(x - 1);
alpha = t1 + t2;
ri = log(alpha + sqrt(alpha*alpha - 1));
if(x > 1) ri *= -1;
return asin(t1 - t2) + ri*I;
}
return casin(z);
}
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 } */
}
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 double complex cacos(double complex z)
{
return M_PI_2 - casin(z);
}
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
}
// RUN: %x86_64ecc -o %t %s -lm && %x86_64run %t
#include "../ecc_test.h"
#include <complex.h>
// 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)
double complex casinh(double complex z) {
z = casin(CMPLX(-cimag(z), creal(z)));
return CMPLX(cimag(z), -creal(z));
}
CAMLprim value math_casin(value x) {
CAMLparam1(x);
CAMLreturn(caml_copy_complex(casin(Complex_val(x))));
}
double complex cacos(double complex z)
{
z = casin(z);
return CMPLX(M_PI_2 - creal(z), -cimag(z));
}
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;
}
long double complex casinl(long double complex z) {
return casin(z);
}
TEST(complex, casin) {
ASSERT_EQ(0.0, casin(0));
}