re PR fortran/92004 (Rejection of different ranks for dummy array argument where actual argument is an element)

2019-10-14  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/92004
	* array.c (expand_constructor): Set from_constructor on
	expression.
	* gfortran.h (gfc_symbol): Add maybe_array.
	(gfc_expr): Add from_constructor.
	* interface.c (maybe_dummy_array_arg): New function.
	(compare_parameter): If the formal argument is generated from a
	call, check the conditions where an array element could be
	passed to an array.  Adjust error message for assumed-shape
	or pointer array.  Use correct language for assumed shaped arrays.
	(gfc_get_formal_from_actual_arglist): Set maybe_array on the
	symbol if the actual argument is an array element fulfilling
	the conditions of 15.5.2.4.

2019-10-14  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/92004
	* gfortran.dg/argument_checking_24.f90: New test.
	* gfortran.dg/abstract_type_6.f90: Add error message.
	* gfortran.dg/argument_checking_11.f90: Correct wording
	in error message.
	* gfortran.dg/argumeent_checking_13.f90: Likewise.
	* gfortran.dg/interface_40.f90: Add error message.

From-SVN: r276972

1 files changed, 95 insertions, 5 deletions

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 3313e72..919c95a 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2229,6 +2229,67 @@ argument_rank_mismatch (const char *name, locus *where,
 }
 
 
+/* Under certain conditions, a scalar actual argument can be passed
+   to an array dummy argument - see F2018, 15.5.2.4, paragraph 14.
+   This function returns true for these conditions so that an error
+   or warning for this can be suppressed later.  Always return false
+   for expressions with rank > 0.  */
+
+bool
+maybe_dummy_array_arg (gfc_expr *e)
+{
+  gfc_symbol *s;
+  gfc_ref *ref;
+  bool array_pointer = false;
+  bool assumed_shape = false;
+  bool scalar_ref = true;
+
+  if (e->rank > 0)
+    return false;
+
+  if (e->ts.type == BT_CHARACTER && e->ts.kind == 1)
+    return true;
+
+  /* If this comes from a constructor, it has been an array element
+     originally.  */
+
+  if (e->expr_type == EXPR_CONSTANT)
+    return e->from_constructor;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    return false;
+
+  s = e->symtree->n.sym;
+
+  if (s->attr.dimension)
+    {
+      scalar_ref = false;
+      array_pointer = s->attr.pointer;
+    }
+
+  if (s->as && s->as->type == AS_ASSUMED_SHAPE)
+    assumed_shape = true;
+
+  for (ref=e->ref; ref; ref=ref->next)
+    {
+      if (ref->type == REF_COMPONENT)
+	{
+	  symbol_attribute *attr;
+	  attr = &ref->u.c.component->attr;
+	  if (attr->dimension)
+	    {
+	      array_pointer = attr->pointer;
+	      assumed_shape = false;
+	      scalar_ref = false;
+	    }
+	  else
+	    scalar_ref = true;
+	}
+    }
+
+  return !(scalar_ref || array_pointer || assumed_shape);
+}
+
 /* Given a symbol of a formal argument list and an expression, see if
    the two are compatible as arguments.  Returns true if
    compatible, false if not compatible.  */
@@ -2544,7 +2605,9 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       || (actual->rank == 0 && formal->attr.dimension
 	  && gfc_is_coindexed (actual)))
     {
-      if (where)
+      if (where 
+	  && (!formal->attr.artificial || (!formal->maybe_array
+					   && !maybe_dummy_array_arg (actual))))
 	{
 	  locus *where_formal;
 	  if (formal->attr.artificial)
@@ -2594,9 +2657,17 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
     {
       if (where)
-	gfc_error ("Element of assumed-shaped or pointer "
-		   "array passed to array dummy argument %qs at %L",
-		   formal->name, &actual->where);
+	{
+	  if (formal->attr.artificial)
+	    gfc_error ("Element of assumed-shape or pointer array "
+		       "as actual argument at %L can not correspond to "
+		       "actual argument at %L ",
+		       &actual->where, &formal->declared_at);
+	  else
+	    gfc_error ("Element of assumed-shape or pointer "
+		       "array passed to array dummy argument %qs at %L",
+		       formal->name, &actual->where);
+	}
       return false;
     }
 
@@ -2625,7 +2696,9 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 
   if (ref == NULL && actual->expr_type != EXPR_NULL)
     {
-      if (where)
+      if (where 
+	  && (!formal->attr.artificial || (!formal->maybe_array
+					   && !maybe_dummy_array_arg (actual))))
 	{
 	  locus *where_formal;
 	  if (formal->attr.artificial)
@@ -3717,6 +3790,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 {
   gfc_actual_arglist *a;
   gfc_formal_arglist *dummy_args;
+  bool implicit = false;
 
   /* Warn about calls with an implicit interface.  Special case
      for calling a ISO_C_BINDING because c_loc and c_funloc
@@ -3724,6 +3798,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
      explicitly declared at all if requested.  */
   if (sym->attr.if_source == IFSRC_UNKNOWN && !sym->attr.is_iso_c)
     {
+      implicit = true;
       if (sym->ns->has_implicit_none_export && sym->attr.proc == PROC_UNKNOWN)
 	{
 	  const char *guessed
@@ -3778,6 +3853,19 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 	  if (a->expr && a->expr->error)
 	    return false;
 
+	  /* F2018, 15.4.2.2 Explicit interface is required for a
+	     polymorphic dummy argument, so there is no way to
+	     legally have a class appear in an argument with an
+	     implicit interface.  */
+
+	  if (implicit && a->expr && a->expr->ts.type == BT_CLASS)
+	    {
+	      gfc_error ("Explicit interface required for polymorphic "
+			 "argument at %L",&a->expr->where);
+	      a->expr->error = 1;
+	      break;
+	    }
+
 	  /* Skip g77 keyword extensions like %VAL, %REF, %LOC.  */
 	  if (a->name != NULL && a->name[0] != '%')
 	    {
@@ -5228,6 +5316,8 @@ gfc_get_formal_from_actual_arglist (gfc_symbol *sym,
 		  s->as->upper[0] = NULL;
 		  s->as->type = AS_ASSUMED_SIZE;
 		}
+	      else
+		s->maybe_array = maybe_dummy_array_arg (a->expr);
 	    }
 	  s->attr.dummy = 1;
 	  s->declared_at = a->expr->where;