re PR fortran/45513 (BOZ kinds differently handled, F2008: BOZ in bit intrinsics)

2018-12-24  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/45513
	PR fortran/81509
	* check.c: Rename function gfc_check_iand to gfc_check_iand_ieor_ior.
	* check.c (boz_args_check): New function.  Check I and J not both BOZ.
	(gfc_check_dshift,gfc_check_iand_ieor_ior, gfc_check_ishft,
	 gfc_check_and, gfc_check_merge_bits): Use it.
	* check.c (gfc_check_iand_ieor_ior): Force conversion of BOZ to kind
	type of other agrument.  Remove silly GNU extension.
	(gfc_check_ieor, gfc_check_ior): Delete now unused functions.
	* intrinsic.c (add_functions): Use gfc_check_iand_ieor_ior. Wrap long
	line.
	* intrinsic.h: Rename gfc_check_iand to gfc_check_iand_ieor_ior.
	Delete prototype for bool gfc_check_ieor and gfc_check_ior
	* intrinsic.texi: Update documentation for boz-literal-constant.

2018-12-24  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/45513
	PR fortran/81509
	* gfortran.dg/graphite/id-26.f03: Fix non-conforming use of IAND.
	* gfortran.dg/pr81509_1.f90: New test.
	* gfortran.dg/pr81509_2.f90: New test.

From-SVN: r267415

1 files changed, 40 insertions, 50 deletions

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 43b0713..2f63c3e 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2168,6 +2168,21 @@ gfc_check_dprod (gfc_expr *x, gfc_expr *y)
 }
 
 
+static bool
+boz_args_check(gfc_expr *i, gfc_expr *j)
+{
+  if (i->is_boz && j->is_boz)
+    {
+      gfc_error ("Arguments of %qs at %L and %L cannot both be BOZ "
+		 "literal constants", gfc_current_intrinsic, &i->where,
+		 &j->where);
+      return false;
+
+    }
+  return true;
+}
+
+
 bool
 gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
 {
@@ -2177,12 +2192,8 @@ gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
   if (!type_check (j, 1, BT_INTEGER))
     return false;
 
-  if (i->is_boz && j->is_boz)
-    {
-      gfc_error ("%<I%> at %L and %<J%>' at %L cannot both be BOZ literal "
-		   "constants", &i->where, &j->where);
-      return false;
-    }
+  if (!boz_args_check (i, j))
+    return false;
 
   if (!i->is_boz && !j->is_boz && !same_type_check (i, 0, j, 1))
     return false;
@@ -2482,7 +2493,7 @@ gfc_check_i (gfc_expr *i)
 
 
 bool
-gfc_check_iand (gfc_expr *i, gfc_expr *j)
+gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j)
 {
   if (!type_check (i, 0, BT_INTEGER))
     return false;
@@ -2490,10 +2501,16 @@ gfc_check_iand (gfc_expr *i, gfc_expr *j)
   if (!type_check (j, 1, BT_INTEGER))
     return false;
 
+  if (!boz_args_check (i, j))
+    return false;
+
+  if (i->is_boz) i->ts.kind = j->ts.kind;
+  if (j->is_boz) j->ts.kind = i->ts.kind;
+
   if (i->ts.kind != j->ts.kind)
     {
-      if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
-			   &i->where))
+      gfc_error ("Arguments of %qs have different kind type parameters "
+		 "at %L", gfc_current_intrinsic, &i->where);
 	return false;
     }
 
@@ -2608,26 +2625,6 @@ gfc_check_idnint (gfc_expr *a)
 
 
 bool
-gfc_check_ieor (gfc_expr *i, gfc_expr *j)
-{
-  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)
-    {
-      if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
-			   &i->where))
-	return false;
-    }
-
-  return true;
-}
-
-
-bool
 gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
 		 gfc_expr *kind)
 {
@@ -2680,27 +2677,6 @@ gfc_check_intconv (gfc_expr *x)
   return true;
 }
 
-
-bool
-gfc_check_ior (gfc_expr *i, gfc_expr *j)
-{
-  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)
-    {
-      if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
-			   &i->where))
-	return false;
-    }
-
-  return true;
-}
-
-
 bool
 gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
 {
@@ -3584,6 +3560,12 @@ gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
   if (!type_check (j, 1, BT_INTEGER))
     return false;
 
+  if (!boz_args_check (i, j))
+    return false;
+
+  if (i->is_boz) i->ts.kind = j->ts.kind;
+  if (j->is_boz) j->ts.kind = i->ts.kind;
+
   if (!type_check (mask, 2, BT_INTEGER))
     return false;
 
@@ -3593,6 +3575,8 @@ gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
   if (!same_type_check (i, 0, mask, 2))
     return false;
 
+  if (mask->is_boz) mask->ts.kind = i->ts.kind;
+
   return true;
 }
 
@@ -6719,6 +6703,12 @@ gfc_check_and (gfc_expr *i, gfc_expr *j)
   if (!scalar_check (j, 1))
     return false;
 
+  if (!boz_args_check (i, j))
+    return false;
+
+  if (i->is_boz) i->ts.kind = j->ts.kind;
+  if (j->is_boz) j->ts.kind = i->ts.kind;
+
   return true;
 }