Exemple #1
0
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;
}
Exemple #2
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);
}
Exemple #3
0
double complex
casinh(double complex z)
{
	double complex w;

	w = -1.0 * I * casin (z * I);
	return (w);
}
Exemple #4
0
double complex
cacos(double complex z)
{
	double complex w;

	w = casin (z);
	w = (M_PI_2 - creal (w)) - cimag (w) * I;
	return (w);
}
Exemple #5
0
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);
}
Exemple #7
0
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);
}
Exemple #8
0
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;
}
Exemple #9
0
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);
}
Exemple #10
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 } */
}
Exemple #11
0
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;
}
Exemple #12
0
static double complex cacos(double complex z)
{
    return M_PI_2 - casin(z);
}
Exemple #13
0
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
}
Exemple #14
0
// 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)
Exemple #15
0
double complex casinh(double complex z) {
  z = casin(CMPLX(-cimag(z), creal(z)));
  return CMPLX(cimag(z), -creal(z));
}
Exemple #16
0
CAMLprim value math_casin(value x) {
  CAMLparam1(x);
  CAMLreturn(caml_copy_complex(casin(Complex_val(x))));
}
Exemple #17
0
double complex cacos(double complex z)
{
	z = casin(z);
	return CMPLX(M_PI_2 - creal(z), -cimag(z));
}
Exemple #18
0
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;
}
Exemple #19
0
long double complex casinl(long double complex z) {
  return casin(z);
}
TEST(complex, casin) {
  ASSERT_EQ(0.0, casin(0));
}