* g++.dg/ipa/iinline-1.C: Remove -c flag, add -fpie for PIC

[pf3gnuchains/gcc-fork.git] / gcc / fortran / arith.c

diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c
index bd32145..c56be03 100644 (file)
--- a/gcc/fortran/arith.c
+++ b/gcc/fortran/arith.c
@@ -35,15 +35,19 @@ along with GCC; see the file COPYING3.  If not see
    It's easily implemented with a few calls though.  */
 
 void
-gfc_mpfr_to_mpz (mpz_t z, mpfr_t x)
+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);
-  /* MPFR 2.0.1 (included with GMP 4.1) has a bug whereby mpfr_get_z_exp
-     may set the sign of z incorrectly.  Work around that here.  */
-  if (mpfr_sgn (x) != mpz_sgn (z))
-    mpz_neg (z, z);
 
   if (e > 0)
     mpz_mul_2exp (z, z, e);
@@ -1069,7 +1073,8 @@ gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
   gfc_expr *result;
   int len;
 
-  result = gfc_constant_result (BT_CHARACTER, gfc_default_character_kind,
+  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;
@@ -1092,7 +1097,7 @@ gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 }
 
 /* Comparison between real values; returns 0 if (op1 .op. op2) is true.
-   This function mimics mpr_cmp but takes NaN into account.  */
+   This function mimics mpfr_cmp but takes NaN into account.  */
 
 static int
 compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
@@ -1159,7 +1164,7 @@ gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
 
 
 /* Compare a pair of complex numbers.  Naturally, this is only for
-   equality and nonequality.  */
+   equality and inequality.  */
 
 static int
 compare_complex (gfc_expr *op1, gfc_expr *op2)
@@ -1552,7 +1557,7 @@ eval_f;
    operands are array constructors.  */
 
 static gfc_expr *
-eval_intrinsic (gfc_intrinsic_op operator,
+eval_intrinsic (gfc_intrinsic_op op,
                eval_f eval, gfc_expr *op1, gfc_expr *op2)
 {
   gfc_expr temp, *result;
@@ -1561,7 +1566,7 @@ eval_intrinsic (gfc_intrinsic_op operator,
 
   gfc_clear_ts (&temp.ts);
 
-  switch (operator)
+  switch (op)
     {
     /* Logical unary  */
     case INTRINSIC_NOT:
@@ -1650,19 +1655,19 @@ eval_intrinsic (gfc_intrinsic_op operator,
 
       temp.expr_type = EXPR_OP;
       gfc_clear_ts (&temp.ts);
-      temp.value.op.operator = operator;
+      temp.value.op.op = op;
 
       temp.value.op.op1 = op1;
       temp.value.op.op2 = op2;
 
       gfc_type_convert_binary (&temp);
 
-      if (operator == INTRINSIC_EQ || operator == INTRINSIC_NE
-         || operator == INTRINSIC_GE || operator == INTRINSIC_GT
-         || operator == INTRINSIC_LE || operator == INTRINSIC_LT
-         || operator == INTRINSIC_EQ_OS || operator == INTRINSIC_NE_OS
-         || operator == INTRINSIC_GE_OS || operator == INTRINSIC_GT_OS
-         || operator == INTRINSIC_LE_OS || operator == INTRINSIC_LT_OS)
+      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;
@@ -1690,7 +1695,7 @@ eval_intrinsic (gfc_intrinsic_op operator,
     }
 
   /* Try to combine the operators.  */
-  if (operator == INTRINSIC_POWER && op2->ts.type != BT_INTEGER)
+  if (op == INTRINSIC_POWER && op2->ts.type != BT_INTEGER)
     goto runtime;
 
   if (op1->expr_type != EXPR_CONSTANT
@@ -1725,7 +1730,7 @@ runtime:
   result->ts = temp.ts;
 
   result->expr_type = EXPR_OP;
-  result->value.op.operator = operator;
+  result->value.op.op = op;
 
   result->value.op.op1 = op1;
   result->value.op.op2 = op2;
@@ -1739,12 +1744,12 @@ runtime:
 /* Modify type of expression for zero size array.  */
 
 static gfc_expr *
-eval_type_intrinsic0 (gfc_intrinsic_op operator, gfc_expr *op)
+eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
 {
   if (op == NULL)
     gfc_internal_error ("eval_type_intrinsic0(): op NULL");
 
-  switch (operator)
+  switch (iop)
     {
     case INTRINSIC_GE:
     case INTRINSIC_GE_OS:
@@ -1806,7 +1811,7 @@ reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
 
 
 static gfc_expr *
-eval_intrinsic_f2 (gfc_intrinsic_op operator,
+eval_intrinsic_f2 (gfc_intrinsic_op op,
                   arith (*eval) (gfc_expr *, gfc_expr **),
                   gfc_expr *op1, gfc_expr *op2)
 {
@@ -1816,22 +1821,22 @@ eval_intrinsic_f2 (gfc_intrinsic_op operator,
   if (op2 == NULL)
     {
       if (gfc_zero_size_array (op1))
-       return eval_type_intrinsic0 (operator, op1);
+       return eval_type_intrinsic0 (op, op1);
     }
   else
     {
       result = reduce_binary0 (op1, op2);
       if (result != NULL)
-       return eval_type_intrinsic0 (operator, result);
+       return eval_type_intrinsic0 (op, result);
     }
 
   f.f2 = eval;
-  return eval_intrinsic (operator, f, op1, op2);
+  return eval_intrinsic (op, f, op1, op2);
 }
 
 
 static gfc_expr *
-eval_intrinsic_f3 (gfc_intrinsic_op operator,
+eval_intrinsic_f3 (gfc_intrinsic_op op,
                   arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
                   gfc_expr *op1, gfc_expr *op2)
 {
@@ -1840,10 +1845,10 @@ eval_intrinsic_f3 (gfc_intrinsic_op operator,
 
   result = reduce_binary0 (op1, op2);
   if (result != NULL)
-    return eval_type_intrinsic0(operator, result);
+    return eval_type_intrinsic0(op, result);
 
   f.f3 = eval;
-  return eval_intrinsic (operator, f, op1, op2);
+  return eval_intrinsic (op, f, op1, op2);
 }
 
 
@@ -2060,11 +2065,13 @@ arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
                 gfc_typename (from), gfc_typename (to), where);
       break;
     case ARITH_UNDERFLOW:
-      gfc_error ("Arithmetic underflow converting %s to %s at %L",
+      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",
+      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:
@@ -2084,7 +2091,7 @@ arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
       gfc_internal_error ("gfc_arith_error(): Bad error code");
     }
 
-  /* TODO: Do something about the error, ie, throw exception, return
+  /* TODO: Do something about the error, i.e., throw exception, return
      NaN, etc.  */
 }
 
@@ -2176,7 +2183,7 @@ gfc_real2int (gfc_expr *src, int kind)
 
   result = gfc_constant_result (BT_INTEGER, kind, &src->where);
 
-  gfc_mpfr_to_mpz (result->value.integer, src->value.real);
+  gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
 
   if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
     {
@@ -2262,7 +2269,7 @@ gfc_complex2int (gfc_expr *src, int kind)
 
   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, &src->where);
 
   if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
     {