Fortran: Add diagnostic for F2018:C839 (TS29113:C535c)

2021-10-08 Sandra Loosemore  <sandra@codesourcery.com>

	PR fortran/54753

gcc/fortran/
	* interface.c (gfc_compare_actual_formal): Add diagnostic
	for F2018:C839.  Refactor shared code and fix bugs with class
	array info lookup, and extend similar diagnostic from PR94110
	to also cover class types.

gcc/testsuite/
	* gfortran.dg/c-interop/c535c-1.f90: Rewrite and expand.
	* gfortran.dg/c-interop/c535c-2.f90: Remove xfails.
	* gfortran.dg/c-interop/c535c-3.f90: Likewise.
	* gfortran.dg/c-interop/c535c-4.f90: Likewise.
	* gfortran.dg/PR94110.f90: Extend to cover class types.

1 files changed, 89 insertions, 11 deletions

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index a2fea0e..2a71da7 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -3061,6 +3061,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
   unsigned long actual_size, formal_size;
   bool full_array = false;
   gfc_array_ref *actual_arr_ref;
+  gfc_array_spec *fas, *aas;
+  bool pointer_dummy, pointer_arg, allocatable_arg;
 
   actual = *ap;
 
@@ -3329,13 +3331,60 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  return false;
 	}
 
-      if (f->sym->as
-	  && (f->sym->as->type == AS_ASSUMED_SHAPE
-	      || f->sym->as->type == AS_DEFERRED
-	      || (f->sym->as->type == AS_ASSUMED_RANK && f->sym->attr.pointer))
-	  && a->expr->expr_type == EXPR_VARIABLE
-	  && a->expr->symtree->n.sym->as
-	  && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
+      /* Class array variables and expressions store array info in a
+	 different place from non-class objects; consolidate the logic
+	 to access it here instead of repeating it below.  Note that
+	 pointer_arg and allocatable_arg are not fully general and are
+	 only used in a specific situation below with an assumed-rank
+	 argument.  */
+      if (f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym))
+	{
+	  gfc_component *classdata = CLASS_DATA (f->sym);
+	  fas = classdata->as;
+	  pointer_dummy = classdata->attr.class_pointer;
+	}
+      else
+	{
+	  fas = f->sym->as;
+	  pointer_dummy = f->sym->attr.pointer;
+	}
+
+      if (a->expr->expr_type != EXPR_VARIABLE)
+	{
+	  aas = NULL;
+	  pointer_arg = false;
+	  allocatable_arg = false;
+	}
+      else if (a->expr->ts.type == BT_CLASS
+	       && a->expr->symtree->n.sym
+	       && CLASS_DATA (a->expr->symtree->n.sym))
+	{
+	  gfc_component *classdata = CLASS_DATA (a->expr->symtree->n.sym);
+	  aas = classdata->as;
+	  pointer_arg = classdata->attr.class_pointer;
+	  allocatable_arg = classdata->attr.allocatable;
+	}
+      else
+	{
+	  aas = a->expr->symtree->n.sym->as;
+	  pointer_arg = a->expr->symtree->n.sym->attr.pointer;
+	  allocatable_arg = a->expr->symtree->n.sym->attr.allocatable;
+	}
+
+      /* F2018:9.5.2(2) permits assumed-size whole array expressions as
+	 actual arguments only if the shape is not required; thus it
+	 cannot be passed to an assumed-shape array dummy.
+	 F2018:15.5.2.(2) permits passing a nonpointer actual to an
+	 intent(in) pointer dummy argument and this is accepted by
+	 the compare_pointer check below, but this also requires shape
+	 information.
+	 There's more discussion of this in PR94110.  */
+      if (fas
+	  && (fas->type == AS_ASSUMED_SHAPE
+	      || fas->type == AS_DEFERRED
+	      || (fas->type == AS_ASSUMED_RANK && pointer_dummy))
+	  && aas
+	  && aas->type == AS_ASSUMED_SIZE
 	  && (a->expr->ref == NULL
 	      || (a->expr->ref->type == REF_ARRAY
 		  && a->expr->ref->u.ar.type == AR_FULL)))
@@ -3346,6 +3395,35 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  return false;
 	}
 
+      /* Diagnose F2018 C839 (TS29113 C535c).  Here the problem is
+	 passing an assumed-size array to an INTENT(OUT) assumed-rank
+	 dummy when it doesn't have the size information needed to run
+	 initializers and finalizers.  */
+      if (f->sym->attr.intent == INTENT_OUT
+	  && fas
+	  && fas->type == AS_ASSUMED_RANK
+	  && aas
+	  && ((aas->type == AS_ASSUMED_SIZE
+	       && (a->expr->ref == NULL
+		   || (a->expr->ref->type == REF_ARRAY
+		       && a->expr->ref->u.ar.type == AR_FULL)))
+	      || (aas->type == AS_ASSUMED_RANK
+		  && !pointer_arg
+		  && !allocatable_arg))
+	  && (a->expr->ts.type == BT_CLASS
+	      || (a->expr->ts.type == BT_DERIVED
+		  && (gfc_is_finalizable (a->expr->ts.u.derived, NULL)
+		      || gfc_has_ultimate_allocatable (a->expr)
+		      || gfc_has_default_initializer
+			   (a->expr->ts.u.derived)))))
+	{
+	  if (where)
+	    gfc_error ("Actual argument to assumed-rank INTENT(OUT) "
+		       "dummy %qs at %L cannot be of unknown size",
+		       f->sym->name, where);
+	  return false;
+	}
+
       if (a->expr->expr_type != EXPR_NULL
 	  && compare_pointer (f->sym, a->expr) == 0)
 	{
@@ -3479,7 +3557,7 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  && a->expr->expr_type == EXPR_VARIABLE
 	  && a->expr->symtree->n.sym->as
 	  && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
-	  && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
+	  && !(fas && fas->type == AS_ASSUMED_SHAPE))
 	{
 	  if (where)
 	    gfc_error ("Assumed-shape actual argument at %L is "
@@ -3496,7 +3574,7 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 
       if (f->sym->attr.volatile_
 	  && actual_arr_ref && actual_arr_ref->type == AR_SECTION
-	  && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
+	  && !(fas && fas->type == AS_ASSUMED_SHAPE))
 	{
 	  if (where)
 	    gfc_error ("Array-section actual argument at %L is "
@@ -3514,8 +3592,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  && a->expr->expr_type == EXPR_VARIABLE
 	  && a->expr->symtree->n.sym->attr.pointer
 	  && a->expr->symtree->n.sym->as
-	  && !(f->sym->as
-	       && (f->sym->as->type == AS_ASSUMED_SHAPE
+	  && !(fas
+	       && (fas->type == AS_ASSUMED_SHAPE
 		   || f->sym->attr.pointer)))
 	{
 	  if (where)