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);
}
Пример #2
0
//## 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);
}
Пример #3
0
//## 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);
}
Пример #4
0
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;
}
Пример #5
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 } */
}
Пример #6
0
static double complex ctanh(double complex z)
{
    return -I * ctan(z * I); /* A&S 4.5.9 */
}
Пример #7
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
}
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();
}
Пример #9
0
 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)
Пример #10
0
Файл: ctanl.c Проект: KGG814/AOS
long double complex ctanl(long double complex z)
{
	return ctan(z);
}
Пример #11
0
CAMLprim value math_ctan(value x) {
  CAMLparam1(x);
  CAMLreturn(caml_copy_complex(ctan(Complex_val(x))));
}
Пример #12
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;
}
Пример #13
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;
}
Пример #14
0
TEST(complex, ctan) {
  ASSERT_EQ(0.0, ctan(0));
}