//## Complex Complex.ccos();
static KMETHOD Complex_ccos(KonohaContext *kctx, KonohaStack *sfp)
{
kComplex *kc = (kComplex *) sfp[0].asObject;
double _Complex z = kc->z;
double ret = ccos(z);
KReturnFloatValue(ret);
}
char *proobraz(char* input)
{
input = registr(input);
input= ficha(input);
for (int i=0;i<strlen(input);i++)
{
ssin(i,input);
ccos(i,input);
aasin(i,input);
aacos(i,input);
aatan(i,input);
cceil(i,input);
cch(i,input);
eexp(i,input);
aabs(i,input);
ffloor(i,input);
lln(i,input);
llog(i,input);
ssh(i,input);
ssqrt(i,input);
ttan(i,input);
tth(i,input);
cctg(i,input);
aactg(i,input);
ccth(i,input);
}
return input;
}
//## Complex Complex.ccosl();
static KMETHOD Complex_ccosl(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 = ccosl(zl);
#else
long double ret = ccos(zl);
#endif
KReturnFloatValue(ret);
}
int main()
{
double complex v, z;
double a = 0.0, b = 0.0;
puts("Calculate the arc cosine of a complex number, cacos(z)\n");
puts("Enter the real and imaginary parts of a complex number:");
if (scanf("%lf %lf", &a, &b) == 2)
{
z = a + b * I;
printf("z = %.2f %+.2f*I.\n", creal(z), cimag(z));
v = cacos(z);
printf("The cacos(z) function yields %.2f %+.2f*I.\n",
creal(v), cimag(v));
printf("The inverse function, ccos(cacos(z)), yields %.2f %+.2f*I.\n",
creal(ccos(v)), cimag(ccos(v)));
}
else
printf("Invalid input. \n");
return 0;
}
int main() {
_Complex double *c1, *c2, *sum, *prod, *c1csin, *c2csin, *c1ccos, *c2ccos;
c1 = (_Complex double *) malloc (sizeof(_Complex double));
c2 = (_Complex double *) malloc (sizeof(_Complex double));
sum = (_Complex double *) malloc (sizeof(_Complex double));
prod = (_Complex double *) malloc (sizeof(_Complex double));
c1csin = (_Complex double *) malloc (sizeof(_Complex double));
c2csin = (_Complex double *) malloc (sizeof(_Complex double));
c1ccos = (_Complex double *) malloc (sizeof(_Complex double));
c2ccos = (_Complex double *) malloc (sizeof(_Complex double));
*c1 = 1.3 + 2.5i;
*c2 = -2.7 + 0.3i;
printf("c1 = %g + %gi\n", creal(*c1), cimag(*c1));
printf("c2 = %g + %gi\n", creal(*c2), cimag(*c2));
*sum = *c1 + *c2;
*prod = *c1 * (*c2);
printf("c1 + c2 = %g + %gi\n", creal(*sum), cimag(*sum));
printf("c1 * c2 = %g + %gi\n", creal(*prod), cimag(*prod));
*c1csin = csin(*c1);
*c2csin = csin(*c1);
printf("csin(c1) = %g + %gi\n", creal(*c1csin), cimag(*c1csin));
printf("csin(c2) = %g + %gi\n", creal(*c1csin), cimag(*c1csin));
*c1ccos = ccos(*c1);
*c2ccos = ccos(*c1);
printf("ccos(c1) = %g + %gi\n", creal(*c1ccos), cimag(*c1ccos));
printf("ccos(c2) = %g + %gi\n", creal(*c1ccos), cimag(*c1ccos));
return 0;
}
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 ccosh(double complex z)
{
return ccos(z * I); /* A&S 4.5.8 */
}
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 test2(double x, double y)
{
if (-tan(x-y) != tan(y-x))
link_error ();
if (-sin(x-y) != sin(y-x))
link_error ();
if (cos(-x*y) != cos(x*y))
link_error ();
if (cos(x*-y) != cos(x*y))
link_error ();
if (cos(-x/y) != cos(x/y))
link_error ();
if (cos(x/-y) != cos(x/y))
link_error ();
if (cos(-fabs(tan(x/-y))) != cos(tan(x/y)))
link_error ();
if (cos(y<10 ? -x : y) != cos(y<10 ? x : y))
link_error ();
if (cos(y<10 ? x : -y) != cos(y<10 ? x : y))
link_error ();
if (cos(y<10 ? -fabs(x) : tan(x<20 ? -x : -fabs(y)))
!= cos(y<10 ? x : tan(x<20 ? x : y)))
link_error ();
if (cos((y*=3, -x)) != cos((y*=3,x)))
link_error ();
if (cos((y*=2, -fabs(tan(x/-y)))) != cos((y*=2,tan(x/y))))
link_error ();
if (cos(copysign(x,y)) != cos(x))
link_error ();
if (cos(copysign(-fabs(x),y*=2)) != cos((y*=2,x)))
link_error ();
if (hypot (x, 0) != fabs(x))
link_error ();
if (hypot (0, x) != fabs(x))
link_error ();
if (hypot (x, x) != fabs(x) * __builtin_sqrt(2))
link_error ();
if (hypot (-x, y) != hypot (x, y))
link_error ();
if (hypot (x, -y) != hypot (x, y))
link_error ();
if (hypot (-x, -y) != hypot (x, y))
link_error ();
if (hypot (fabs(x), y) != hypot (x, y))
link_error ();
if (hypot (x, fabs(y)) != hypot (x, y))
link_error ();
if (hypot (fabs(x), fabs(y)) != hypot (x, y))
link_error ();
if (hypot (-fabs(-x), -fabs(fabs(fabs(-y)))) != hypot (x, y))
link_error ();
if (hypot (-x, 0) != fabs(x))
link_error ();
if (hypot (-x, x) != fabs(x) * __builtin_sqrt(2))
link_error ();
if (hypot (pure(x), -pure(x)) != fabs(pure(x)) * __builtin_sqrt(2))
link_error ();
if (hypot (tan(-x), tan(-fabs(y))) != hypot (tan(x), tan(y)))
link_error ();
if (fmin (fmax(x,y),y) != y)
link_error ();
if (fmin (fmax(y,x),y) != y)
link_error ();
if (fmin (x,fmax(x,y)) != x)
link_error ();
if (fmin (x,fmax(y,x)) != x)
link_error ();
if (fmax (fmin(x,y),y) != y)
link_error ();
if (fmax (fmin(y,x),y) != y)
link_error ();
if (fmax (x,fmin(x,y)) != x)
link_error ();
if (fmax (x,fmin(y,x)) != x)
link_error ();
if ((__complex__ double) x != -(__complex__ double) (-x))
link_error ();
if (x*1i != -(-x*1i))
link_error ();
if (x+(x-y)*1i != -(-x+(y-x)*1i))
link_error ();
if (x+(x-y)*1i != -(-x-(x-y)*1i))
link_error ();
if (ccos(tan(x)+sin(y)*1i) != ccos(-tan(-x)+-sin(-y)*1i))
link_error ();
if (ccos(tan(x)+sin(x-y)*1i) != ccos(-tan(-x)-sin(y-x)*1i))
link_error ();
if (-5+x*1i != -~(5+x*1i))
link_error ();
if (tan(x)+tan(y)*1i != -~(tan(-x)+tan(y)*1i))
link_error ();
}
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();
}
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)
d = cacosh(d);
f = cacoshf(f);
ld = cacoshl(ld);
TEST_TRACE(C99 7.3.6.2)
CAMLprim value math_ccos(value x) {
CAMLparam1(x);
CAMLreturn(caml_copy_complex(ccos(Complex_val(x))));
}
void z_cos(doublecomplex *r, doublecomplex *z)
{
double _Complex ret_val = ccos(z->r + I*z->i);
r->r = creal(ret_val);
r->i = cimag(ret_val);
}
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, ccos) {
ASSERT_EQ(1.0, ccos(0));
}
long double complex ccosl(long double complex z)
{
return ccos(z);
}