Add bit_size, btest and bgt plus friends.

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 5cfae6182c3b9ac12833b730547b65de76c940ad..1a8f601ce838fb719c4316ba427343a5dde3d8d1 100644 (file)
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -2015,11 +2015,36 @@ gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
       && !gfc_boz2int (j, i->ts.kind))
     return false;
 
-  if (!type_check (i, 0, BT_INTEGER))
-    return false;
+  if (flag_unsigned)
+    {
+      /* 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))
-    return false;
+      /* 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 (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;
+    }
 
   return true;
 }
@@ -2028,8 +2053,16 @@ gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
 bool
 gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
 {
-  if (!type_check (i, 0, BT_INTEGER))
-    return false;
+  if (flag_unsigned)
+    {
+      if (!type_check2 (i, 0, BT_INTEGER, BT_UNSIGNED))
+       return false;
+    }
+  else
+    {
+      if (!type_check (i, 0, BT_INTEGER))
+       return false;
+    }
 
   if (!type_check (pos, 1, BT_INTEGER))
     return false;
@@ -3154,18 +3187,18 @@ gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j)
       && !gfc_boz2int (j, i->ts.kind))
     return false;
 
-  /* 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 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 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 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 (gfc_invalid_unsigned_ops (i,j))
        return false;
 
@@ -3177,7 +3210,6 @@ gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j)
     }
   else
     {
-
       if (!type_check (i, 0, BT_INTEGER))
        return false;
 

diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index 8dcdff9540a598dc5d97ca1ef4e057efa86f6720..da4e9828dc8d5fe3998dacdae3ee4e7b63d9bd23 100644 (file)
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -1661,7 +1661,7 @@ add_functions (void)
   make_generic ("bgt", GFC_ISYM_BGT, GFC_STD_F2008);
 
   add_sym_1 ("bit_size", GFC_ISYM_BIT_SIZE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
-            gfc_check_i, gfc_simplify_bit_size, NULL,
+            gfc_check_iu, gfc_simplify_bit_size, NULL,
             i, BT_INTEGER, di, REQUIRED);
 
   make_generic ("bit_size", GFC_ISYM_BIT_SIZE, GFC_STD_F95);

diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index e00ebb6e4d1952826269b913cf977a60231c66e4..1818dc5956ccfda4963dc6407916336b60bc37bd 100644 (file)
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -1658,8 +1658,14 @@ gfc_expr *
 gfc_simplify_bit_size (gfc_expr *e)
 {
   int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
-  return gfc_get_int_expr (e->ts.kind, &e->where,
-                          gfc_integer_kinds[i].bit_size);
+  int bit_size;
+
+  if (flag_unsigned && e->ts.type == BT_UNSIGNED)
+    bit_size = gfc_unsigned_kinds[i].bit_size;
+  else
+    bit_size = gfc_integer_kinds[i].bit_size;
+
+  return gfc_get_int_expr (e->ts.kind, &e->where, bit_size);
 }
 
 
@@ -1709,47 +1715,74 @@ compare_bitwise (gfc_expr *i, gfc_expr *j)
 gfc_expr *
 gfc_simplify_bge (gfc_expr *i, gfc_expr *j)
 {
+  bool result;
+
   if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
     return NULL;
 
+  if (flag_unsigned && i->ts.type == BT_UNSIGNED)
+    result = mpz_cmp (i->value.integer, j->value.integer) >= 0;
+  else
+    result = compare_bitwise (i, j) >= 0;
+
   return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
-                              compare_bitwise (i, j) >= 0);
+                              result);
 }
 
 
 gfc_expr *
 gfc_simplify_bgt (gfc_expr *i, gfc_expr *j)
 {
+  bool result;
+
   if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
     return NULL;
 
+  if (flag_unsigned && i->ts.type == BT_UNSIGNED)
+    result = mpz_cmp (i->value.integer, j->value.integer) > 0;
+  else
+    result = compare_bitwise (i, j) > 0;
+
   return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
-                              compare_bitwise (i, j) > 0);
+                              result);
 }
 
 
 gfc_expr *
 gfc_simplify_ble (gfc_expr *i, gfc_expr *j)
 {
+  bool result;
+
   if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
     return NULL;
 
+  if (flag_unsigned && i->ts.type == BT_UNSIGNED)
+    result = mpz_cmp (i->value.integer, j->value.integer) <= 0;
+  else
+    result = compare_bitwise (i, j) <= 0;
+
   return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
-                              compare_bitwise (i, j) <= 0);
+                              result);
 }
 
 
 gfc_expr *
 gfc_simplify_blt (gfc_expr *i, gfc_expr *j)
 {
+  bool result;
+
   if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
     return NULL;
 
+  if (flag_unsigned && i->ts.type == BT_UNSIGNED)
+    result = mpz_cmp (i->value.integer, j->value.integer) < 0;
+  else
+    result = compare_bitwise (i, j) < 0;
+
   return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
-                              compare_bitwise (i, j) < 0);
+                              result);
 }
 
-
 gfc_expr *
 gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
 {

diff --git a/gcc/testsuite/gfortran.dg/unsigned_8.f90 b/gcc/testsuite/gfortran.dg/unsigned_8.f90
new file mode 100644 (file)
index 0000000..f23056a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unsigned_8.f90
@@ -0,0 +1,70 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test bit_size, btest and bgt plus friends.
+program main
+  implicit none
+  unsigned :: u
+  integer :: i, j
+  unsigned :: ui, uj
+  logical:: test_i, test_u
+  if (bit_size(u) /= 32) error stop 1
+  if (.not. btest(32,5)) error stop 2
+  if (btest(32,4)) error stop 3
+  u = 32u
+  if (btest(u,4)) error stop 4
+  do i=1,3
+     ui = uint(i)
+     do j=1,3
+        uj = uint(j)
+        test_i = blt(i,j)
+        test_u = blt(ui,uj)
+        if (test_i .neqv. test_u) error stop 5
+        test_i = ble(i,j)
+        test_u = ble(ui,uj)
+        if (test_i .neqv. test_u) error stop 6
+        test_i = bge(i,j)
+        test_u = bge(ui,uj)
+        if (test_i .neqv. test_u) error stop 7
+        test_i = bgt(i,j)
+        test_u = bgt(ui,uj)
+        if (test_i .neqv. test_u) error stop 8
+     end do
+  end do
+  if (blt (1, 1) .neqv. blt (1u, 1u)) error stop 8
+  if (ble (1, 1) .neqv. ble (1u, 1u)) error stop 9
+  if (bge (1, 1) .neqv. bge (1u, 1u)) error stop 10
+  if (bgt (1, 1) .neqv. bgt (1u, 1u)) error stop 11
+  if (blt (1, 2) .neqv. blt (1u, 2u)) error stop 12
+  if (ble (1, 2) .neqv. ble (1u, 2u)) error stop 13
+  if (bge (1, 2) .neqv. bge (1u, 2u)) error stop 14
+  if (bgt (1, 2) .neqv. bgt (1u, 2u)) error stop 15
+  if (blt (1, 3) .neqv. blt (1u, 3u)) error stop 16
+  if (ble (1, 3) .neqv. ble (1u, 3u)) error stop 17
+  if (bge (1, 3) .neqv. bge (1u, 3u)) error stop 18
+  if (bgt (1, 3) .neqv. bgt (1u, 3u)) error stop 19
+  if (blt (2, 1) .neqv. blt (2u, 1u)) error stop 20
+  if (ble (2, 1) .neqv. ble (2u, 1u)) error stop 21
+  if (bge (2, 1) .neqv. bge (2u, 1u)) error stop 22
+  if (bgt (2, 1) .neqv. bgt (2u, 1u)) error stop 23
+  if (blt (2, 2) .neqv. blt (2u, 2u)) error stop 24
+  if (ble (2, 2) .neqv. ble (2u, 2u)) error stop 25
+  if (bge (2, 2) .neqv. bge (2u, 2u)) error stop 26
+  if (bgt (2, 2) .neqv. bgt (2u, 2u)) error stop 27
+  if (blt (2, 3) .neqv. blt (2u, 3u)) error stop 28
+  if (ble (2, 3) .neqv. ble (2u, 3u)) error stop 29
+  if (bge (2, 3) .neqv. bge (2u, 3u)) error stop 30
+  if (bgt (2, 3) .neqv. bgt (2u, 3u)) error stop 31
+  if (blt (3, 1) .neqv. blt (3u, 1u)) error stop 32
+  if (ble (3, 1) .neqv. ble (3u, 1u)) error stop 33
+  if (bge (3, 1) .neqv. bge (3u, 1u)) error stop 34
+  if (bgt (3, 1) .neqv. bgt (3u, 1u)) error stop 35
+  if (blt (3, 2) .neqv. blt (3u, 2u)) error stop 36
+  if (ble (3, 2) .neqv. ble (3u, 2u)) error stop 37
+  if (bge (3, 2) .neqv. bge (3u, 2u)) error stop 38
+  if (bgt (3, 2) .neqv. bgt (3u, 2u)) error stop 39
+  if (blt (3, 3) .neqv. blt (3u, 3u)) error stop 40
+  if (ble (3, 3) .neqv. ble (3u, 3u)) error stop 41
+  if (bge (3, 3) .neqv. bge (3u, 3u)) error stop 42
+  if (bgt (3, 3) .neqv. bgt (3u, 3u)) error stop 43
+
+end