Implement dshift[lr], ibclr, ibset and ibits.

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 1a8f601ce838fb719c4316ba427343a5dde3d8d1..54a84ae40756ee3b9e38757ab334157e97320e85 100644 (file)
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -913,14 +913,20 @@ static bool
 less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
 {
   int i, val;
+  int bit_size;
 
   if (expr->expr_type != EXPR_CONSTANT)
     return true;
 
-  i = gfc_validate_kind (BT_INTEGER, k, false);
+  i = gfc_validate_kind (expr->ts.type, k, false);
   gfc_extract_int (expr, &val);
 
-  if (val > gfc_integer_kinds[i].bit_size)
+  if (expr->ts.type == BT_INTEGER)
+    bit_size = gfc_integer_kinds[i].bit_size;
+  else
+    bit_size = gfc_unsigned_kinds[i].bit_size;
+
+  if (val > bit_size)
     {
       gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of "
                 "INTEGER(KIND=%d)", arg, &expr->where, k);
@@ -939,14 +945,21 @@ less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
               gfc_expr *expr2, const char *arg3, gfc_expr *expr3)
 {
   int i2, i3;
+  int k, bit_size;
 
   if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT)
     {
       gfc_extract_int (expr2, &i2);
       gfc_extract_int (expr3, &i3);
       i2 += i3;
-      i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
-      if (i2 > gfc_integer_kinds[i3].bit_size)
+      k = gfc_validate_kind (expr1->ts.type, expr1->ts.kind, false);
+
+      if (expr1->ts.type == BT_INTEGER)
+       bit_size = gfc_integer_kinds[k].bit_size;
+      else
+       bit_size = gfc_unsigned_kinds[k].bit_size;
+
+      if (i2 > bit_size)
        {
          gfc_error ("%<%s + %s%> at %L must be less than or equal "
                     "to BIT_SIZE(%qs)",
@@ -2822,33 +2835,54 @@ gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
   if (!boz_args_check (i, j))
     return false;
 
-  /* If i is BOZ and j is integer, convert i to type of j.  If j is not
-     an integer, clear the BOZ; otherwise, check that i is an integer.  */
   if (i->ts.type == BT_BOZ)
     {
-      if (j->ts.type != BT_INTEGER)
-        reset_boz (i);
-      else if (!gfc_boz2int (i, j->ts.kind))
-       return false;
+      if (j->ts.type == BT_INTEGER)
+       {
+         if (!gfc_boz2int (i, j->ts.kind))
+           return false;
+       }
+      else if (flag_unsigned && j->ts.type == BT_UNSIGNED)
+       {
+         if (!gfc_boz2uint (i, j->ts.kind))
+           return false;
+       }
+      else
+       reset_boz (i);
     }
-  else if (!type_check (i, 0, BT_INTEGER))
+
+  if (j->ts.type == BT_BOZ)
     {
-      if (j->ts.type == BT_BOZ)
+      if (i->ts.type == BT_INTEGER)
+       {
+         if (!gfc_boz2int (j, i->ts.kind))
+           return false;
+       }
+      else if (flag_unsigned && i->ts.type == BT_UNSIGNED)
+       {
+         if (!gfc_boz2uint (j, i->ts.kind))
+           return false;
+       }
+      else
        reset_boz (j);
-      return false;
     }
 
-  /* If j is BOZ and i is integer, convert j to type of i.  If i is not
-     an integer, clear the BOZ; otherwise, check that i is an integer.  */
-  if (j->ts.type == BT_BOZ)
+  if (flag_unsigned)
     {
-      if (i->ts.type != BT_INTEGER)
-        reset_boz (j);
-      else if (!gfc_boz2int (j, i->ts.kind))
+      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;
     }
-  else if (!type_check (j, 1, BT_INTEGER))
-    return false;
 
   if (!same_type_check (i, 0, j, 1))
     return false;
@@ -3231,8 +3265,16 @@ gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j)
 bool
 gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
 {
-  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;

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 5f8dd1300a500221deb1a4c3f508db47def7e581..16395a35b0306797694465001ddca3f10626d835 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3474,7 +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);
+void gfc_reduce_unsigned (gfc_expr *e);
 
 extern bool gfc_seen_div0;
 

diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index 845c99f18ddf24504a6cc88a7a89b5bc345ec565..8e2ad8780f8c5e5ba1218f898c57d302144c691d 100644 (file)
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -895,11 +895,13 @@ void
 gfc_resolve_dshift (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED,
                    gfc_expr *shift ATTRIBUTE_UNUSED)
 {
+  char c = i->ts.type == BT_INTEGER ? 'i' : 'u';
+
   f->ts = i->ts;
   if (f->value.function.isym->id == GFC_ISYM_DSHIFTL)
-    f->value.function.name = gfc_get_string ("dshiftl_i%d", f->ts.kind);
+    f->value.function.name = gfc_get_string ("dshiftl_%c%d", c, f->ts.kind);
   else if (f->value.function.isym->id == GFC_ISYM_DSHIFTR)
-    f->value.function.name = gfc_get_string ("dshiftr_i%d", f->ts.kind);
+    f->value.function.name = gfc_get_string ("dshiftr_%c%d", c, f->ts.kind);
   else
     gcc_unreachable ();
 }
@@ -1182,6 +1184,7 @@ gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
   /* If the kind of i and j are different, then g77 cross-promoted the
      kinds to the largest value.  The Fortran 95 standard requires the
      kinds to match.  */
+
   if (i->ts.kind != j->ts.kind)
     {
       if (i->ts.kind == gfc_kind_max (i, j))
@@ -1191,7 +1194,8 @@ gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
     }
 
   f->ts = i->ts;
-  f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
+  const char *name = i->ts.kind == BT_UNSIGNED ? "__iand_u_%d" : "__iand_%d";
+  f->value.function.name = gfc_get_string (name, i->ts.kind);
 }
 
 
@@ -1206,7 +1210,8 @@ void
 gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
 {
   f->ts = i->ts;
-  f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
+  const char *name = i->ts.kind == BT_UNSIGNED ? "__ibclr_u_%d" : "__ibclr_%d";
+  f->value.function.name = gfc_get_string (name, i->ts.kind);
 }
 
 
@@ -1215,7 +1220,8 @@ gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED,
                   gfc_expr *len ATTRIBUTE_UNUSED)
 {
   f->ts = i->ts;
-  f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
+  const char *name = i->ts.kind == BT_UNSIGNED ? "__ibits_u_%d" : "__ibits_%d";
+  f->value.function.name = gfc_get_string (name, i->ts.kind);
 }
 
 
@@ -1223,7 +1229,8 @@ void
 gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
 {
   f->ts = i->ts;
-  f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
+  const char *name = i->ts.kind == BT_UNSIGNED ? "__ibset_u_%d" : "__ibset_%d";
+  f->value.function.name = gfc_get_string (name, i->ts.kind);
 }
 
 
@@ -1273,6 +1280,7 @@ gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
   /* If the kind of i and j are different, then g77 cross-promoted the
      kinds to the largest value.  The Fortran 95 standard requires the
      kinds to match.  */
+
   if (i->ts.kind != j->ts.kind)
     {
       if (i->ts.kind == gfc_kind_max (i, j))
@@ -1281,8 +1289,9 @@ gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
        gfc_convert_type (i, &j->ts, 2);
     }
 
+  const char *name = i->ts.kind == BT_UNSIGNED ? "__ieor_u_%d" : "__ieor_%d";
   f->ts = i->ts;
-  f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
+  f->value.function.name = gfc_get_string (name, i->ts.kind);
 }
 
 
@@ -1292,6 +1301,7 @@ gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
   /* If the kind of i and j are different, then g77 cross-promoted the
      kinds to the largest value.  The Fortran 95 standard requires the
      kinds to match.  */
+
   if (i->ts.kind != j->ts.kind)
     {
       if (i->ts.kind == gfc_kind_max (i, j))
@@ -1300,8 +1310,9 @@ gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
        gfc_convert_type (i, &j->ts, 2);
     }
 
+  const char *name = i->ts.kind == BT_UNSIGNED ? "__ior_u_%d" : "__ior_%d";
   f->ts = i->ts;
-  f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
+  f->value.function.name = gfc_get_string (name, i->ts.kind);
 }
 
 
@@ -2225,7 +2236,8 @@ void
 gfc_resolve_not (gfc_expr *f, gfc_expr *i)
 {
   f->ts = i->ts;
-  f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
+  const char *name = i->ts.kind == BT_UNSIGNED ? "__not_u_%d" : "__not_%d";
+  f->value.function.name = gfc_get_string (name, i->ts.kind);
 }
 
 

diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 1818dc5956ccfda4963dc6407916336b60bc37bd..b7b280754e90879a8e7504c407540f0432dc0ace 100644 (file)
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -2493,13 +2493,23 @@ simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg,
 {
   gfc_expr *result;
   int i, k, size, shift;
+  bt type = BT_INTEGER;
 
   if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT
       || shiftarg->expr_type != EXPR_CONSTANT)
     return NULL;
 
-  k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false);
-  size = gfc_integer_kinds[k].bit_size;
+  if (flag_unsigned && arg1->ts.type == BT_UNSIGNED)
+    {
+      k = gfc_validate_kind (BT_UNSIGNED, arg1->ts.kind, false);
+      size = gfc_unsigned_kinds[k].bit_size;
+      type = BT_UNSIGNED;
+    }
+  else
+    {
+      k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false);
+      size = gfc_integer_kinds[k].bit_size;
+    }
 
   gfc_extract_int (shiftarg, &shift);
 
@@ -2507,7 +2517,7 @@ simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg,
   if (right)
     shift = size - shift;
 
-  result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where);
+  result = gfc_get_constant_expr (type, arg1->ts.kind, &arg1->where);
   mpz_set_ui (result->value.integer, 0);
 
   for (i = 0; i < shift; i++)
@@ -2518,8 +2528,11 @@ simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg,
     if (mpz_tstbit (arg1->value.integer, i))
       mpz_setbit (result->value.integer, shift + i);
 
-  /* Convert to a signed value.  */
-  gfc_convert_mpz_to_signed (result->value.integer, size);
+  /* Convert to a signed value if needed.  */
+  if (type == BT_INTEGER)
+    gfc_convert_mpz_to_signed (result->value.integer, size);
+  else
+    gfc_reduce_unsigned (result);
 
   return result;
 }
@@ -3448,13 +3461,18 @@ gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
       result->representation.string = NULL;
     }
 
-  gfc_convert_mpz_to_unsigned (result->value.integer,
-                          gfc_integer_kinds[k].bit_size);
+  if (x->ts.type == BT_INTEGER)
+    {
+      gfc_convert_mpz_to_unsigned (result->value.integer,
+                                  gfc_integer_kinds[k].bit_size);
 
-  mpz_clrbit (result->value.integer, pos);
+      mpz_clrbit (result->value.integer, pos);
 
-  gfc_convert_mpz_to_signed (result->value.integer,
-                        gfc_integer_kinds[k].bit_size);
+      gfc_convert_mpz_to_signed (result->value.integer,
+                                gfc_integer_kinds[k].bit_size);
+    }
+  else
+    mpz_clrbit (result->value.integer, pos);
 
   return result;
 }
@@ -3479,9 +3497,13 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
   gfc_extract_int (y, &pos);
   gfc_extract_int (z, &len);
 
-  k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
+  k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
 
-  bitsize = gfc_integer_kinds[k].bit_size;
+  if (x->ts.type == BT_INTEGER)
+    bitsize = gfc_integer_kinds[k].bit_size;
+  else
+    bitsize = gfc_unsigned_kinds[k].bit_size;
+    
 
   if (pos + len > bitsize)
     {
@@ -3491,8 +3513,10 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
     }
 
   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
-  gfc_convert_mpz_to_unsigned (result->value.integer,
-                          gfc_integer_kinds[k].bit_size);
+
+  if (x->ts.type == BT_INTEGER)
+    gfc_convert_mpz_to_unsigned (result->value.integer,
+                                gfc_integer_kinds[k].bit_size);
 
   bits = XCNEWVEC (int, bitsize);
 
@@ -3514,8 +3538,9 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
 
   free (bits);
 
-  gfc_convert_mpz_to_signed (result->value.integer,
-                        gfc_integer_kinds[k].bit_size);
+  if (x->ts.type == BT_INTEGER)
+    gfc_convert_mpz_to_signed (result->value.integer,
+                              gfc_integer_kinds[k].bit_size);
 
   return result;
 }
@@ -3546,13 +3571,18 @@ gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
       result->representation.string = NULL;
     }
 
-  gfc_convert_mpz_to_unsigned (result->value.integer,
-                          gfc_integer_kinds[k].bit_size);
+  if (x->ts.type == BT_INTEGER)
+    {
+      gfc_convert_mpz_to_unsigned (result->value.integer,
+                                  gfc_integer_kinds[k].bit_size);
 
-  mpz_setbit (result->value.integer, pos);
+      mpz_setbit (result->value.integer, pos);
 
-  gfc_convert_mpz_to_signed (result->value.integer,
-                        gfc_integer_kinds[k].bit_size);
+      gfc_convert_mpz_to_signed (result->value.integer,
+                                gfc_integer_kinds[k].bit_size);
+    }
+  else
+    mpz_setbit (result->value.integer, pos);
 
   return result;
 }

diff --git a/gcc/testsuite/gfortran.dg/unsigned_9.f90 b/gcc/testsuite/gfortran.dg/unsigned_9.f90
new file mode 100644 (file)
index 0000000..2627ccf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unsigned_9.f90
@@ -0,0 +1,32 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test dshiftl, dshiftr, ibclr, ibset and ibits intrinsics.
+program main
+  unsigned :: u, v, w
+  integer :: i, j, k
+
+  u = 1u;  v = 4u
+  i = 1;   j = 4
+  if (int(dshiftl(u,v,12)) /= dshiftl(i,j,12)) error stop 1
+  if (int(dshiftl(1u,4u,12)) /= dshiftl(1,4,12)) error stop 2
+  if (int(dshiftr(u,v,12)) /= dshiftr(i,j,12)) error stop 3
+  if (int(dshiftr(1u,4u,12)) /= dshiftr(1,4,12)) error stop 4
+
+  k = 14
+
+  if (int(dshiftl(u,v,k)) /= dshiftl(i,j,k)) error stop 5
+  if (int(dshiftl(1u,4u,k)) /= dshiftl(1,4,k)) error stop 6
+  if (int(dshiftr(u,v,k)) /= dshiftr(i,j,k)) error stop 7
+  if (int(dshiftr(1u,4u,k)) /= dshiftr(1,4,k)) error stop 8
+
+  u = 255u
+  i = 255
+  do k=0,8
+     if (ibclr(i,k) /= int(ibclr(u,k))) error stop  9
+     if (ibset(i,k+4) /= int(ibset(u,k+4))) error stop 10
+  end do
+  if (ibclr(255,5) /= int(ibclr(255u,5))) stop 11
+  if (ibset(255,10) /= int(ibset(255u,10))) stop 12
+
+  if (uint(ibits(6,6,2)) /= ibits(6u,6,2)) stop 13
+end program main