/* Compiler arithmetic
- Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
Inc.
Contributed by Andy Vaught
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
/* Since target arithmetic must be done on the host, there has to
be some way of evaluating arithmetic expressions as the host
and this file provides the interface. */
#include "config.h"
-
-#include <string.h>
-
+#include "system.h"
+#include "flags.h"
#include "gfortran.h"
#include "arith.h"
-/* The gfc_(integer|real)_kinds[] structures have everything the front
- end needs to know about integers and real numbers on the target.
- Other entries of the structure are calculated from these values.
- The first entry is the default kind, the second entry of the real
- structure is the default double kind. */
-
-#define MPZ_NULL {{0,0,0}}
-#define MPF_NULL {{0,0,0,0}}
-
-#define DEF_GFC_INTEGER_KIND(KIND,RADIX,DIGITS,BIT_SIZE) \
- {KIND, RADIX, DIGITS, BIT_SIZE, 0, MPZ_NULL, MPZ_NULL, MPZ_NULL}
-
-#define DEF_GFC_LOGICAL_KIND(KIND,BIT_SIZE) \
- {KIND, BIT_SIZE}
-
-#define DEF_GFC_REAL_KIND(KIND,RADIX,DIGITS,MIN_EXP, MAX_EXP) \
- {KIND, RADIX, DIGITS, MIN_EXP, MAX_EXP, \
- 0, 0, MPF_NULL, MPF_NULL, MPF_NULL}
-
-gfc_integer_info gfc_integer_kinds[] = {
- DEF_GFC_INTEGER_KIND (4, 2, 31, 32),
- DEF_GFC_INTEGER_KIND (8, 2, 63, 64),
- DEF_GFC_INTEGER_KIND (2, 2, 15, 16),
- DEF_GFC_INTEGER_KIND (1, 2, 7, 8),
- DEF_GFC_INTEGER_KIND (0, 0, 0, 0)
-};
-
-gfc_logical_info gfc_logical_kinds[] = {
- DEF_GFC_LOGICAL_KIND (4, 32),
- DEF_GFC_LOGICAL_KIND (8, 64),
- DEF_GFC_LOGICAL_KIND (2, 16),
- DEF_GFC_LOGICAL_KIND (1, 8),
- DEF_GFC_LOGICAL_KIND (0, 0)
-};
-
-
-/* IEEE-754 uses 1.xEe representation whereas the fortran standard
- uses 0.xEe representation. Hence the exponents below are biased
- by one. */
-
-#define GFC_SP_KIND 4
-#define GFC_SP_PREC 24 /* p = 24, IEEE-754 */
-#define GFC_SP_EMIN -125 /* emin = -126, IEEE-754 */
-#define GFC_SP_EMAX 128 /* emin = 127, IEEE-754 */
-
-/* Double precision model numbers. */
-#define GFC_DP_KIND 8
-#define GFC_DP_PREC 53 /* p = 53, IEEE-754 */
-#define GFC_DP_EMIN -1021 /* emin = -1022, IEEE-754 */
-#define GFC_DP_EMAX 1024 /* emin = 1023, IEEE-754 */
-
-/* Quad precision model numbers. Not used. */
-#define GFC_QP_KIND 16
-#define GFC_QP_PREC 113 /* p = 113, IEEE-754 */
-#define GFC_QP_EMIN -16381 /* emin = -16382, IEEE-754 */
-#define GFC_QP_EMAX 16384 /* emin = 16383, IEEE-754 */
-
-gfc_real_info gfc_real_kinds[] = {
- DEF_GFC_REAL_KIND (GFC_SP_KIND, 2, GFC_SP_PREC, GFC_SP_EMIN, GFC_SP_EMAX),
- DEF_GFC_REAL_KIND (GFC_DP_KIND, 2, GFC_DP_PREC, GFC_DP_EMIN, GFC_DP_EMAX),
- DEF_GFC_REAL_KIND (0, 0, 0, 0, 0)
-};
-
-
-/* The integer kind to use for array indices. This will be set to the
- proper value based on target information from the backend. */
-
-int gfc_index_integer_kind;
-
-
/* MPFR does not have a direct replacement for mpz_set_f() from GMP.
It's easily implemented with a few calls though. */
void
gfc_set_model_kind (int kind)
{
- switch (kind)
- {
- case GFC_SP_KIND:
- mpfr_set_default_prec (GFC_SP_PREC);
- break;
- case GFC_DP_KIND:
- mpfr_set_default_prec (GFC_DP_PREC);
- break;
- case GFC_QP_KIND:
- mpfr_set_default_prec (GFC_QP_PREC);
- break;
- default:
- gfc_internal_error ("gfc_set_model_kind(): Bad model number");
- }
+ 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)
{
- switch (mpfr_get_prec (x))
- {
- case GFC_SP_PREC:
- mpfr_set_default_prec (GFC_SP_PREC);
- break;
- case GFC_DP_PREC:
- mpfr_set_default_prec (GFC_DP_PREC);
- break;
- case GFC_QP_PREC:
- mpfr_set_default_prec (GFC_QP_PREC);
- break;
- default:
- gfc_internal_error ("gfc_set_model(): Bad model number");
- }
+ mpfr_set_default_prec (mpfr_get_prec (x));
}
/* Calculate atan2 (y, x)
gfc_set_model (y);
mpfr_init (t);
- i = mpfr_sgn(x);
+ i = mpfr_sgn (x);
if (i > 0)
{
if (mpfr_sgn (y) < 0)
mpfr_neg (result, result, GFC_RND_MODE);
}
- else
- {
+ else
+ {
if (mpfr_sgn (y) == 0)
mpfr_set_ui (result, 0, GFC_RND_MODE);
else
switch (code)
{
case ARITH_OK:
- p = "Arithmetic OK";
+ p = _("Arithmetic OK at %L");
break;
case ARITH_OVERFLOW:
- p = "Arithmetic overflow";
+ p = _("Arithmetic overflow at %L");
break;
case ARITH_UNDERFLOW:
- p = "Arithmetic underflow";
+ p = _("Arithmetic underflow at %L");
break;
case ARITH_NAN:
- p = "Arithmetic NaN";
+ p = _("Arithmetic NaN at %L");
break;
case ARITH_DIV0:
- p = "Division by zero";
- break;
- case ARITH_0TO0:
- p = "Indeterminate form 0 ** 0";
+ p = _("Division by zero at %L");
break;
case ARITH_INCOMMENSURATE:
- p = "Array operands are 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");
mpz_t r;
int i;
- gfc_set_model_kind (GFC_QP_KIND);
-
+ mpfr_set_default_prec (128);
mpfr_init (a);
mpz_init (r);
/* These are the numbers that are actually representable by the
target. For bases other than two, this needs to be changed. */
if (int_info->radix != 2)
- gfc_internal_error ("Fix min_int, max_int calculation");
+ gfc_internal_error ("Fix min_int, max_int calculation");
+
+ /* See PRs 13490 and 17912, related to integer ranges.
+ The pedantic_min_int exists for range checking when a program
+ is compiled with -pedantic, and reflects the belief that
+ Standard Fortran requires integers to be symmetrical, i.e.
+ every negative integer must have a representable positive
+ absolute value, and vice versa. */
+
+ mpz_init (int_info->pedantic_min_int);
+ mpz_neg (int_info->pedantic_min_int, int_info->huge);
mpz_init (int_info->min_int);
- mpz_neg (int_info->min_int, int_info->huge);
- /* No -1 here, because the representation is symmetric. */
+ mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);
mpz_init (int_info->max_int);
mpz_add (int_info->max_int, int_info->huge, int_info->huge);
mpfr_init (real_info->tiny);
mpfr_set (real_info->tiny, b, GFC_RND_MODE);
+ /* subnormal (x) = b**(emin - digit) */
+ mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
+ mpfr_pow_si (b, b, real_info->min_exponent - real_info->digits,
+ GFC_RND_MODE);
+
+ mpfr_init (real_info->subnormal);
+ mpfr_set (real_info->subnormal, b, GFC_RND_MODE);
+
/* epsilon(x) = b**(1-p) */
mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
mpfr_pow_si (b, b, 1 - real_info->digits, GFC_RND_MODE);
}
-/* Return default kinds. */
-
-int
-gfc_default_integer_kind (void)
-{
- return gfc_integer_kinds[gfc_option.i8 ? 1 : 0].kind;
-}
-
-int
-gfc_default_real_kind (void)
-{
- return gfc_real_kinds[gfc_option.r8 ? 1 : 0].kind;
-}
-
-int
-gfc_default_double_kind (void)
-{
- return gfc_real_kinds[1].kind;
-}
-
-int
-gfc_default_character_kind (void)
-{
- return 1;
-}
-
-int
-gfc_default_logical_kind (void)
-{
- return gfc_logical_kinds[gfc_option.i8 ? 1 : 0].kind;
-}
-
-int
-gfc_default_complex_kind (void)
-{
- return gfc_default_real_kind ();
-}
-
-
-/* Make sure that a valid kind is present. Returns an index into the
- gfc_integer_kinds array, -1 if the kind is not present. */
-
-static int
-validate_integer (int kind)
-{
- int i;
-
- for (i = 0;; i++)
- {
- if (gfc_integer_kinds[i].kind == 0)
- {
- i = -1;
- break;
- }
- if (gfc_integer_kinds[i].kind == kind)
- break;
- }
-
- return i;
-}
-
-
-static int
-validate_real (int kind)
-{
- int i;
-
- for (i = 0;; i++)
- {
- if (gfc_real_kinds[i].kind == 0)
- {
- i = -1;
- break;
- }
- if (gfc_real_kinds[i].kind == kind)
- break;
- }
-
- return i;
-}
-
-
-static int
-validate_logical (int kind)
-{
- int i;
-
- for (i = 0;; i++)
- {
- if (gfc_logical_kinds[i].kind == 0)
- {
- i = -1;
- break;
- }
- if (gfc_logical_kinds[i].kind == kind)
- break;
- }
-
- return i;
-}
-
-
-static int
-validate_character (int kind)
-{
-
- if (kind == gfc_default_character_kind ())
- return 0;
- return -1;
-}
-
-
-/* Validate a kind given a basic type. The return value is the same
- for the child functions, with -1 indicating nonexistence of the
- type. */
-
-int
-gfc_validate_kind (bt type, int kind, bool may_fail)
-{
- int rc;
-
- switch (type)
- {
- case BT_REAL: /* Fall through */
- case BT_COMPLEX:
- rc = validate_real (kind);
- break;
- case BT_INTEGER:
- rc = validate_integer (kind);
- break;
- case BT_LOGICAL:
- rc = validate_logical (kind);
- break;
- case BT_CHARACTER:
- rc = validate_character (kind);
- break;
-
- default:
- gfc_internal_error ("gfc_validate_kind(): Got bad type");
- }
-
- if (!may_fail && rc < 0)
- gfc_internal_error ("gfc_validate_kind(): Got bad kind");
-
- return rc;
-}
-
-
/* Given an integer and a kind, make sure that the integer lies within
- the range of the kind. Returns ARITH_OK or ARITH_OVERFLOW. */
+ the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or
+ ARITH_OVERFLOW. */
static arith
gfc_check_integer_range (mpz_t p, int kind)
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 (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
|| mpz_cmp (p, gfc_integer_kinds[i].max_int) > 0)
result = ARITH_OVERFLOW;
mpfr_init (q);
mpfr_abs (q, p, GFC_RND_MODE);
- retval = ARITH_OK;
if (mpfr_sgn (q) == 0)
- goto done;
-
- if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
+ retval = ARITH_OK;
+ else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
+ retval = ARITH_OVERFLOW;
+ else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
+ retval = ARITH_UNDERFLOW;
+ else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
{
- retval = ARITH_OVERFLOW;
- goto done;
- }
+ /* MPFR operates on a numbers with a given precision and enormous
+ exponential range. To represent subnormal numbers the exponent is
+ allowed to become smaller than emin, but always retains the full
+ precision. This function resets unused bits to 0 to alleviate
+ rounding problems. Note, a future version of MPFR will have a
+ mpfr_subnormalize() function, which handles this truncation in a
+ more efficient and robust way. */
+
+ int j, k;
+ char *bin, *s;
+ mp_exp_t e;
+
+ bin = mpfr_get_str (NULL, &e, gfc_real_kinds[i].radix, 0, q, GMP_RNDN);
+ k = gfc_real_kinds[i].digits - (gfc_real_kinds[i].min_exponent - e);
+ for (j = k; j < gfc_real_kinds[i].digits; j++)
+ bin[j] = '0';
+ /* Need space for '0.', bin, 'E', and e */
+ s = (char *) gfc_getmem (strlen(bin)+10);
+ sprintf (s, "0.%sE%d", bin, (int) e);
+ mpfr_set_str (q, s, gfc_real_kinds[i].radix, GMP_RNDN);
+
+ if (mpfr_sgn (p) < 0)
+ mpfr_neg (p, q, GMP_RNDN);
+ else
+ mpfr_set (p, q, GMP_RNDN);
- if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
- retval = ARITH_UNDERFLOW;
+ gfc_free (s);
+ gfc_free (bin);
+
+ retval = ARITH_OK;
+ }
+ else
+ retval = ARITH_OK;
-done:
mpfr_clear (q);
return retval;
}
+/* Several of the following routines use the same set of statements to
+ check the validity of the result. Encapsulate the checking here. */
+
+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;
+}
+
+
/* It may seem silly to have a subroutine that actually computes the
unary plus of a constant, but it prevents us from making exceptions
in the code elsewhere. */
static arith
gfc_arith_uplus (gfc_expr * op1, gfc_expr ** resultp)
{
-
*resultp = gfc_copy_expr (op1);
return ARITH_OK;
}
rc = gfc_range_check (result);
- if (rc == ARITH_UNDERFLOW)
- {
- if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &op1->where);
- rc = ARITH_OK;
- *resultp = result;
- }
- else if (rc != ARITH_OK)
- gfc_free_expr (result);
- else
- *resultp = result;
-
- return rc;
+ return check_result (rc, op1, result, resultp);
}
rc = gfc_range_check (result);
- if (rc == ARITH_UNDERFLOW)
- {
- if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &op1->where);
- rc = ARITH_OK;
- *resultp = result;
- }
- else if (rc != ARITH_OK)
- gfc_free_expr (result);
- else
- *resultp = result;
-
- return rc;
+ return check_result (rc, op1, result, resultp);
}
rc = gfc_range_check (result);
- if (rc == ARITH_UNDERFLOW)
- {
- if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &op1->where);
- rc = ARITH_OK;
- *resultp = result;
- }
- else if (rc != ARITH_OK)
- gfc_free_expr (result);
- else
- *resultp = result;
-
- return rc;
+ return check_result (rc, op1, result, resultp);
}
rc = gfc_range_check (result);
- if (rc == ARITH_UNDERFLOW)
- {
- if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &op1->where);
- rc = ARITH_OK;
- *resultp = result;
- }
- else if (rc != ARITH_OK)
- gfc_free_expr (result);
- else
- *resultp = result;
-
- return rc;
+ return check_result (rc, op1, result, resultp);
}
if (rc == ARITH_OK)
rc = gfc_range_check (result);
- if (rc == ARITH_UNDERFLOW)
- {
- if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &op1->where);
- rc = ARITH_OK;
- *resultp = result;
- }
- else if (rc != ARITH_OK)
- gfc_free_expr (result);
- else
- *resultp = result;
-
- return rc;
+ return check_result (rc, op1, result, resultp);
}
result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
if (power == 0)
- { /* Handle something to the zeroth power */
+ {
+ /* Handle something to the zeroth power. Since we're dealing
+ with integral exponents, there is no ambiguity in the
+ limiting procedure used to determine the value of 0**0. */
switch (op1->ts.type)
{
case BT_INTEGER:
- if (mpz_sgn (op1->value.integer) == 0)
- rc = ARITH_0TO0;
- else
- mpz_set_ui (result->value.integer, 1);
+ mpz_set_ui (result->value.integer, 1);
break;
case BT_REAL:
- if (mpfr_sgn (op1->value.real) == 0)
- rc = ARITH_0TO0;
- else
- mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
+ mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
break;
case BT_COMPLEX:
- if (mpfr_sgn (op1->value.complex.r) == 0
- && mpfr_sgn (op1->value.complex.i) == 0)
- rc = ARITH_0TO0;
- else
- {
- mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE);
- mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
- }
-
+ mpfr_set_ui (result->value.complex.r, 1, GFC_RND_MODE);
+ mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
break;
default:
if (rc == ARITH_OK)
rc = gfc_range_check (result);
- if (rc == ARITH_UNDERFLOW)
- {
- if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &op1->where);
- rc = ARITH_OK;
- *resultp = result;
- }
- else if (rc != ARITH_OK)
- gfc_free_expr (result);
- else
- *resultp = result;
-
- return rc;
+ return check_result (rc, op1, result, resultp);
}
gfc_expr *result;
int len;
- result = gfc_constant_result (BT_CHARACTER, gfc_default_character_kind (),
+ result = gfc_constant_result (BT_CHARACTER, gfc_default_character_kind,
&op1->where);
len = op1->value.character.length + op2->value.character.length;
static int
compare_complex (gfc_expr * op1, gfc_expr * op2)
{
-
return (mpfr_cmp (op1->value.complex.r, op2->value.complex.r) == 0
&& mpfr_cmp (op1->value.complex.i, op2->value.complex.i) == 0);
}
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind (),
+ 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) == 0);
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind (),
+ 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) != 0);
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind (),
+ result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where);
result->value.logical = (gfc_compare_expr (op1, op2) > 0);
*resultp = result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind (),
+ result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where);
result->value.logical = (gfc_compare_expr (op1, op2) >= 0);
*resultp = result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind (),
+ result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where);
result->value.logical = (gfc_compare_expr (op1, op2) < 0);
*resultp = result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind (),
+ result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where);
result->value.logical = (gfc_compare_expr (op1, op2) <= 0);
*resultp = result;
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);
goto runtime;
temp.ts.type = BT_LOGICAL;
- temp.ts.kind = gfc_default_logical_kind ();
+ temp.ts.kind = gfc_default_logical_kind;
unary = 1;
break;
goto runtime;
temp.ts.type = BT_LOGICAL;
- temp.ts.kind = gfc_default_logical_kind ();
+ temp.ts.kind = gfc_default_logical_kind;
unary = 0;
break;
if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
{
temp.ts.type = BT_LOGICAL;
- temp.ts.kind = gfc_default_logical_kind();
+ temp.ts.kind = gfc_default_logical_kind;
goto runtime;
}
{
unary = 0;
temp.ts.type = BT_LOGICAL;
- temp.ts.kind = gfc_default_logical_kind();
+ temp.ts.kind = gfc_default_logical_kind;
break;
}
temp.expr_type = EXPR_OP;
gfc_clear_ts (&temp.ts);
- temp.operator = operator;
+ temp.value.op.operator = operator;
- temp.op1 = op1;
- temp.op2 = op2;
+ temp.value.op.op1 = op1;
+ temp.value.op.op2 = op2;
gfc_type_convert_binary (&temp);
|| operator == INTRINSIC_LE || operator == INTRINSIC_LT)
{
temp.ts.type = BT_LOGICAL;
- temp.ts.kind = gfc_default_logical_kind ();
+ temp.ts.kind = gfc_default_logical_kind;
}
unary = 0;
goto runtime;
temp.ts.type = BT_CHARACTER;
- temp.ts.kind = gfc_default_character_kind ();
+ temp.ts.kind = gfc_default_character_kind;
unary = 0;
break;
if (operator == 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)))
+ if (op1->from_H
+ || (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)))
+ && (op2->from_H
+ || (op2->expr_type != EXPR_CONSTANT
+ && (op2->expr_type != EXPR_ARRAY
+ || !gfc_is_constant_expr (op2)
+ || !gfc_expanded_ac (op2)))))
goto runtime;
if (unary)
if (rc != ARITH_OK)
{ /* Something went wrong */
- gfc_error ("%s at %L", gfc_arith_error (rc), &op1->where);
+ gfc_error (gfc_arith_error (rc), &op1->where);
return NULL;
}
result->ts = temp.ts;
result->expr_type = EXPR_OP;
- result->operator = operator;
+ result->value.op.operator = operator;
- result->op1 = op1;
- result->op2 = op2;
+ result->value.op.op1 = op1;
+ result->value.op.op2 = op2;
result->where = op1->where;
eval_type_intrinsic0 (gfc_intrinsic_op operator, gfc_expr *op)
{
if (op == NULL)
- gfc_internal_error("eval_type_intrinsic0(): op NULL");
+ gfc_internal_error ("eval_type_intrinsic0(): op NULL");
- switch(operator)
+ switch (operator)
{
case INTRINSIC_GE:
case INTRINSIC_LT:
case INTRINSIC_EQ:
case INTRINSIC_NE:
op->ts.type = BT_LOGICAL;
- op->ts.kind = gfc_default_logical_kind();
+ op->ts.kind = gfc_default_logical_kind;
break;
default:
static int
gfc_zero_size_array (gfc_expr * e)
{
-
if (e->expr_type != EXPR_ARRAY)
return 0;
static gfc_expr *
reduce_binary0 (gfc_expr * op1, gfc_expr * op2)
{
-
if (gfc_zero_size_array (op1))
{
gfc_free_expr (op2);
if (op2 == NULL)
{
if (gfc_zero_size_array (op1))
- return eval_type_intrinsic0(operator, op1);
+ return eval_type_intrinsic0 (operator, op1);
}
else
{
result = reduce_binary0 (op1, op2);
if (result != NULL)
- return eval_type_intrinsic0(operator, result);
+ return eval_type_intrinsic0 (operator, result);
}
f.f2 = eval;
gfc_convert_real (const char *buffer, int kind, locus * where)
{
gfc_expr *e;
- const char *t;
e = gfc_constant_result (BT_REAL, kind, where);
- /* A leading plus is allowed in Fortran, but not by mpfr_set_str */
- if (buffer[0] == '+')
- t = buffer + 1;
- else
- t = buffer;
- mpfr_set_str (e->value.real, t, 10, GFC_RND_MODE);
+ mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
return e;
}
static void
arith_error (arith rc, gfc_typespec * from, gfc_typespec * to, locus * where)
{
-
- gfc_error ("%s converting %s to %s at %L", gfc_arith_error (rc),
- gfc_typename (from), gfc_typename (to), 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",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ case ARITH_UNDERFLOW:
+ gfc_error ("Arithmetic underflow converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ case ARITH_NAN:
+ gfc_error ("Arithmetic NaN converting %s to %s at %L",
+ 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");
+ }
/* TODO: Do something about the error, ie, throw exception, return
NaN, etc. */
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;
+ 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;
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
- mpfr_set_ui(result->value.real, 0, GFC_RND_MODE);
+ gfc_warning (gfc_arith_error (rc), &src->where);
+ mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
{
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
- mpfr_set_ui(result->value.complex.r, 0, GFC_RND_MODE);
+ gfc_warning (gfc_arith_error (rc), &src->where);
+ mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
{
result = gfc_constant_result (BT_INTEGER, kind, &src->where);
- gfc_mpfr_to_mpz(result->value.integer, src->value.complex.r);
+ gfc_mpfr_to_mpz (result->value.integer, src->value.complex.r);
if ((rc = gfc_check_integer_range (result->value.integer, kind))
!= ARITH_OK)
rc = gfc_check_real_range (result->value.real, kind);
- if (rc == ARITH_UNDERFLOW)
+ if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
- mpfr_set_ui(result->value.real, 0, GFC_RND_MODE);
+ gfc_warning (gfc_arith_error (rc), &src->where);
+ mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
}
if (rc != ARITH_OK)
{
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
- mpfr_set_ui(result->value.complex.r, 0, GFC_RND_MODE);
+ gfc_warning (gfc_arith_error (rc), &src->where);
+ mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
{
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 ("%s at %L", gfc_arith_error (rc), &src->where);
- mpfr_set_ui(result->value.complex.i, 0, GFC_RND_MODE);
+ gfc_warning (gfc_arith_error (rc), &src->where);
+ mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
{
return result;
}
+
+/* Convert logical to integer. */
+
+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;
+}
+
+/* Convert integer to logical. */
+
+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;
+}
+
+/* Convert Hollerith to integer. The constant will be padded or truncated. */
+
+gfc_expr *
+gfc_hollerith2int (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_INTEGER;
+ result->ts.kind = kind;
+ result->where = src->where;
+ result->from_H = 1;
+
+ if (len > kind)
+ {
+ gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+ &src->where, gfc_typename(&result->ts));
+ }
+ result->value.character.string = gfc_getmem (kind + 1);
+ memcpy (result->value.character.string, src->value.character.string,
+ MIN (kind, len));
+
+ if (len < kind)
+ memset (&result->value.character.string[len], ' ', kind - len);
+
+ result->value.character.string[kind] = '\0'; /* For debugger */
+ result->value.character.length = kind;
+
+ return result;
+}
+
+/* Convert Hollerith to real. The constant will be padded or truncated. */
+
+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;
+ result->from_H = 1;
+
+ if (len > kind)
+ {
+ gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+ &src->where, gfc_typename(&result->ts));
+ }
+ result->value.character.string = gfc_getmem (kind + 1);
+ memcpy (result->value.character.string, src->value.character.string,
+ MIN (kind, len));
+
+ if (len < kind)
+ memset (&result->value.character.string[len], ' ', kind - len);
+
+ result->value.character.string[kind] = '\0'; /* For debugger */
+ result->value.character.length = kind;
+
+ return result;
+}
+
+/* Convert Hollerith to complex. The constant will be padded or truncated. */
+
+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;
+ result->from_H = 1;
+
+ kind = kind * 2;
+
+ if (len > kind)
+ {
+ gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+ &src->where, gfc_typename(&result->ts));
+ }
+ result->value.character.string = gfc_getmem (kind + 1);
+ memcpy (result->value.character.string, src->value.character.string,
+ MIN (kind, len));
+
+ if (len < kind)
+ memset (&result->value.character.string[len], ' ', kind - len);
+
+ result->value.character.string[kind] = '\0'; /* For debugger */
+ result->value.character.length = kind;
+
+ return result;
+}
+
+/* Convert Hollerith to character. */
+
+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->from_H = 1;
+
+ return result;
+}
+
+/* Convert Hollerith to logical. The constant will be padded or truncated. */
+
+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;
+ result->from_H = 1;
+
+ if (len > kind)
+ {
+ gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+ &src->where, gfc_typename(&result->ts));
+ }
+ result->value.character.string = gfc_getmem (kind + 1);
+ memcpy (result->value.character.string, src->value.character.string,
+ MIN (kind, len));
+
+ if (len < kind)
+ memset (&result->value.character.string[len], ' ', kind - len);
+
+ result->value.character.string[kind] = '\0'; /* For debugger */
+ result->value.character.length = kind;
+
+ return result;
+}
OSDN Git Service
