PR fortran/92018 -- BOZ the gift that keeps giving

Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c	(revision 276705)
+++ gcc/fortran/check.c	(working copy)
@@ -30,10 +30,29 @@  along with GCC; see the file COPYING3.  If not see
 #include "coretypes.h"
 #include "options.h"
 #include "gfortran.h"
+#include "arith.h"
 #include "intrinsic.h"
 #include "constructor.h"
 #include "target-memory.h"
 
+
+/* Reset a BOZ to a zero value.  This is used to prevent run-on errors
+   from resolve.c(resolve_function).  */
+
+static void
+reset_boz (gfc_expr *x)
+{
+  /* Clear boz info.  */
+  x->boz.rdx = 0;
+  x->boz.len = 0;
+  free (x->boz.str);
+
+  x->ts.type = BT_INTEGER;
+  x->ts.kind = gfc_default_integer_kind;
+  mpz_init (x->value.integer);
+  mpz_set_ui (x->value.integer, 0);
+}
+
 /* A BOZ literal constant can appear in a limited number of contexts.
    gfc_invalid_boz() is a helper function to simplify error/warning
    generation.  gfortran accepts the nonstandard 'X' for 'Z', and gfortran
@@ -63,6 +82,7 @@  illegal_boz_arg (gfc_expr *x)
     {
       gfc_error ("BOZ literal constant at %L cannot be an actual argument "
 		 "to %qs", &x->where, gfc_current_intrinsic);
+      reset_boz (x);
       return true;
     }
 
@@ -79,6 +99,8 @@  boz_args_check(gfc_expr *i, gfc_expr *j)
       gfc_error ("Arguments of %qs at %L and %L cannot both be BOZ "
 		 "literal constants", gfc_current_intrinsic, &i->where,
 		 &j->where);
+      reset_boz (i);
+      reset_boz (j);
       return false;
 
     }
@@ -2399,7 +2421,10 @@  gfc_check_complex (gfc_expr *x, gfc_expr *y)
     {
       if (gfc_invalid_boz ("BOZ constant at %L cannot appear in the COMPLEX "
 			   "intrinsic subprogram", &x->where))
-	return false;
+	{
+	  reset_boz (x);
+	  return false;
+        }
       if (y->ts.type == BT_INTEGER && !gfc_boz2int (x, y->ts.kind))
 	return false;
       if (y->ts.type == BT_REAL && !gfc_boz2real (x, y->ts.kind))
@@ -2410,7 +2435,10 @@  gfc_check_complex (gfc_expr *x, gfc_expr *y)
     {
       if (gfc_invalid_boz ("BOZ constant at %L cannot appear in the COMPLEX "
 			   "intrinsic subprogram", &y->where))
-	return false;
+	{
+	  reset_boz (y);
+	  return false;
+	}
       if (x->ts.type == BT_INTEGER && !gfc_boz2int (y, x->ts.kind))
 	return false;
       if (x->ts.type == BT_REAL && !gfc_boz2real (y, x->ts.kind))
@@ -2674,22 +2702,34 @@  gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *
   if (!boz_args_check (i, j))
     return false;
 
-  /* If i is BOZ and j is integer, convert i to type of j.  */
-  if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
-      && !gfc_boz2int (i, j->ts.kind))
-    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;
+    }
+  else if (!type_check (i, 0, BT_INTEGER))
+    {
+      if (j->ts.type == BT_BOZ)
+	reset_boz (j);
+      return false;
+    }
 
-  /* If j is BOZ and i is integer, convert j to type of i.  */
-  if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
-      && !gfc_boz2int (j, i->ts.kind))
+  /* 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 (i->ts.type != BT_INTEGER)
+        reset_boz (j);
+      else if (!gfc_boz2int (j, i->ts.kind))
+	return false;
+    }
+  else if (!type_check (j, 1, BT_INTEGER))
     return false;
 
-  if (!type_check (i, 0, BT_INTEGER))
-    return false;
-
-  if (!type_check (j, 1, BT_INTEGER))
-    return false;
-
   if (!same_type_check (i, 0, j, 1))
     return false;
 
@@ -2860,7 +2900,10 @@  gfc_check_float (gfc_expr *a)
     {
       if (gfc_invalid_boz ("BOZ literal constant at %L cannot appear in the "
 			   "FLOAT intrinsic subprogram", &a->where))
-	return false;
+	{
+	  reset_boz (a);
+	  return false;
+	}
       if (!gfc_boz2int (a, gfc_default_integer_kind))
 	return false;
     }
@@ -6126,7 +6169,11 @@  gfc_check_transfer (gfc_expr *source, gfc_expr *mold, 
   if (size != NULL)
     {
       if (!type_check (size, 2, BT_INTEGER))
-	return false;
+	{
+	  if (size->ts.type == BT_BOZ)
+	    reset_boz (size);
+	  return false;
+	}
 
       if (!scalar_check (size, 2))
 	return false;
@@ -7286,19 +7333,61 @@  gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
 bool
 gfc_check_and (gfc_expr *i, gfc_expr *j)
 {
+  if (i->ts.type != BT_INTEGER
+      && i->ts.type != BT_LOGICAL
+      && i->ts.type != BT_BOZ)
+    {
+      gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
+                 "LOGICAL, or a BOZ literal constant",
+		 gfc_current_intrinsic_arg[0]->name,
+                 gfc_current_intrinsic, &i->where);
+      return false;
+    }
+
+  if (j->ts.type != BT_INTEGER
+      && j->ts.type != BT_LOGICAL
+      && j->ts.type != BT_BOZ)
+    {
+      gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
+                 "LOGICAL, or a BOZ literal constant",
+		 gfc_current_intrinsic_arg[1]->name,
+                 gfc_current_intrinsic, &j->where);
+      return false;
+    }
+
   /* i and j cannot both be BOZ literal constants.  */
   if (!boz_args_check (i, j))
     return false;
 
   /* If i is BOZ and j is integer, convert i to type of j.  */
-  if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
-      && !gfc_boz2int (i, j->ts.kind))
-    return false;
+  if (i->ts.type == BT_BOZ)
+    {
+      if (j->ts.type != BT_INTEGER)
+	{
+	  gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
+		     gfc_current_intrinsic_arg[1]->name,
+		     gfc_current_intrinsic, &j->where);
+	  reset_boz (i);
+	  return false;
+	}
+      if (!gfc_boz2int (i, j->ts.kind))
+	return false;
+    }
 
   /* If j is BOZ and i is integer, convert j to type of i.  */
-  if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
-      && !gfc_boz2int (j, i->ts.kind))
-    return false;
+  if (j->ts.type == BT_BOZ)
+    {
+      if (i->ts.type != BT_INTEGER)
+	{
+	  gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
+		     gfc_current_intrinsic_arg[0]->name,
+		     gfc_current_intrinsic, &j->where);
+	  reset_boz (j);
+	  return false;
+	}
+      if (!gfc_boz2int (j, i->ts.kind))
+	return false;
+    }
 
   if (!same_type_check (i, 0, j, 1, false))
     return false;
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 276705)
+++ gcc/fortran/resolve.c	(working copy)
@@ -3243,19 +3243,14 @@  resolve_function (gfc_expr *expr)
     return t;
 
   /* Walk the argument list looking for invalid BOZ.  */
-  if (expr->value.function.esym)
-    {
-      gfc_actual_arglist *a;
-
-      for (a = expr->value.function.actual; a; a = a->next)
-	if (a->expr && a->expr->ts.type == BT_BOZ)
-	  {
-	    gfc_error ("A BOZ literal constant at %L cannot appear as an "
-			"actual argument in a function reference",
-			&a->expr->where);
-	    return false;
-	  }
-    }
+  for (arg = expr->value.function.actual; arg; arg = arg->next)
+    if (arg->expr && arg->expr->ts.type == BT_BOZ)
+      {
+	gfc_error ("A BOZ literal constant at %L cannot appear as an "
+		   "actual argument in a function reference",
+		   &arg->expr->where);
+	return false;
+      }
 
   temp = need_full_assumed_size;
   need_full_assumed_size = 0;
Index: gcc/testsuite/gfortran.dg/gnu_logical_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/gnu_logical_2.f90	(revision 276705)
+++ gcc/testsuite/gfortran.dg/gnu_logical_2.f90	(working copy)
@@ -7,22 +7,22 @@ 
 
   print *, and(i,i)
   print *, and(l,l)
-  print *, and(i,r) ! { dg-error "must be the same type" }
-  print *, and(c,l) ! { dg-error "must be the same type" }
+  print *, and(i,r) ! { dg-error "must be INTEGER, LOGICAL, or a BOZ" }
+  print *, and(c,l) ! { dg-error "must be INTEGER, LOGICAL, or a BOZ" }
   print *, and(i,l) ! { dg-error "must be the same type" }
   print *, and(l,i) ! { dg-error "must be the same type" }
 
   print *, or(i,i)
   print *, or(l,l)
-  print *, or(i,r) ! { dg-error "must be the same type" }
-  print *, or(c,l) ! { dg-error "must be the same type" }
+  print *, or(i,r) ! { dg-error "must be INTEGER, LOGICAL, or a BOZ" }
+  print *, or(c,l) ! { dg-error "must be INTEGER, LOGICAL, or a BOZ" }
   print *, or(i,l) ! { dg-error "must be the same type" }
   print *, or(l,i) ! { dg-error "must be the same type" }
 
   print *, xor(i,i)
   print *, xor(l,l)
-  print *, xor(i,r) ! { dg-error "must be the same type" }
-  print *, xor(c,l) ! { dg-error "must be the same type" }
+  print *, xor(i,r) ! { dg-error "must be INTEGER, LOGICAL, or a BOZ" }
+  print *, xor(c,l) ! { dg-error "must be INTEGER, LOGICAL, or a BOZ" }
   print *, xor(i,l) ! { dg-error "must be the same type" }
   print *, xor(l,i) ! { dg-error "must be the same type" }
 
Index: gcc/testsuite/gfortran.dg/pr81509_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr81509_2.f90	(revision 276705)
+++ gcc/testsuite/gfortran.dg/pr81509_2.f90	(working copy)
@@ -13,6 +13,6 @@  k = ieor(z'ade',i)
 k = ior(i,z'1111')
 k = ior(i,k)                  ! { dg-error "different kind type parameters" }
 k = and(i,k)                  ! { dg-error "must be the same type" }
-k = and(a,z'1234')            ! { dg-error "must be the same type" }
+k = and(a,z'1234')            ! { dg-error "must be INTEGER" }
 end program foo
 
Index: gcc/testsuite/gfortran.dg/pr92018.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr92018.f90	(nonexistent)
+++ gcc/testsuite/gfortran.dg/pr92018.f90	(working copy)
@@ -0,0 +1,9 @@ 
+! { dg-do compile }
+! PR fortran/92018
+subroutine sub (f)
+   integer :: f
+   print *, f(b'11') ! { dg-error "cannot appear as an actual" }
+   print *, f(o'11') ! { dg-error "cannot appear as an actual" }
+   print *, f(z'11') ! { dg-error "cannot appear as an actual" }
+end
+