I was the one who changed my system, in ingnorance. It's kind of a long, stupid story (though I had fun messing with it), but I was trying to build up Gnustep, and couldn't get any of the code to be recogized by the Terminal, so I got disgusted with being rejected using "sudo", and put the Gnustep "Make" code in using "root". It took off like a shot. So I then went and got Oolite 1.65 x 86, and entered the install code for it right after the "root" setup was finished......and there you have it. It set up an Oolite folder in the Lib section of usr, in the System Files, and now I can't figure out how to put OXPs into that AddOns folder. I've attached a copy of the Gnustep code I entered into Terminal. The Oolite I installed is a rather large package installer, 1.65 x 86. I simply extracted that download, and clicked on it to install, and the package installer did the rest, after I entered my password. Maybe this is a mess a little too big to clean up. I would be happy to reinstall Oolite to my Home file, rather than the File System, using "sudo", rather than "root", but I confess I don't know how. I guess I should have just stuck with the version that came with Ubuntu. If this would be a better course to take, please let me know. Thanks.
I couldn't see where to attach the document on which I saved the Gnustep code I put into Terminal, so here is the code.
Code: Select all
#include "config.h"
#include "system.h"
#include "flags.h"
#include "gfortran.h"
#include "arith.h"
#include "target-memory.h"
void
gfc_mpfr_to_mpz (mpz_t z, mpfr_t x, locus *where)
{
mp_exp_t e;
if (mpfr_inf_p (x) || mpfr_nan_p (x))
{
gfc_error ("Conversion of an Infinity or Not-a-Number at %L "
"to INTEGER", where);
mpz_set_ui (z, 0);
return;
}
e = mpfr_get_z_exp (z, x);
if (e > 0)
mpz_mul_2exp (z, z, e);
else
mpz_tdiv_q_2exp (z, z, -e);
}
void
gfc_set_model_kind (int kind)
{
int index = gfc_validate_kind (BT_REAL, kind, false);
int base2prec;
base2prec = gfc_real_kinds[index].digits;
if (gfc_real_kinds[index].radix != 2)
base2prec *= gfc_real_kinds[index].radix / 2;
mpfr_set_default_prec (base2prec);
}
void
gfc_set_model (mpfr_t x)
{
mpfr_set_default_prec (mpfr_get_prec (x));
}
static const char *
gfc_arith_error (arith code)
{
const char *p;
switch (code)
{
case ARITH_OK:
p = _("Arithmetic OK at %L");
break;
case ARITH_OVERFLOW:
p = _("Arithmetic overflow at %L");
break;
case ARITH_UNDERFLOW:
p = _("Arithmetic underflow at %L");
break;
case ARITH_NAN:
p = _("Arithmetic NaN at %L");
break;
case ARITH_DIV0:
p = _("Division by zero at %L");
break;
case ARITH_INCOMMENSURATE:
p = _("Array operands are incommensurate at %L");
break;
case ARITH_ASYMMETRIC:
p =
_("Integer outside symmetric range implied by Standard Fortran at %L");
break;
default:
gfc_internal_error ("gfc_arith_error(): Bad error code");
}
return p;
}
void
gfc_arith_init_1 (void)
{
gfc_integer_info *int_info;
gfc_real_info *real_info;
mpfr_t a, b;
int i;
mpfr_set_default_prec (128);
mpfr_init (a);
for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++)
{
mpz_init (int_info->huge);
mpz_set_ui (int_info->huge, int_info->radix);
mpz_pow_ui (int_info->huge, int_info->huge, int_info->digits);
mpz_sub_ui (int_info->huge, int_info->huge, 1);
if (int_info->radix != 2)
gfc_internal_error ("Fix min_int calculation");
mpz_init (int_info->pedantic_min_int);
mpz_neg (int_info->pedantic_min_int, int_info->huge);
mpz_init (int_info->min_int);
mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);
mpfr_set_z (a, int_info->huge, GFC_RND_MODE);
mpfr_log10 (a, a, GFC_RND_MODE);
mpfr_trunc (a, a);
int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
}
mpfr_clear (a);
for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
{
gfc_set_model_kind (real_info->kind);
mpfr_init (a);
mpfr_init (b);
mpfr_init (real_info->huge);
mpfr_set_ui (real_info->huge, 1, GFC_RND_MODE);
mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODE);
mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODE);
mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODE);
mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODE);
mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix,
GFC_RND_MODE);
mpfr_init (real_info->tiny);
mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODE);
mpfr_pow_si (real_info->tiny, real_info->tiny,
real_info->min_exponent - 1, GFC_RND_MODE);
mpfr_init (real_info->subnormal);
mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODE);
mpfr_pow_si (real_info->subnormal, real_info->subnormal,
real_info->min_exponent - real_info->digits, GFC_RND_MODE);
mpfr_init (real_info->epsilon);
mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODE);
mpfr_pow_si (real_info->epsilon, real_info->epsilon,
1 - real_info->digits, GFC_RND_MODE);
mpfr_log10 (a, real_info->huge, GFC_RND_MODE);
mpfr_log10 (b, real_info->tiny, GFC_RND_MODE);
mpfr_neg (b, b, GFC_RND_MODE);
mpfr_min (a, a, b, GFC_RND_MODE);
mpfr_trunc (a, a);
real_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
mpfr_log10 (a, a, GFC_RND_MODE);
mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE);
mpfr_trunc (a, a);
real_info->precision = (int) mpfr_get_si (a, GFC_RND_MODE);
for (i = 10; i <= real_info->radix; i *= 10)
if (i == real_info->radix)
real_info->precision++;
mpfr_clears (a, b, NULL);
}
}
void
gfc_arith_done_1 (void)
{
gfc_integer_info *ip;
gfc_real_info *rp;
for (ip = gfc_integer_kinds; ip->kind; ip++)
{
mpz_clear (ip->min_int);
mpz_clear (ip->pedantic_min_int);
mpz_clear (ip->huge);
}
for (rp = gfc_real_kinds; rp->kind; rp++)
mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL);
}
bool
gfc_check_character_range (gfc_char_t c, int kind)
{
if (kind == 4)
return true;
if (kind == 1)
return c <= 255 ? true : false;
gcc_unreachable ();
}
arith
gfc_check_integer_range (mpz_t p, int kind)
{
arith result;
int i;
i = gfc_validate_kind (BT_INTEGER, kind, false);
result = ARITH_OK;
if (pedantic)
{
if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0)
result = ARITH_ASYMMETRIC;
}
if (gfc_option.flag_range_check == 0)
return result;
if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
|| mpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
result = ARITH_OVERFLOW;
return result;
}
static arith
gfc_check_real_range (mpfr_t p, int kind)
{
arith retval;
mpfr_t q;
int i;
i = gfc_validate_kind (BT_REAL, kind, false);
gfc_set_model (p);
mpfr_init (q);
mpfr_abs (q, p, GFC_RND_MODE);
retval = ARITH_OK;
if (mpfr_inf_p (p))
{
if (gfc_option.flag_range_check != 0)
retval = ARITH_OVERFLOW;
}
else if (mpfr_nan_p (p))
{
if (gfc_option.flag_range_check != 0)
retval = ARITH_NAN;
}
else if (mpfr_sgn (q) == 0)
{
mpfr_clear (q);
return retval;
}
else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
{
if (gfc_option.flag_range_check == 0)
mpfr_set_inf (p, mpfr_sgn (p));
else
retval = ARITH_OVERFLOW;
}
else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
{
if (gfc_option.flag_range_check == 0)
{
if (mpfr_sgn (p) < 0)
{
mpfr_set_ui (p, 0, GFC_RND_MODE);
mpfr_set_si (q, -1, GFC_RND_MODE);
mpfr_copysign (p, p, q, GFC_RND_MODE);
}
else
mpfr_set_ui (p, 0, GFC_RND_MODE);
}
else
retval = ARITH_UNDERFLOW;
}
else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
{
mp_exp_t emin, emax;
int en;
emin = mpfr_get_emin ();
emax = mpfr_get_emax ();
en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1;
mpfr_set_emin ((mp_exp_t) en);
mpfr_set_emax ((mp_exp_t) gfc_real_kinds[i].max_exponent);
mpfr_check_range (q, 0, GFC_RND_MODE);
mpfr_subnormalize (q, 0, GFC_RND_MODE);
mpfr_set_emin (emin);
mpfr_set_emax (emax);
if (mpfr_sgn (p) < 0)
mpfr_neg (p, q, GMP_RNDN);
else
mpfr_set (p, q, GMP_RNDN);
}
mpfr_clear (q);
return retval;
}
gfc_expr *
gfc_constant_result (bt type, int kind, locus *where)
{
gfc_expr *result;
if (!where)
gfc_internal_error ("gfc_constant_result(): locus 'where' cannot be NULL");
result = gfc_get_expr ();
result->expr_type = EXPR_CONSTANT;
result->ts.type = type;
result->ts.kind = kind;
result->where = *where;
switch (type)
{
case BT_INTEGER:
mpz_init (result->value.integer);
break;
case BT_REAL:
gfc_set_model_kind (kind);
mpfr_init (result->value.real);
break;
case BT_COMPLEX:
gfc_set_model_kind (kind);
mpfr_init (result->value.complex.r);
mpfr_init (result->value.complex.i);
break;
default:
break;
}
return result;
}
static arith
gfc_arith_not (gfc_expr *op1, gfc_expr **resultp)
{
gfc_expr *result;
result = gfc_constant_result (BT_LOGICAL, op1->ts.kind, &op1->where);
result->value.logical = !op1->value.logical;
*resultp = result;
return ARITH_OK;
}
static arith
gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
gfc_expr *result;
result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
&op1->where);
result->value.logical = op1->value.logical && op2->value.logical;
*resultp = result;
return ARITH_OK;
}
static arith
gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
gfc_expr *result;
result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
&op1->where);
result->value.logical = op1->value.logical || op2->value.logical;
*resultp = result;
return ARITH_OK;
}
static arith
gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
gfc_expr *result;
result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
&op1->where);
result->value.logical = op1->value.logical == op2->value.logical;
*resultp = result;
return ARITH_OK;
}
static arith
gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
gfc_expr *result;
result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
&op1->where);
result->value.logical = op1->value.logical != op2->value.logical;
*resultp = result;
return ARITH_OK;
}
arith
gfc_range_check (gfc_expr *e)
{
arith rc;
arith rc2;
switch (e->ts.type)
{
case BT_INTEGER:
rc = gfc_check_integer_range (e->value.integer, e->ts.kind);
break;
case BT_REAL:
rc = gfc_check_real_range (e->value.real, e->ts.kind);
if (rc == ARITH_UNDERFLOW)
mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
if (rc == ARITH_OVERFLOW)
mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real));
if (rc == ARITH_NAN)
mpfr_set_nan (e->value.real);
break;
case BT_COMPLEX:
rc = gfc_check_real_range (e->value.complex.r, e->ts.kind);
if (rc == ARITH_UNDERFLOW)
mpfr_set_ui (e->value.complex.r, 0, GFC_RND_MODE);
if (rc == ARITH_OVERFLOW)
mpfr_set_inf (e->value.complex.r, mpfr_sgn (e->value.complex.r));
if (rc == ARITH_NAN)
mpfr_set_nan (e->value.complex.r);
rc2 = gfc_check_real_range (e->value.complex.i, e->ts.kind);
if (rc == ARITH_UNDERFLOW)
mpfr_set_ui (e->value.complex.i, 0, GFC_RND_MODE);
if (rc == ARITH_OVERFLOW)
mpfr_set_inf (e->value.complex.i, mpfr_sgn (e->value.complex.i));
if (rc == ARITH_NAN)
mpfr_set_nan (e->value.complex.i);
if (rc == ARITH_OK)
rc = rc2;
break;
default:
gfc_internal_error ("gfc_range_check(): Bad type");
}
return rc;
}
static arith
check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp)
{
arith val = rc;
if (val == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
gfc_warning (gfc_arith_error (val), &x->where);
val = ARITH_OK;
}
if (val == ARITH_ASYMMETRIC)
{
gfc_warning (gfc_arith_error (val), &x->where);
val = ARITH_OK;
}
if (val != ARITH_OK)
gfc_free_expr (r);
else
*rp = r;
return val;
}
static arith
gfc_arith_identity (gfc_expr *op1, gfc_expr **resultp)
{
*resultp = gfc_copy_expr (op1);
return ARITH_OK;
}
static arith
gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
{
gfc_expr *result;
arith rc;
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
switch (op1->ts.type)
{
case BT_INTEGER:
mpz_neg (result->value.integer, op1->value.integer);
break;
case BT_REAL:
mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
mpfr_neg (result->value.complex.r, op1->value.complex.r, GFC_RND_MODE);
mpfr_neg (result->value.complex.i, op1->value.complex.i, GFC_RND_MODE);
break;
default:
gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
}
rc = gfc_range_check (result);
return check_result (rc, op1, result, resultp);
}
static arith
gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
gfc_expr *result;
arith rc;
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
switch (op1->ts.type)
{
case BT_INTEGER:
mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
break;
case BT_REAL:
mpfr_add (result->value.real, op1->value.real, op2->value.real,
GFC_RND_MODE);
break;
case BT_COMPLEX:
mpfr_add (result->value.complex.r, op1->value.complex.r,
op2->value.complex.r, GFC_RND_MODE);
mpfr_add (result->value.complex.i, op1->value.complex.i,
op2->value.complex.i, GFC_RND_MODE);
break;
default:
gfc_internal_error ("gfc_arith_plus(): Bad basic type");
}
rc = gfc_range_check (result);
return check_result (rc, op1, result, resultp);
}
static arith
gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
gfc_expr *result;
arith rc;
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
switch (op1->ts.type)
{
case BT_INTEGER:
mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
break;
case BT_REAL:
mpfr_sub (result->value.real, op1->value.real, op2->value.real,
GFC_RND_MODE);
break;
case BT_COMPLEX:
mpfr_sub (result->value.complex.r, op1->value.complex.r,
op2->value.complex.r, GFC_RND_MODE);
mpfr_sub (result->value.complex.i, op1->value.complex.i,
op2->value.complex.i, GFC_RND_MODE);
break;
default:
gfc_internal_error ("gfc_arith_minus(): Bad basic type");
}
rc = gfc_range_check (result);
return check_result (rc, op1, result, resultp);
}
static arith
gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
gfc_expr *result;
mpfr_t x, y;
arith rc;
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
switch (op1->ts.type)
{
case BT_INTEGER:
mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
break;
case BT_REAL:
mpfr_mul (result->value.real, op1->value.real, op2->value.real,
GFC_RND_MODE);
break;
case BT_COMPLEX:
gfc_set_model (op1->value.complex.r);
mpfr_init (x);
mpfr_init (y);
mpfr_mul (x, op1->value.complex.r, op2->value.complex.r, GFC_RND_MODE);
mpfr_mul (y, op1->value.complex.i, op2->value.complex.i, GFC_RND_MODE);
mpfr_sub (result->value.complex.r, x, y, GFC_RND_MODE);
mpfr_mul (x, op1->value.complex.r, op2->value.complex.i, GFC_RND_MODE);
mpfr_mul (y, op1->value.complex.i, op2->value.complex.r, GFC_RND_MODE);
mpfr_add (result->value.complex.i, x, y, GFC_RND_MODE);
mpfr_clears (x, y, NULL);
break;
default:
gfc_internal_error ("gfc_arith_times(): Bad basic type");
}
rc = gfc_range_check (result);
return check_result (rc, op1, result, resultp);
}
static arith
gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
gfc_expr *result;
mpfr_t x, y, div;
arith rc;
rc = ARITH_OK;
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
switch (op1->ts.type)
{
case BT_INTEGER:
if (mpz_sgn (op2->value.integer) == 0)
{
rc = ARITH_DIV0;
break;
}
mpz_tdiv_q (result->value.integer, op1->value.integer,
op2->value.integer);
break;
case BT_REAL:
if (mpfr_sgn (op2->value.real) == 0 && gfc_option.flag_range_check == 1)
{
rc = ARITH_DIV0;
break;
}
mpfr_div (result->value.real, op1->value.real, op2->value.real,
GFC_RND_MODE);
break;
case BT_COMPLEX:
if (mpfr_sgn (op2->value.complex.r) == 0
&& mpfr_sgn (op2->value.complex.i) == 0
&& gfc_option.flag_range_check == 1)
{
rc = ARITH_DIV0;
break;
}
gfc_set_model (op1->value.complex.r);
mpfr_init (x);
mpfr_init (y);
mpfr_init (div);
mpfr_mul (x, op2->value.complex.r, op2->value.complex.r, GFC_RND_MODE);
mpfr_mul (y, op2->value.complex.i, op2->value.complex.i, GFC_RND_MODE);
mpfr_add (div, x, y, GFC_RND_MODE);
mpfr_mul (x, op1->value.complex.r, op2->value.complex.r, GFC_RND_MODE);
mpfr_mul (y, op1->value.complex.i, op2->value.complex.i, GFC_RND_MODE);
mpfr_add (result->value.complex.r, x, y, GFC_RND_MODE);
mpfr_div (result->value.complex.r, result->value.complex.r, div,
GFC_RND_MODE);
mpfr_mul (x, op1->value.complex.i, op2->value.complex.r, GFC_RND_MODE);
mpfr_mul (y, op1->value.complex.r, op2->value.complex.i, GFC_RND_MODE);
mpfr_sub (result->value.complex.i, x, y, GFC_RND_MODE);
mpfr_div (result->value.complex.i, result->value.complex.i, div,
GFC_RND_MODE);
mpfr_clears (x, y, div, NULL);
break;
default:
gfc_internal_error ("gfc_arith_divide(): Bad basic type");
}
if (rc == ARITH_OK)
rc = gfc_range_check (result);
return check_result (rc, op1, result, resultp);
}
static void
complex_reciprocal (gfc_expr *op)
{
mpfr_t mod, tmp;
gfc_set_model (op->value.complex.r);
mpfr_init (mod);
mpfr_init (tmp);
mpfr_mul (mod, op->value.complex.r, op->value.complex.r, GFC_RND_MODE);
mpfr_mul (tmp, op->value.complex.i, op->value.complex.i, GFC_RND_MODE);
mpfr_add (mod, mod, tmp, GFC_RND_MODE);
mpfr_div (op->value.complex.r, op->value.complex.r, mod, GFC_RND_MODE);
mpfr_neg (op->value.complex.i, op->value.complex.i, GFC_RND_MODE);
mpfr_div (op->value.complex.i, op->value.complex.i, mod, GFC_RND_MODE);
mpfr_clears (tmp, mod, NULL);
}
Use Binary Method, which is not an optimal but a simple and reasonable
arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth,
"Seminumerical Algorithms", Vol. 2, "The Art of Computer Programming",
3rd Edition, 1998. */
static void
complex_pow (gfc_expr *result, gfc_expr *base, mpz_t power)
{
mpfr_t x_r, x_i, tmp, re, im;
gfc_set_model (base->value.complex.r);
mpfr_init (x_r);
mpfr_init (x_i);
mpfr_init (tmp);
mpfr_init (re);
mpfr_init (im);
mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE);
mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
mpfr_set (x_r, base->value.complex.r, GFC_RND_MODE);
mpfr_set (x_i, base->value.complex.i, GFC_RND_MODE);
#define CMULT(res_r,res_i,a_r,a_i,b_r,b_i) \
mpfr_mul (re, a_r, b_r, GFC_RND_MODE), \
mpfr_mul (tmp, a_i, b_i, GFC_RND_MODE), \
mpfr_sub (re, re, tmp, GFC_RND_MODE), \
\
mpfr_mul (im, a_r, b_i, GFC_RND_MODE), \
mpfr_mul (tmp, a_i, b_r, GFC_RND_MODE), \
mpfr_add (res_i, im, tmp, GFC_RND_MODE), \
mpfr_set (res_r, re, GFC_RND_MODE)
#define res_r result->value.complex.r
#define res_i result->value.complex.i
for (; mpz_cmp_si (power, 0) > 0; CMULT(x_r,x_i,x_r,x_i,x_r,x_i))
{
if (mpz_congruent_ui_p (power, 1, 2))
CMULT(res_r,res_i,res_r,res_i,x_r,x_i);
mpz_fdiv_q_ui (power, power, 2);
}
#undef res_r
#undef res_i
#undef CMULT
mpfr_clears (x_r, x_i, tmp, re, im, NULL);
}
static arith
gfc_arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
int power_sign;
gfc_expr *result;
arith rc;
gcc_assert (op2->expr_type == EXPR_CONSTANT && op2->ts.type == BT_INTEGER);
rc = ARITH_OK;
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
power_sign = mpz_sgn (op2->value.integer);
if (power_sign == 0)
{
switch (op1->ts.type)
{
case BT_INTEGER:
mpz_set_ui (result->value.integer, 1);
break;
case BT_REAL:
mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
break;
case BT_COMPLEX:
mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE);
mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
break;
default:
gfc_internal_error ("gfc_arith_power(): Bad base");
}
}
else
{
switch (op1->ts.type)
{
case BT_INTEGER:
{
int power;
if (mpz_cmp_si (op1->value.integer, 1) == 0)
{
mpz_set_si (result->value.integer, 1);
}
else if (mpz_cmp_si (op1->value.integer, 0) == 0)
{
mpz_set_si (result->value.integer, 0);
if (mpz_cmp_si (op2->value.integer, 0) < 0)
rc = ARITH_DIV0;
}
else if (mpz_cmp_si (op1->value.integer, -1) == 0)
{
unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
if (odd)
mpz_set_si (result->value.integer, -1);
else
mpz_set_si (result->value.integer, 1);
}
else if (mpz_cmp_si (op2->value.integer, 0) < 0)
{
mpz_set_si (result->value.integer, 0);
}
else if (gfc_extract_int (op2, &power) != NULL)
{
mpz_t max;
int i = gfc_validate_kind (BT_INTEGER, result->ts.kind, false);
if (gfc_option.flag_range_check)
rc = ARITH_OVERFLOW;
mpz_init (max);
mpz_add_ui (max, gfc_integer_kinds[i].huge, 1);
mpz_mul_ui (max, max, 2);
mpz_powm (result->value.integer, op1->value.integer,
op2->value.integer, max);
mpz_clear (max);
}
else
mpz_pow_ui (result->value.integer, op1->value.integer, power);
}
break;
case BT_REAL:
mpfr_pow_z (result->value.real, op1->value.real, op2->value.integer,
GFC_RND_MODE);
break;
case BT_COMPLEX:
{
mpz_t apower;
mpz_init (apower);
mpz_abs (apower, op2->value.integer);
complex_pow (result, op1, apower);
mpz_clear (apower);
if (power_sign < 0)
complex_reciprocal (result);
break;
}
default:
break;
}
}
if (rc == ARITH_OK)
rc = gfc_range_check (result);
return check_result (rc, op1, result, resultp);
}
static arith
gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
gfc_expr *result;
int len;
gcc_assert (op1->ts.kind == op2->ts.kind);
result = gfc_constant_result (BT_CHARACTER, op1->ts.kind,
&op1->where);
len = op1->value.character.length + op2->value.character.length;
result->value.character.string = gfc_get_wide_string (len + 1);
result->value.character.length = len;
memcpy (result->value.character.string, op1->value.character.string,
op1->value.character.length * sizeof (gfc_char_t));
memcpy (&result->value.character.string[op1->value.character.length],
op2->value.character.string,
op2->value.character.length * sizeof (gfc_char_t));
result->value.character.string[len] = '\0';
*resultp = result;
return ARITH_OK;
}
static int
compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
int rc;
switch (op)
{
case INTRINSIC_EQ:
rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
break;
case INTRINSIC_GT:
rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1;
break;
case INTRINSIC_GE:
rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1;
break;
case INTRINSIC_LT:
rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1;
break;
case INTRINSIC_LE:
rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1;
break;
default:
gfc_internal_error ("compare_real(): Bad operator");
}
return rc;
}
int
gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
int rc;
switch (op1->ts.type)
{
case BT_INTEGER:
rc = mpz_cmp (op1->value.integer, op2->value.integer);
break;
case BT_REAL:
rc = compare_real (op1, op2, op);
break;
case BT_CHARACTER:
rc = gfc_compare_string (op1, op2);
break;
case BT_LOGICAL:
rc = ((!op1->value.logical && op2->value.logical)
|| (op1->value.logical && !op2->value.logical));
break;
default:
gfc_internal_error ("gfc_compare_expr(): Bad basic type");
}
return rc;
}
static int
compare_complex (gfc_expr *op1, gfc_expr *op2)
{
return (mpfr_equal_p (op1->value.complex.r, op2->value.complex.r)
&& mpfr_equal_p (op1->value.complex.i, op2->value.complex.i));
}
int
gfc_compare_string (gfc_expr *a, gfc_expr *b)
{
int len, alen, blen, i;
gfc_char_t ac, bc;
alen = a->value.character.length;
blen = b->value.character.length;
len = MAX(alen, blen);
for (i = 0; i < len; i++)
{
ac = ((i < alen) ? a->value.character.string[i] : ' ');
bc = ((i < blen) ? b->value.character.string[i] : ' ');
if (ac < bc)
return -1;
if (ac > bc)
return 1;
}
return 0;
}
int
gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
{
int len, alen, blen, i;
gfc_char_t ac, bc;
alen = a->value.character.length;
blen = strlen (b);
len = MAX(alen, blen);
for (i = 0; i < len; i++)
{
ac = ((i < alen) ? a->value.character.string[i] : ' ');
bc = ((i < blen) ? b[i] : ' ');
if (!case_sensitive)
{
ac = TOLOWER (ac);
bc = TOLOWER (bc);
}
if (ac < bc)
return -1;
if (ac > bc)
return 1;
}
return 0;
}
static arith
gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
gfc_expr *result;
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where);
result->value.logical = (op1->ts.type == BT_COMPLEX)
? compare_complex (op1, op2)
: (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
*resultp = result;
return ARITH_OK;
}
static arith
gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
gfc_expr *result;
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where);
result->value.logical = (op1->ts.type == BT_COMPLEX)
? !compare_complex (op1, op2)
: (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
*resultp = result;
return ARITH_OK;
}
static arith
gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
gfc_expr *result;
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where);
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
*resultp = result;
return ARITH_OK;
}
static arith
gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
gfc_expr *result;
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where);
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
*resultp = result;
return ARITH_OK;
}
static arith
gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
gfc_expr *result;
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where);
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
*resultp = result;
return ARITH_OK;
}
static arith
gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
gfc_expr *result;
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where);
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
*resultp = result;
return ARITH_OK;
}
static arith
reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
gfc_expr **result)
{
gfc_constructor *c, *head;
gfc_expr *r;
arith rc;
if (op->expr_type == EXPR_CONSTANT)
return eval (op, result);
rc = ARITH_OK;
head = gfc_copy_constructor (op->value.constructor);
for (c = head; c; c = c->next)
{
rc = reduce_unary (eval, c->expr, &r);
if (rc != ARITH_OK)
break;
gfc_replace_expr (c->expr, r);
}
if (rc != ARITH_OK)
gfc_free_constructor (head);
else
{
r = gfc_get_expr ();
r->expr_type = EXPR_ARRAY;
r->value.constructor = head;
r->shape = gfc_copy_shape (op->shape, op->rank);
r->ts = head->expr->ts;
r->where = op->where;
r->rank = op->rank;
*result = r;
}
return rc;
}
static arith
reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
{
gfc_constructor *c, *head;
gfc_expr *r;
arith rc;
head = gfc_copy_constructor (op1->value.constructor);
rc = ARITH_OK;
for (c = head; c; c = c->next)
{
if (c->expr->expr_type == EXPR_CONSTANT)
rc = eval (c->expr, op2, &r);
else
rc = reduce_binary_ac (eval, c->expr, op2, &r);
if (rc != ARITH_OK)
break;
gfc_replace_expr (c->expr, r);
}
if (rc != ARITH_OK)
gfc_free_constructor (head);
else
{
r = gfc_get_expr ();
r->expr_type = EXPR_ARRAY;
r->value.constructor = head;
r->shape = gfc_copy_shape (op1->shape, op1->rank);
r->ts = head->expr->ts;
r->where = op1->where;
r->rank = op1->rank;
*result = r;
}
return rc;
}
static arith
reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
{
gfc_constructor *c, *head;
gfc_expr *r;
arith rc;
head = gfc_copy_constructor (op2->value.constructor);
rc = ARITH_OK;
for (c = head; c; c = c->next)
{
if (c->expr->expr_type == EXPR_CONSTANT)
rc = eval (op1, c->expr, &r);
else
rc = reduce_binary_ca (eval, op1, c->expr, &r);
if (rc != ARITH_OK)
break;
gfc_replace_expr (c->expr, r);
}
if (rc != ARITH_OK)
gfc_free_constructor (head);
else
{
r = gfc_get_expr ();
r->expr_type = EXPR_ARRAY;
r->value.constructor = head;
r->shape = gfc_copy_shape (op2->shape, op2->rank);
r->ts = head->expr->ts;
r->where = op2->where;
r->rank = op2->rank;
*result = r;
}
return rc;
}
static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
gfc_expr *op1, gfc_expr *op2, gfc_expr **result);
static arith
reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
{
gfc_constructor *c, *d, *head;
gfc_expr *r;
arith rc;
head = gfc_copy_constructor (op1->value.constructor);
rc = ARITH_OK;
d = op2->value.constructor;
if (gfc_check_conformance ("elemental binary operation", op1, op2)
!= SUCCESS)
rc = ARITH_INCOMMENSURATE;
else
{
for (c = head; c; c = c->next, d = d->next)
{
if (d == NULL)
{
rc = ARITH_INCOMMENSURATE;
break;
}
rc = reduce_binary (eval, c->expr, d->expr, &r);
if (rc != ARITH_OK)
break;
gfc_replace_expr (c->expr, r);
}
if (d != NULL)
rc = ARITH_INCOMMENSURATE;
}
if (rc != ARITH_OK)
gfc_free_constructor (head);
else
{
r = gfc_get_expr ();
r->expr_type = EXPR_ARRAY;
r->value.constructor = head;
r->shape = gfc_copy_shape (op1->shape, op1->rank);
r->ts = head->expr->ts;
r->where = op1->where;
r->rank = op1->rank;
*result = r;
}
return rc;
}
static arith
reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
{
if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
return eval (op1, op2, result);
if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
return reduce_binary_ca (eval, op1, op2, result);
if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
return reduce_binary_ac (eval, op1, op2, result);
return reduce_binary_aa (eval, op1, op2, result);
}
typedef union
{
arith (*f2)(gfc_expr *, gfc_expr **);
arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
}
eval_f;
static gfc_expr *
eval_intrinsic (gfc_intrinsic_op op,
eval_f eval, gfc_expr *op1, gfc_expr *op2)
{
gfc_expr temp, *result;
int unary;
arith rc;
gfc_clear_ts (&temp.ts);
switch (op)
{
case INTRINSIC_NOT:
if (op1->ts.type != BT_LOGICAL)
goto runtime;
temp.ts.type = BT_LOGICAL;
temp.ts.kind = gfc_default_logical_kind;
unary = 1;
break;
case INTRINSIC_OR:
case INTRINSIC_AND:
case INTRINSIC_NEQV:
case INTRINSIC_EQV:
if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
goto runtime;
temp.ts.type = BT_LOGICAL;
temp.ts.kind = gfc_default_logical_kind;
unary = 0;
break;
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
if (!gfc_numeric_ts (&op1->ts))
goto runtime;
temp.ts = op1->ts;
unary = 1;
break;
case INTRINSIC_PARENTHESES:
temp.ts = op1->ts;
unary = 1;
break;
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
{
temp.ts.type = BT_LOGICAL;
temp.ts.kind = gfc_default_logical_kind;
goto runtime;
}
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
{
unary = 0;
temp.ts.type = BT_LOGICAL;
temp.ts.kind = gfc_default_logical_kind;
if (op1->ts.kind != op2->ts.kind)
goto runtime;
break;
}
case INTRINSIC_PLUS:
case INTRINSIC_MINUS:
case INTRINSIC_TIMES:
case INTRINSIC_DIVIDE:
case INTRINSIC_POWER:
if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
goto runtime;
temp.expr_type = EXPR_OP;
gfc_clear_ts (&temp.ts);
temp.value.op.op = op;
temp.value.op.op1 = op1;
temp.value.op.op2 = op2;
gfc_type_convert_binary (&temp);
if (op == INTRINSIC_EQ || op == INTRINSIC_NE
|| op == INTRINSIC_GE || op == INTRINSIC_GT
|| op == INTRINSIC_LE || op == INTRINSIC_LT
|| op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
|| op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
|| op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
{
temp.ts.type = BT_LOGICAL;
temp.ts.kind = gfc_default_logical_kind;
}
unary = 0;
break;
case INTRINSIC_CONCAT:
if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
|| op1->ts.kind != op2->ts.kind)
goto runtime;
temp.ts.type = BT_CHARACTER;
temp.ts.kind = op1->ts.kind;
unary = 0;
break;
case INTRINSIC_USER:
goto runtime;
default:
gfc_internal_error ("eval_intrinsic(): Bad operator");
}
if (op == INTRINSIC_POWER && op2->ts.type != BT_INTEGER)
goto runtime;
if (op1->expr_type != EXPR_CONSTANT
&& (op1->expr_type != EXPR_ARRAY
|| !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
goto runtime;
if (op2 != NULL
&& op2->expr_type != EXPR_CONSTANT
&& (op2->expr_type != EXPR_ARRAY
|| !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
goto runtime;
if (unary)
rc = reduce_unary (eval.f2, op1, &result);
else
rc = reduce_binary (eval.f3, op1, op2, &result);
if (rc != ARITH_OK)
{ /* Something went wrong. */
gfc_error (gfc_arith_error (rc), &op1->where);
return NULL;
}
gfc_free_expr (op1);
gfc_free_expr (op2);
return result;
runtime:
result = gfc_get_expr ();
result->ts = temp.ts;
result->expr_type = EXPR_OP;
result->value.op.op = op;
result->value.op.op1 = op1;
result->value.op.op2 = op2;
result->where = op1->where;
return result;
}
static gfc_expr *
eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
{
if (op == NULL)
gfc_internal_error ("eval_type_intrinsic0(): op NULL");
switch (iop)
{
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
op->ts.type = BT_LOGICAL;
op->ts.kind = gfc_default_logical_kind;
break;
default:
break;
}
return op;
}
static int
gfc_zero_size_array (gfc_expr *e)
{
if (e->expr_type != EXPR_ARRAY)
return 0;
return e->value.constructor == NULL;
}
static gfc_expr *
reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
{
if (gfc_zero_size_array (op1))
{
gfc_free_expr (op2);
return op1;
}
if (gfc_zero_size_array (op2))
{
gfc_free_expr (op1);
return op2;
}
return NULL;
}
static gfc_expr *
eval_intrinsic_f2 (gfc_intrinsic_op op,
arith (*eval) (gfc_expr *, gfc_expr **),
gfc_expr *op1, gfc_expr *op2)
{
gfc_expr *result;
eval_f f;
if (op2 == NULL)
{
if (gfc_zero_size_array (op1))
return eval_type_intrinsic0 (op, op1);
}
else
{
result = reduce_binary0 (op1, op2);
if (result != NULL)
return eval_type_intrinsic0 (op, result);
}
f.f2 = eval;
return eval_intrinsic (op, f, op1, op2);
}
static gfc_expr *
eval_intrinsic_f3 (gfc_intrinsic_op op,
arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
gfc_expr *op1, gfc_expr *op2)
{
gfc_expr *result;
eval_f f;
result = reduce_binary0 (op1, op2);
if (result != NULL)
return eval_type_intrinsic0(op, result);
f.f3 = eval;
return eval_intrinsic (op, f, op1, op2);
}
gfc_expr *
gfc_parentheses (gfc_expr *op)
{
if (gfc_is_constant_expr (op))
return op;
return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
op, NULL);
}
gfc_expr *
gfc_uplus (gfc_expr *op)
{
return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
}
gfc_expr *
gfc_uminus (gfc_expr *op)
{
return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
}
gfc_expr *
gfc_add (gfc_expr *op1, gfc_expr *op2)
{
return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
}
gfc_expr *
gfc_subtract (gfc_expr *op1, gfc_expr *op2)
{
return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
}
gfc_expr *
gfc_multiply (gfc_expr *op1, gfc_expr *op2)
{
return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
}
gfc_expr *
gfc_divide (gfc_expr *op1, gfc_expr *op2)
{
return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
}
gfc_expr *
gfc_power (gfc_expr *op1, gfc_expr *op2)
{
return eval_intrinsic_f3 (INTRINSIC_POWER, gfc_arith_power, op1, op2);
}
gfc_expr *
gfc_concat (gfc_expr *op1, gfc_expr *op2)
{
return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
}
gfc_expr *
gfc_and (gfc_expr *op1, gfc_expr *op2)
{
return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
}
gfc_expr *
gfc_or (gfc_expr *op1, gfc_expr *op2)
{
return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
}
gfc_expr *
gfc_not (gfc_expr *op1)
{
return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
}
gfc_expr *
gfc_eqv (gfc_expr *op1, gfc_expr *op2)
{
return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
}
gfc_expr *
gfc_neqv (gfc_expr *op1, gfc_expr *op2)
{
return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
}
gfc_expr *
gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
}
gfc_expr *
gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
}
gfc_expr *
gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
}
gfc_expr *
gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
}
gfc_expr *
gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
}
gfc_expr *
gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
}
gfc_expr *
gfc_convert_integer (const char *buffer, int kind, int radix, locus *where)
{
gfc_expr *e;
const char *t;
e = gfc_constant_result (BT_INTEGER, kind, where);
if (buffer[0] == '+')
t = buffer + 1;
else
t = buffer;
mpz_set_str (e->value.integer, t, radix);
return e;
}
gfc_expr *
gfc_convert_real (const char *buffer, int kind, locus *where)
{
gfc_expr *e;
e = gfc_constant_result (BT_REAL, kind, where);
mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
return e;
}
gfc_expr *
gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
{
gfc_expr *e;
e = gfc_constant_result (BT_COMPLEX, kind, &real->where);
mpfr_set (e->value.complex.r, real->value.real, GFC_RND_MODE);
mpfr_set (e->value.complex.i, imag->value.real, GFC_RND_MODE);
return e;
}
static void
arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
{
switch (rc)
{
case ARITH_OK:
gfc_error ("Arithmetic OK converting %s to %s at %L",
gfc_typename (from), gfc_typename (to), where);
break;
case ARITH_OVERFLOW:
gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
"can be disabled with the option -fno-range-check",
gfc_typename (from), gfc_typename (to), where);
break;
case ARITH_UNDERFLOW:
gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
"can be disabled with the option -fno-range-check",
gfc_typename (from), gfc_typename (to), where);
break;
case ARITH_NAN:
gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
"can be disabled with the option -fno-range-check",
gfc_typename (from), gfc_typename (to), where);
break;
case ARITH_DIV0:
gfc_error ("Division by zero converting %s to %s at %L",
gfc_typename (from), gfc_typename (to), where);
break;
case ARITH_INCOMMENSURATE:
gfc_error ("Array operands are incommensurate converting %s to %s at %L",
gfc_typename (from), gfc_typename (to), where);
break;
case ARITH_ASYMMETRIC:
gfc_error ("Integer outside symmetric range implied by Standard Fortran"
" converting %s to %s at %L",
gfc_typename (from), gfc_typename (to), where);
break;
default:
gfc_internal_error ("gfc_arith_error(): Bad error code");
}
}
gfc_expr *
gfc_int2int (gfc_expr *src, int kind)
{
gfc_expr *result;
arith rc;
result = gfc_constant_result (BT_INTEGER, kind, &src->where);
mpz_set (result->value.integer, src->value.integer);
if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
{
if (rc == ARITH_ASYMMETRIC)
{
gfc_warning (gfc_arith_error (rc), &src->where);
}
else
{
arith_error (rc, &src->ts, &result->ts, &src->where);
gfc_free_expr (result);
return NULL;
}
}
return result;
}
gfc_expr *
gfc_int2real (gfc_expr *src, int kind)
{
gfc_expr *result;
arith rc;
result = gfc_constant_result (BT_REAL, kind, &src->where);
mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
{
arith_error (rc, &src->ts, &result->ts, &src->where);
gfc_free_expr (result);
return NULL;
}
return result;
}
gfc_expr *
gfc_int2complex (gfc_expr *src, int kind)
{
gfc_expr *result;
arith rc;
result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
mpfr_set_z (result->value.complex.r, src->value.integer, GFC_RND_MODE);
mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
if ((rc = gfc_check_real_range (result->value.complex.r, kind)) != ARITH_OK)
{
arith_error (rc, &src->ts, &result->ts, &src->where);
gfc_free_expr (result);
return NULL;
}
return result;
}
gfc_expr *
gfc_real2int (gfc_expr *src, int kind)
{
gfc_expr *result;
arith rc;
result = gfc_constant_result (BT_INTEGER, kind, &src->where);
gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
{
arith_error (rc, &src->ts, &result->ts, &src->where);
gfc_free_expr (result);
return NULL;
}
return result;
}
gfc_expr *
gfc_real2real (gfc_expr *src, int kind)
{
gfc_expr *result;
arith rc;
result = gfc_constant_result (BT_REAL, kind, &src->where);
mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
rc = gfc_check_real_range (result->value.real, kind);
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
gfc_warning (gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
{
arith_error (rc, &src->ts, &result->ts, &src->where);
gfc_free_expr (result);
return NULL;
}
return result;
}
gfc_expr *
gfc_real2complex (gfc_expr *src, int kind)
{
gfc_expr *result;
arith rc;
result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
mpfr_set (result->value.complex.r, src->value.real, GFC_RND_MODE);
mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
rc = gfc_check_real_range (result->value.complex.r, kind);
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
gfc_warning (gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
{
arith_error (rc, &src->ts, &result->ts, &src->where);
gfc_free_expr (result);
return NULL;
}
return result;
}
gfc_expr *
gfc_complex2int (gfc_expr *src, int kind)
{
gfc_expr *result;
arith rc;
result = gfc_constant_result (BT_INTEGER, kind, &src->where);
gfc_mpfr_to_mpz (result->value.integer, src->value.complex.r, &src->where);
if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
{
arith_error (rc, &src->ts, &result->ts, &src->where);
gfc_free_expr (result);
return NULL;
}
return result;
}
gfc_expr *
gfc_complex2real (gfc_expr *src, int kind)
{
gfc_expr *result;
arith rc;
result = gfc_constant_result (BT_REAL, kind, &src->where);
mpfr_set (result->value.real, src->value.complex.r, GFC_RND_MODE);
rc = gfc_check_real_range (result->value.real, kind);
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
gfc_warning (gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
}
if (rc != ARITH_OK)
{
arith_error (rc, &src->ts, &result->ts, &src->where);
gfc_free_expr (result);
return NULL;
}
return result;
}
gfc_expr *
gfc_complex2complex (gfc_expr *src, int kind)
{
gfc_expr *result;
arith rc;
result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
mpfr_set (result->value.complex.r, src->value.complex.r, GFC_RND_MODE);
mpfr_set (result->value.complex.i, src->value.complex.i, GFC_RND_MODE);
rc = gfc_check_real_range (result->value.complex.r, kind);
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
gfc_warning (gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
{
arith_error (rc, &src->ts, &result->ts, &src->where);
gfc_free_expr (result);
return NULL;
}
rc = gfc_check_real_range (result->value.complex.i, kind);
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
gfc_warning (gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
{
arith_error (rc, &src->ts, &result->ts, &src->where);
gfc_free_expr (result);
return NULL;
}
return result;
}
gfc_expr *
gfc_log2log (gfc_expr *src, int kind)
{
gfc_expr *result;
result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
result->value.logical = src->value.logical;
return result;
}
gfc_expr *
gfc_log2int (gfc_expr *src, int kind)
{
gfc_expr *result;
result = gfc_constant_result (BT_INTEGER, kind, &src->where);
mpz_set_si (result->value.integer, src->value.logical);
return result;
}
gfc_expr *
gfc_int2log (gfc_expr *src, int kind)
{
gfc_expr *result;
result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
return result;
}
static void
hollerith2representation (gfc_expr *result, gfc_expr *src)
{
int src_len, result_len;
src_len = src->representation.length;
result_len = gfc_target_expr_size (result);
if (src_len > result_len)
{
gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
&src->where, gfc_typename(&result->ts));
}
result->representation.string = XCNEWVEC (char, result_len + 1);
memcpy (result->representation.string, src->representation.string,
MIN (result_len, src_len));
if (src_len < result_len)
memset (&result->representation.string[src_len], ' ', result_len - src_len);
result->representation.string[result_len] = '\0'; /* For debugger */
result->representation.length = result_len;
}
gfc_expr *
gfc_hollerith2int (gfc_expr *src, int kind)
{
gfc_expr *result;
result = gfc_get_expr ();
result->expr_type = EXPR_CONSTANT;
result->ts.type = BT_INTEGER;
result->ts.kind = kind;
result->where = src->where;
hollerith2representation (result, src);
gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
result->representation.length, result->value.integer);
return result;
}
gfc_expr *
gfc_hollerith2real (gfc_expr *src, int kind)
{
gfc_expr *result;
int len;
len = src->value.character.length;
result = gfc_get_expr ();
result->expr_type = EXPR_CONSTANT;
result->ts.type = BT_REAL;
result->ts.kind = kind;
result->where = src->where;
hollerith2representation (result, src);
gfc_interpret_float (kind, (unsigned char *) result->representation.string,
result->representation.length, result->value.real);
return result;
}
gfc_expr *
gfc_hollerith2complex (gfc_expr *src, int kind)
{
gfc_expr *result;
int len;
len = src->value.character.length;
result = gfc_get_expr ();
result->expr_type = EXPR_CONSTANT;
result->ts.type = BT_COMPLEX;
result->ts.kind = kind;
result->where = src->where;
hollerith2representation (result, src);
gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
result->representation.length, result->value.complex.r,
result->value.complex.i);
return result;
}
gfc_expr *
gfc_hollerith2character (gfc_expr *src, int kind)
{
gfc_expr *result;
result = gfc_copy_expr (src);
result->ts.type = BT_CHARACTER;
result->ts.kind = kind;
result->value.character.length = result->representation.length;
result->value.character.string
= gfc_char_to_widechar (result->representation.string);
return result;
}
gfc_expr *
gfc_hollerith2logical (gfc_expr *src, int kind)
{
gfc_expr *result;
int len;
len = src->value.character.length;
result = gfc_get_expr ();
result->expr_type = EXPR_CONSTANT;
result->ts.type = BT_LOGICAL;
result->ts.kind = kind;
result->where = src->where;
hollerith2representation (result, src);
gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
result->representation.length, &result->value.logical);
return result;
}
gfc_expr *
gfc_enum_initializer (gfc_expr *last_initializer, locus where)
{
gfc_expr *result;
result = gfc_get_expr ();
result->expr_type = EXPR_CONSTANT;
result->ts.type = BT_INTEGER;
result->ts.kind = gfc_c_int_kind;
result->where = where;
mpz_init (result->value.integer);
if (last_initializer != NULL)
{
mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
result->where = last_initializer->where;
if (gfc_check_integer_range (result->value.integer,
gfc_c_int_kind) != ARITH_OK)
{
gfc_error ("Enumerator exceeds the C integer type at %C");
return NULL;
}
}
else
{
mpz_set_si (result->value.integer, 0);
}
return result;
}
