Bit functions, HUGE and DIGITS.

diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc
index b270ae8741ff6e55d23fd69a7c29323af19015a3..93641d91926fe95754f8551502b6932dcf76222d 100644 (file)
--- a/gcc/fortran/arith.cc
+++ b/gcc/fortran/arith.cc
@@ -58,7 +58,16 @@ gfc_mpfr_to_mpz (mpz_t z, mpfr_t x, locus *where)
     mpz_tdiv_q_2exp (z, z, -e);
 }
 
+/* Reduce an unsigned number to within its range.  */
 
+void
+gfc_reduce_unsigned (gfc_expr *e)
+{
+  int k;
+  gcc_checking_assert (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_UNSIGNED);
+  k = gfc_validate_kind (BT_UNSIGNED, e->ts.kind, false);
+  mpz_and (e->value.integer, e->value.integer, gfc_unsigned_kinds[k].huge);
+}
 /* Set the model number precision by the requested KIND.  */
 
 void
@@ -688,7 +697,6 @@ gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
 {
   gfc_expr *result;
   arith rc;
-  int k;
 
   result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
 
@@ -702,13 +710,11 @@ gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
       {
        arith neg_rc;
        mpz_neg (result->value.integer, op1->value.integer);
-       k = gfc_validate_kind (BT_UNSIGNED, op1->ts.kind, false);
        neg_rc = gfc_range_check (result);
        if (neg_rc != ARITH_OK)
          gfc_warning (0, gfc_arith_error (neg_rc), &result->where);
 
-       mpz_and (result->value.integer, result->value.integer,
-                gfc_unsigned_kinds[k].huge);
+       gfc_reduce_unsigned (result);
        if (pedantic)
          rc = neg_rc;
       }
@@ -749,6 +755,11 @@ gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
       mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
       break;
 
+    case BT_UNSIGNED:
+      mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
+      gfc_reduce_unsigned (result);
+      break;
+
     case BT_REAL:
       mpfr_add (result->value.real, op1->value.real, op2->value.real,
               GFC_RND_MODE);
@@ -783,6 +794,7 @@ gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
   switch (op1->ts.type)
     {
     case BT_INTEGER:
+    case BT_UNSIGNED:
       mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
       break;
 
@@ -823,6 +835,11 @@ gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
       mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
       break;
 
+    case BT_UNSIGNED:
+      mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
+      gfc_reduce_unsigned (result);
+      break;
+
     case BT_REAL:
       mpfr_mul (result->value.real, op1->value.real, op2->value.real,
               GFC_RND_MODE);
@@ -860,6 +877,7 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
   switch (op1->ts.type)
     {
     case BT_INTEGER:
+    case BT_UNSIGNED:
       if (mpz_sgn (op2->value.integer) == 0)
        {
          rc = ARITH_DIV0;
@@ -2384,7 +2402,6 @@ gfc_uint2uint (gfc_expr *src, int kind)
 {
   gfc_expr *result;
   arith rc;
-  int k;
 
   if (src->ts.type != BT_UNSIGNED && src->ts.type != BT_INTEGER)
     return NULL;
@@ -2396,10 +2413,7 @@ gfc_uint2uint (gfc_expr *src, int kind)
   if (rc != ARITH_OK)
     gfc_warning (0, gfc_arith_error (rc), &result->where);
 
-  k = gfc_validate_kind (BT_UNSIGNED, kind, false);
-  mpz_and (result->value.integer, result->value.integer,
-          gfc_unsigned_kinds[k].huge);
-
+  gfc_reduce_unsigned (result);
   return result;
 }
 
@@ -2540,7 +2554,6 @@ gfc_real2uint (gfc_expr *src, int kind)
   gfc_expr *result;
   arith rc;
   bool did_warn = false;
-  int k;
 
   if (src->ts.type != BT_REAL)
     return NULL;
@@ -2555,9 +2568,7 @@ gfc_real2uint (gfc_expr *src, int kind)
       return NULL;
     }
 
-  k = gfc_validate_kind (BT_UNSIGNED, kind, false);
-  mpz_and (result->value.integer, result->value.integer,
-          gfc_unsigned_kinds[k].huge);
+  gfc_reduce_unsigned (result);
 
   /* If there was a fractional part, warn about this.  */
 
@@ -2774,7 +2785,6 @@ gfc_complex2uint (gfc_expr *src, int kind)
   gfc_expr *result;
   arith rc;
   bool did_warn = false;
-  int k;
 
   if (src->ts.type != BT_COMPLEX)
     return NULL;
@@ -2791,9 +2801,7 @@ gfc_complex2uint (gfc_expr *src, int kind)
       return NULL;
     }
 
-  k = gfc_validate_kind (BT_UNSIGNED, kind, false);
-  mpz_and (result->value.integer, result->value.integer,
-          gfc_unsigned_kinds[k].huge);
+  gfc_reduce_unsigned (result);
 
   if (warn_conversion || warn_conversion_extra)
     {

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 360d06f2532c4a481d740e28e4e61708026c160c..5cfae6182c3b9ac12833b730547b65de76c940ad 100644 (file)
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -524,6 +524,20 @@ type_check (gfc_expr *e, int n, bt type)
   return false;
 }
 
+/* Check the type of an expression which can be one of two.  */
+
+static bool
+type_check2 (gfc_expr *e, int n, bt type1, bt type2)
+{
+  if (e->ts.type == type1 || e->ts.type == type2)
+    return true;
+
+  gfc_error ("%qs argument of %qs intrinsic at %L must be %s or %s",
+            gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+            &e->where, gfc_basic_typename (type1), gfc_basic_typename (type2));
+
+  return false;
+}
 
 /* Check that the expression is a numeric type.  */
 
@@ -575,6 +589,23 @@ int_or_real_check (gfc_expr *e, int n)
   return true;
 }
 
+/* Check that an expression is integer or real... or unsigned.  */
+
+static bool
+int_or_real_or_unsigned_check (gfc_expr *e, int n)
+{
+  if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL
+      && e->ts.type != BT_UNSIGNED)
+    {
+      gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
+                "REAL or UNSIGNED", gfc_current_intrinsic_arg[n]->name,
+                gfc_current_intrinsic, &e->where);
+      return false;
+    }
+
+  return true;
+}
+
 /* Check that an expression is integer or real; allow character for
    F2003 or later.  */
 
@@ -2669,7 +2700,13 @@ gfc_check_dble (gfc_expr *x)
 bool
 gfc_check_digits (gfc_expr *x)
 {
-  if (!int_or_real_check (x, 0))
+
+  if (flag_unsigned)
+    {
+      if (!int_or_real_or_unsigned_check (x, 0))
+       return false;
+    }
+  else if (!int_or_real_check (x, 0))
     return false;
 
   return true;
@@ -3049,7 +3086,12 @@ gfc_check_fnum (gfc_expr *unit)
 bool
 gfc_check_huge (gfc_expr *x)
 {
-  if (!int_or_real_check (x, 0))
+  if (flag_unsigned)
+    {
+      if (!int_or_real_or_unsigned_check (x, 0))
+       return false;
+    }
+  else if (!int_or_real_check (x, 0))
     return false;
 
   return true;
@@ -3079,6 +3121,21 @@ gfc_check_i (gfc_expr *i)
   return true;
 }
 
+/* Check that the single argument is an integer or an UNSIGNED.  */
+
+bool
+gfc_check_iu (gfc_expr *i)
+{
+  if (flag_unsigned)
+    {
+      if (!type_check2 (i, 0, BT_INTEGER, BT_UNSIGNED))
+       return false;
+    }
+  else if (!type_check (i, 0, BT_INTEGER))
+    return false;
+
+  return true;
+}
 
 bool
 gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j)
@@ -3097,12 +3154,37 @@ gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j)
       && !gfc_boz2int (j, i->ts.kind))
     return false;
 
-  if (!type_check (i, 0, BT_INTEGER))
+  /* If i is BOZ and j is UNSIGNED, convert i to type of j.  */
+  if (i->ts.type == BT_BOZ && j->ts.type == BT_UNSIGNED
+      && !gfc_boz2uint (i, j->ts.kind))
     return false;
 
-  if (!type_check (j, 1, BT_INTEGER))
+  /* If j is BOZ and i is UNSIGNED, convert j to type of i.  */
+  if (j->ts.type == BT_BOZ && i->ts.type == BT_UNSIGNED
+      && !gfc_boz2uint (j, i->ts.kind))
     return false;
 
+  if (flag_unsigned)
+    {
+      if (gfc_invalid_unsigned_ops (i,j))
+       return false;
+
+      if (!type_check2 (i, 0, BT_INTEGER, BT_UNSIGNED))
+       return false;
+
+      if (!type_check2 (j, 1, BT_INTEGER, BT_UNSIGNED))
+       return false;
+    }
+  else
+    {
+
+      if (!type_check (i, 0, BT_INTEGER))
+       return false;
+
+      if (!type_check (j, 1, BT_INTEGER))
+       return false;
+    }
+
   if (i->ts.kind != j->ts.kind)
     {
       gfc_error ("Arguments of %qs have different kind type parameters "

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index e3567cd0d18f671100a407ac1ca8397bce509d14..5f8dd1300a500221deb1a4c3f508db47def7e581 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3474,6 +3474,7 @@ arith gfc_check_integer_range (mpz_t p, int kind);
 arith gfc_check_unsigned_range (mpz_t p, int kind);
 bool gfc_check_character_range (gfc_char_t, int);
 const char *gfc_arith_error (arith);
+void gfc_reduce_unigned (gfc_expr *e);
 
 extern bool gfc_seen_div0;
 

diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index 86f5ce9f1e326d31b96a70d15afb3a674a892d35..8dcdff9540a598dc5d97ca1ef4e057efa86f6720 100644 (file)
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -2747,7 +2747,7 @@ add_functions (void)
   make_generic ("nint", GFC_ISYM_NINT, GFC_STD_F77);
 
   add_sym_1 ("not", GFC_ISYM_NOT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
-            gfc_check_i, gfc_simplify_not, gfc_resolve_not,
+            gfc_check_iu, gfc_simplify_not, gfc_resolve_not,
             i, BT_INTEGER, di, REQUIRED);
 
   if (flag_dec_intrinsic_ints)

diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index fcb2733ddec8b2ca3172bdb11ddfc05f59e6101f..653a17fd9b9f193310c46cfba59148b0593ed088 100644 (file)
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -89,6 +89,7 @@ bool gfc_check_hostnm (gfc_expr *);
 bool gfc_check_huge (gfc_expr *);
 bool gfc_check_hypot (gfc_expr *, gfc_expr *);
 bool gfc_check_i (gfc_expr *);
+bool gfc_check_iu (gfc_expr *);
 bool gfc_check_iand_ieor_ior (gfc_expr *, gfc_expr *);
 bool gfc_check_and (gfc_expr *, gfc_expr *);
 bool gfc_check_ibits (gfc_expr *, gfc_expr *, gfc_expr *);

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 8f70acf84ca05634a7942bbae002de4ac30eafc3..dca383ebd19f874f04af69a284b2b290ef11af0b 100644 (file)
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -4458,6 +4458,15 @@ resolve_operator (gfc_expr *e)
              goto bad_op;
            }
 
+         if (flag_unsigned  && gfc_invalid_unsigned_ops (op1, op2))
+           {
+             dual_locus_error = true;
+             snprintf (msg, sizeof (msg),
+                       _("Inconsistent types for operator at %%L and %%L: "
+                         "%s and %s"), gfc_typename (op1), gfc_typename (op2));
+             goto bad_op;
+           }
+
          gfc_type_convert_binary (e, 1);
 
          e->ts.type = BT_LOGICAL;

diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 5bedab3f3f4ddbe4bc0053f2cc33117d1f3200a2..e00ebb6e4d1952826269b913cf977a60231c66e4 100644 (file)
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -2356,6 +2356,10 @@ gfc_simplify_digits (gfc_expr *x)
        digits = gfc_integer_kinds[i].digits;
        break;
 
+      case BT_UNSIGNED:
+       digits = gfc_unsigned_kinds[i].digits;
+       break;
+
       case BT_REAL:
       case BT_COMPLEX:
        digits = gfc_real_kinds[i].digits;
@@ -3265,7 +3269,11 @@ gfc_simplify_huge (gfc_expr *e)
        mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
        break;
 
-      case BT_REAL:
+      case BT_UNSIGNED:
+       mpz_set (result->value.integer, gfc_unsigned_kinds[i].huge);
+       break;
+
+    case BT_REAL:
        mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
        break;
 
@@ -3369,11 +3377,13 @@ gfc_expr *
 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
 {
   gfc_expr *result;
+  bt type;
 
   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
     return NULL;
 
-  result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
+  type = x->ts.type == BT_UNSIGNED ? BT_UNSIGNED : BT_INTEGER;
+  result = gfc_get_constant_expr (type, x->ts.kind, &x->where);
   mpz_and (result->value.integer, x->value.integer, y->value.integer);
 
   return range_check (result, "IAND");
@@ -3547,11 +3557,13 @@ gfc_expr *
 gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
 {
   gfc_expr *result;
+  bt type;
 
   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
     return NULL;
 
-  result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
+  type = x->ts.type == BT_UNSIGNED ? BT_UNSIGNED : BT_INTEGER;
+  result = gfc_get_constant_expr (type, x->ts.kind, &x->where);
   mpz_xor (result->value.integer, x->value.integer, y->value.integer);
 
   return range_check (result, "IEOR");
@@ -3774,11 +3786,13 @@ gfc_expr *
 gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
 {
   gfc_expr *result;
+  bt type;
 
   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
     return NULL;
 
-  result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
+  type = x->ts.type == BT_UNSIGNED ? BT_UNSIGNED : BT_INTEGER;
+  result = gfc_get_constant_expr (type, x->ts.kind, &x->where);
   mpz_ior (result->value.integer, x->value.integer, y->value.integer);
 
   return range_check (result, "IOR");

diff --git a/gcc/testsuite/gfortran.dg/unsigned_7.f90 b/gcc/testsuite/gfortran.dg/unsigned_7.f90
new file mode 100644 (file)
index 0000000..703c8ab
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unsigned_7.f90
@@ -0,0 +1,26 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test bit functions, huge and digits.
+  unsigned :: u1, u2, u3
+  u1 = 32u
+  u2 = 64u
+  if (ior (u1,u2) /= u1 + u2) error stop 1
+  if (ior (32u,64u) /= 32u + 64u) error stop 2
+  u1 = 234u
+  u2 = 221u
+  if (iand (u1,u2) /= 200u) error stop 3
+  if (iand (234u,221u) /= 200u) error stop 4
+  if (ieor (u1,u2) /= 55u) error stop 5
+  if (ieor (234u,221u) /= 55u) error stop 6
+  u1 = huge(u1)
+  if (u1 /= 4294967295u) error stop 7
+  u2 = not(0u)
+  u3 = u2 - u1
+  if (u3 /= 0u) error stop 8
+  u2 = not(255u);
+  if (u2 /= huge(u2) - 255u) error stop 9
+  u1 = 255u
+  u2 = not(u1)
+  if (u2 /= huge(u2) - 255u) error stop 9
+  if (digits(u1) /= 32) error stop 10
+end