[Patch, Fortran] PR45859 - Permit array elements to coarray dummy arguments

[Tobias Burnus <tobias.burnus@physik.fu-berlin.de>]

[-- Attachment #1: Type: text/plain, Size: 923 bytes --]

This patch permits

   interface
      subroutine sub (x)
         real x(10)[*]
      end subroutine
   end interface
   real :: x(100)[*]
   call sub (x(10))
   end

where one passes an array element ("x(10)") of a contiguous array to a
coarray dummy argument. That's permitted per interpretation request
F08/0048, which ended up in Fortran 2008's Corrigendum 2 - and is also
in the current Fortran 2015 drafts:

"If the dummy argument is an array coarray that has the CONTIGUOUS attribute
 or is not of assumed shape, the corresponding actual argument shall be
 simply contiguous or an element of a simply contiguous array."

the "or ..." of the last line was added in the corrigendum.


I hope and think that I got the true/false of the other users correct - in
most cases, it probably doesn't matter as the caller is only reached for
expr->rank > 0.

Build and regtested on x86-64-gnu-linux.
OK for the trunk?

Tobias

[-- Attachment #2: coarray.diff --]
[-- Type: text/x-diff, Size: 6163 bytes --]

gcc/fortran
	PR fortran/45859
	* expr.c (gfc_is_simply_contiguous): Optionally permit array elements.
	(gfc_check_pointer_assign): Update call.
	* interface.c (compare_parameter): Ditto.
	* trans-array.c (gfc_conv_array_parameter): Ditto.
	* trans-intrinsic.c (gfc_conv_intrinsic_transfer,
	conv_isocbinding_function): Ditto.
	* gfortran.h (gfc_is_simply_contiguous):

gcc/testsuite/
	PR fortran/45859
	* gfortran.dg/coarray_argument_1.f90: New.

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 2aeb0b5..5dd90ef 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3683,7 +3683,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 	 and F2008 must be allowed.  */
       if (rvalue->rank != 1)
 	{
-	  if (!gfc_is_simply_contiguous (rvalue, true))
+	  if (!gfc_is_simply_contiguous (rvalue, true, false))
 	    {
 	      gfc_error ("Rank remapping target must be rank 1 or"
 			 " simply contiguous at %L", &rvalue->where);
@@ -4601,7 +4601,7 @@ gfc_has_ultimate_pointer (gfc_expr *e)
    a "(::1)" is accepted.  */
 
 bool
-gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
+gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element)
 {
   bool colon;
   int i;
@@ -4615,7 +4615,7 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
   else if (expr->expr_type != EXPR_VARIABLE)
     return false;
 
-  if (expr->rank == 0)
+  if (!permit_element && expr->rank == 0)
     return false;
 
   for (ref = expr->ref; ref; ref = ref->next)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 9f61e45..d203c32 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2982,7 +2982,7 @@ void gfc_free_actual_arglist (gfc_actual_arglist *);
 gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
 const char *gfc_extract_int (gfc_expr *, int *);
 bool is_subref_array (gfc_expr *);
-bool gfc_is_simply_contiguous (gfc_expr *, bool);
+bool gfc_is_simply_contiguous (gfc_expr *, bool, bool);
 bool gfc_check_init_expr (gfc_expr *);
 
 gfc_expr *gfc_build_conversion (gfc_expr *);
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index f74239d..bfd5d36 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2020,7 +2020,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 
   /* F2008, C1241.  */
   if (formal->attr.pointer && formal->attr.contiguous
-      && !gfc_is_simply_contiguous (actual, true))
+      && !gfc_is_simply_contiguous (actual, true, false))
     {
       if (where)
 	gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
@@ -2131,15 +2131,17 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 
   if (formal->attr.codimension)
     {
-      /* F2008, 12.5.2.8.  */
+      /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048).  */
+      /* F2015, 12.5.2.8.  */
       if (formal->attr.dimension
 	  && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
 	  && gfc_expr_attr (actual).dimension
-	  && !gfc_is_simply_contiguous (actual, true))
+	  && !gfc_is_simply_contiguous (actual, true, true))
 	{
 	  if (where)
 	    gfc_error ("Actual argument to %qs at %L must be simply "
-		       "contiguous", formal->name, &actual->where);
+		       "contiguous or an element of such an array",
+		       formal->name, &actual->where);
 	  return 0;
 	}
 
@@ -2179,7 +2181,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       && (actual->symtree->n.sym->attr.asynchronous
          || actual->symtree->n.sym->attr.volatile_)
       &&  (formal->attr.asynchronous || formal->attr.volatile_)
-      && actual->rank && formal->as && !gfc_is_simply_contiguous (actual, true)
+      && actual->rank && formal->as
+      && !gfc_is_simply_contiguous (actual, true, false)
       && ((formal->as->type != AS_ASSUMED_SHAPE
 	   && formal->as->type != AS_ASSUMED_RANK && !formal->attr.pointer)
 	  || formal->attr.contiguous))
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 69f6e19..6e24e2e 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -7386,7 +7386,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
 		  && ref->u.ar.as->type != AS_ASSUMED_RANK
 		  && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
 		      ||
-	     gfc_is_simply_contiguous (expr, false));
+	     gfc_is_simply_contiguous (expr, false, true));
 
   no_pack = contiguous && no_pack;
 
@@ -7464,7 +7464,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
     }
 
   if (g77 || (fsym && fsym->attr.contiguous
-	      && !gfc_is_simply_contiguous (expr, false)))
+	      && !gfc_is_simply_contiguous (expr, false, true)))
     {
       tree origptr = NULL_TREE;
 
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 21efe44..743148e 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -6244,7 +6244,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
       source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
 
       /* Repack the source if not simply contiguous.  */
-      if (!gfc_is_simply_contiguous (arg->expr, false))
+      if (!gfc_is_simply_contiguous (arg->expr, false, true))
 	{
 	  tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
 
@@ -7142,7 +7142,7 @@ conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
     {
       if (arg->expr->rank == 0)
 	gfc_conv_expr_reference (se, arg->expr);
-      else if (gfc_is_simply_contiguous (arg->expr, false))
+      else if (gfc_is_simply_contiguous (arg->expr, false, false))
 	gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL);
       else
 	{
diff --git a/gcc/testsuite/gfortran.dg/coarray_argument_1.f90 b/gcc/testsuite/gfortran.dg/coarray_argument_1.f90
new file mode 100644
index 0000000..511da29
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_argument_1.f90
@@ -0,0 +1,14 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=lib" }
+!
+! PR fortran/45859
+! Interpretation request F08/0048
+!
+   interface
+      subroutine sub (x)
+         real x(10)[*]
+      end subroutine
+   end interface
+   real :: x(100)[*]
+   call sub (x(10))
+   end