From a5baf71b0a5bd79923c095cf81218b8194008f60 Mon Sep 17 00:00:00 2001
From: Paul Thomas <pault@gcc.gnu.org>
Date: Sun, 2 Aug 2020 10:57:59 +0100
Subject: [PATCH] This patch fixes PR96320. See the explanatory comment in the
 testcase.

2020-08-01  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR target/96320
	* interface.c (gfc_check_dummy_characteristics): If a module
	procedure arrives with assumed shape in the interface and
	deferred shape in the procedure itself, update the latter and
	copy the lower bounds.

gcc/testsuite/
	PR target/96320
	* gfortran.dg/module_procedure_4.f90 : New test.
---
 gcc/fortran/interface.c                       | 19 +++++-
 .../gfortran.dg/module_procedure_4.f90        | 63 +++++++++++++++++++
 2 files changed, 79 insertions(+), 3 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/module_procedure_4.f90

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index e51820918b8..7985fc70fd4 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1466,6 +1466,19 @@ gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
       int i, compval;
       gfc_expr *shape1, *shape2;
 
+      /* Sometimes the ambiguity between deferred shape and assumed shape
+	 does not get resolved in module procedures, where the only explicit
+	 declaration of the dummy is in the interface.  */
+      if (s1->ns->proc_name && s1->ns->proc_name->attr.module_procedure
+	  && s1->as->type == AS_ASSUMED_SHAPE
+	  && s2->as->type == AS_DEFERRED)
+	{
+	  s2->as->type = AS_ASSUMED_SHAPE;
+	  for (i = 0; i < s2->as->rank; i++)
+	    if (s1->as->lower[i] != NULL)
+	      s2->as->lower[i] = gfc_copy_expr (s1->as->lower[i]);
+	}
+
       if (s1->as->type != s2->as->type)
 	{
 	  snprintf (errmsg, err_len, "Shape mismatch in argument '%s'",
@@ -2617,7 +2630,7 @@ 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))))
 	{
@@ -2708,7 +2721,7 @@ 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))))
 	{
@@ -3965,7 +3978,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
   if (!gfc_compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental,
 				  sym->attr.proc == PROC_ST_FUNCTION, where))
     return false;
- 
+
   if (!check_intents (dummy_args, *ap))
     return false;
 
diff --git a/gcc/testsuite/gfortran.dg/module_procedure_4.f90 b/gcc/testsuite/gfortran.dg/module_procedure_4.f90
new file mode 100644
index 00000000000..c30bbfe5d50
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/module_procedure_4.f90
@@ -0,0 +1,63 @@
+! { dg-do run }
+!
+! Test the fix for PR96320 in which the assumed shape of 'arg' in the
+! interface for 'bar' was mirrored by the 'arg' in the module procedure
+! incorrectly have deferred shape.
+!
+! Contributed by Damian Rouson  <damian@sourceryinstitute.org>
+!
+module foobar
+  type foo
+  contains
+    procedure, nopass :: bar1
+    procedure, nopass :: bar2
+    procedure, nopass :: bar3
+  end type
+
+  interface
+
+    module subroutine bar1(arg)
+      character(len=*) arg(:)
+    end subroutine
+
+    module subroutine bar2(arg)
+      character(len=*) arg(3:)
+    end subroutine
+
+    module subroutine bar3(arg)
+      character(len=*) arg(2)
+    end subroutine
+
+  end interface
+contains
+
+  module procedure bar1
+    if (lbound(arg, 1) .ne. 1) stop 1
+    if (arg(3) .ne. 'hijk') stop 2
+  end procedure
+
+! Make sure that the lower bound of an assumed shape array dummy,
+! if defined, is passed to the module procedure.
+
+  module procedure bar2
+    if (lbound(arg, 1) .ne. 3) stop 3
+    if (arg(3) .ne. 'abcd') stop 4
+  end procedure
+
+! This makes sure that an dummy with explicit shape has the upper
+! bound correctly set in the module procedure.
+
+  module procedure bar3
+    if (lbound(arg, 1) .ne. 1) stop 5
+    if (arg(3) .ne. 'hijk') stop 6       ! { dg-warning "is out of bounds" }
+  end procedure
+
+end module
+
+  use foobar
+  character(4) :: list(3) = ['abcd', 'efgh' , 'hijk']
+  type(foo) :: f
+  call f%bar1(list)
+  call f%bar2(list)
+  call f%bar3(list)
+end
-- 
2.30.2