Fortran: Fix bind(C) character length checks

gcc/fortran/ChangeLog:

	* decl.c (gfc_verify_c_interop_param): Update for F2008 + F2018
	changes; reject unsupported bits with 'Error: Sorry,'.
	* trans-expr.c (gfc_conv_procedure_call): Fix condition to
	For using CFI descriptor with characters.

gcc/testsuite/ChangeLog:

	* gfortran.dg/iso_c_binding_char_1.f90: Update dg-error.
	* gfortran.dg/pr32599.f03: Use -std=-f2003 + update comment.
	* gfortran.dg/bind_c_char_10.f90: New test.
	* gfortran.dg/bind_c_char_6.f90: New test.
	* gfortran.dg/bind_c_char_7.f90: New test.
	* gfortran.dg/bind_c_char_8.f90: New test.
	* gfortran.dg/bind_c_char_9.f90: New test.

2 files changed, 112 insertions, 19 deletions

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 413c7a7..05081c4 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1552,20 +1552,115 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
 	    }
 
           /* Character strings are only C interoperable if they have a
-             length of 1.  */
-          if (sym->ts.type == BT_CHARACTER && !sym->attr.dimension)
+	     length of 1.  However, as argument they are either iteroperable
+	     when passed as descriptor (which requires len=: or len=*) or
+	     when having a constant length or are always passed by
+	     descriptor.  */
+	  if (sym->ts.type == BT_CHARACTER)
 	    {
 	      gfc_charlen *cl = sym->ts.u.cl;
-	      if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
-                  || mpz_cmp_si (cl->length->value.integer, 1) != 0)
+
+	      if (sym->attr.allocatable || sym->attr.pointer)
 		{
-		  gfc_error ("Character argument %qs at %L "
-			     "must be length 1 because "
-			     "procedure %qs is BIND(C)",
-			     sym->name, &sym->declared_at,
-			     sym->ns->proc_name->name);
+		  /* F2018, 18.3.6 (6).  */
+		  if (!sym->ts.deferred)
+		    {
+		      if (sym->attr.allocatable)
+			gfc_error ("Allocatable character dummy argument %qs "
+				   "at %L must have deferred length as "
+				   "procedure %qs is BIND(C)", sym->name,
+				   &sym->declared_at, sym->ns->proc_name->name);
+		      else
+			gfc_error ("Pointer character dummy argument %qs at %L "
+				   "must have deferred length as procedure %qs "
+				   "is BIND(C)", sym->name, &sym->declared_at,
+				   sym->ns->proc_name->name);
+		      retval = false;
+		    }
+		  else if (!gfc_notify_std (GFC_STD_F2018,
+					    "Deferred-length character dummy "
+					    "argument %qs at %L of procedure "
+					    "%qs with BIND(C) attribute",
+					    sym->name, &sym->declared_at,
+					    sym->ns->proc_name->name))
+		    retval = false;
+		  else if (!sym->attr.dimension)
+		    {
+		      /* FIXME: Use CFI array descriptor for scalars.  */
+		      gfc_error ("Sorry, deferred-length scalar character dummy "
+				 "argument %qs at %L of procedure %qs with "
+				 "BIND(C) not yet supported", sym->name,
+				 &sym->declared_at, sym->ns->proc_name->name);
+		      retval = false;
+		    }
+		}
+	      else if (sym->attr.value
+		       && (!cl || !cl->length
+			   || cl->length->expr_type != EXPR_CONSTANT
+			   || mpz_cmp_si (cl->length->value.integer, 1) != 0))
+		{
+		  gfc_error ("Character dummy argument %qs at %L must be "
+			     "of length 1 as it has the VALUE attribute",
+			     sym->name, &sym->declared_at);
 		  retval = false;
 		}
+	      else if (!cl || !cl->length)
+		{
+		  /* Assumed length; F2018, 18.3.6 (5)(2).
+		     Uses the CFI array descriptor.  */
+		  if (!gfc_notify_std (GFC_STD_F2018,
+				      "Assumed-length character dummy argument "
+				      "%qs at %L of procedure %qs with BIND(C) "
+				      "attribute", sym->name, &sym->declared_at,
+				      sym->ns->proc_name->name))
+		    retval = false;
+		  else if (!sym->attr.dimension
+			   || sym->as->type == AS_ASSUMED_SIZE
+			   || sym->as->type == AS_EXPLICIT)
+		    {
+		      /* FIXME: Valid - should use the CFI array descriptor, but
+			 not yet handled for scalars and assumed-/explicit-size
+			 arrays.  */
+		      gfc_error ("Sorry, character dummy argument %qs at %L "
+				 "with assumed length is not yet supported for "
+				 "procedure %qs with BIND(C) attribute",
+				 sym->name, &sym->declared_at,
+				 sym->ns->proc_name->name);
+		      retval = false;
+		    }
+		}
+	      else if (cl->length->expr_type != EXPR_CONSTANT)
+		{
+		  /* F2018, 18.3.6, (5), item 4.  */
+		  if (!sym->attr.dimension
+		      || sym->as->type == AS_ASSUMED_SIZE
+		      || sym->as->type == AS_EXPLICIT)
+		    {
+		      gfc_error ("Character dummy argument %qs at %L must be "
+				 "of constant length or assumed length, "
+				 "unless it has assumed shape or assumed rank, "
+				 "as procedure %qs has the BIND(C) attribute",
+				 sym->name, &sym->declared_at,
+				 sym->ns->proc_name->name);
+		      retval = false;
+		    }
+		  else if (!gfc_notify_std (GFC_STD_F2018,
+					    "Character dummy argument %qs at "
+					    "%L with nonconstant length as "
+					    "procedure %qs is BIND(C)",
+					    sym->name, &sym->declared_at,
+					    sym->ns->proc_name->name))
+		    retval = false;
+		}
+	     else if (mpz_cmp_si (cl->length->value.integer, 1) != 0
+		      && !gfc_notify_std (GFC_STD_F2008,
+					  "Character dummy argument %qs at %L "
+					  "with length greater than 1 for "
+					  "procedure %qs with BIND(C) "
+					  "attribute",
+					  sym->name, &sym->declared_at,
+					  sym->ns->proc_name->name))
+	       retval = false;
 	    }
 
 	  /* We have to make sure that any param to a bind(c) routine does
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 9e0dcde..b18a9ec 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5757,18 +5757,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
        arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
     {
       bool finalized = false;
-      bool non_unity_length_string = false;
+      bool assumed_length_string = false;
       tree derived_array = NULL_TREE;
 
       e = arg->expr;
       fsym = formal ? formal->sym : NULL;
       parm_kind = MISSING;
 
-      if (fsym && fsym->ts.type == BT_CHARACTER && fsym->ts.u.cl
-	  && (!fsym->ts.u.cl->length
-	      || fsym->ts.u.cl->length->expr_type != EXPR_CONSTANT
-	      || mpz_cmp_si (fsym->ts.u.cl->length->value.integer, 1) != 0))
-	non_unity_length_string = true;
+      if (fsym && fsym->ts.type == BT_CHARACTER
+	  && (!fsym->ts.u.cl || !fsym->ts.u.cl->length))
+	assumed_length_string = true;
 
       /* If the procedure requires an explicit interface, the actual
 	 argument is passed according to the corresponding formal
@@ -6002,8 +6000,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
 	      else if (sym->attr.is_bind_c && e
 		       && (is_CFI_desc (fsym, NULL)
-			   || non_unity_length_string))
-		/* Implement F2018, C.12.6.1: paragraph (2).  */
+			   || assumed_length_string))
+		/* Implement F2018, 18.3.6, list item (5), bullet point 2.  */
 		gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
 
 	      else if (fsym && fsym->attr.value)
@@ -6447,8 +6445,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		}
 
 	      if (sym->attr.is_bind_c && e
-		  && (is_CFI_desc (fsym, NULL) || non_unity_length_string))
-		/* Implement F2018, C.12.6.1: paragraph (2).  */
+		  && (is_CFI_desc (fsym, NULL) || assumed_length_string))
+		/* Implement F2018, 18.3.6, list item (5), bullet point 2.  */
 		gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
 
 	      else if (e->expr_type == EXPR_VARIABLE