Fix PR 93956, wrong pointer when returned via function.

This one took a bit of detective work.  When array pointers point
to components of derived types, we currently set the span field
and then create an array temporary when we pass the array
pointer to a procedure as a non-pointer or non-target argument.
(This is inefficient, but that's for another release).

Now, the compiler detected this case when there was a direct assignment
like p => a%b, but not when p was returned either as a function result
or via an argument.  This patch fixes that.

2020-04-23  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/93956
	* expr.c (gfc_check_pointer_assign): Also set subref_array_pointer
	when a function returns a pointer.
	* interface.c (gfc_set_subref_array_pointer_arg): New function.
	(gfc_procedure_use): Call it.

2020-04-23  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/93956
	* gfortran.dg/pointer_assign_13.f90: New test.

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 9d06c2e7fd33de1a38fdab6a1693d0d1f4382d32..2274ce05e0359e6ef3b14e1da87de5bb5a404a5c 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2020-04-23  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR fortran/93956
+       * expr.c (gfc_check_pointer_assign): Also set subref_array_pointer
+       when a function returns a pointer.
+       * interface.c (gfc_set_subref_array_pointer_arg): New function.
+       (gfc_procedure_use): Call it.
+
 2020-04-22  Fritz Reese  <foreese@gcc.gnu.org>
 
        * trigd_fe.inc: Use mpfr to compute cosd(30) rather than a host-

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index a9fa03ad153ff8d1bd6f51bfba991548c1cfa002..618c98a592ddbce7354ddd85e3289e636ad98332 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4242,8 +4242,11 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue,
   if (rvalue->expr_type == EXPR_NULL)
     return true;
 
-  if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
-    lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
+  /* A function may also return subref arrray pointer.  */
+
+  if ((rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
+      || rvalue->expr_type == EXPR_FUNCTION)
+      lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
 
   attr = gfc_expr_attr (rvalue);
 

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index ba1c8bc322eade13caf726aae58b242e375bb02a..58b7abf31e9119d2783eea57ddaba5cebc476a2a 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -3788,6 +3788,36 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
   return true;
 }
 
+/* Go through the argument list of a procedure and look for
+   pointers which may be set, possibly introducing a span.  */
+
+static void
+gfc_set_subref_array_pointer_arg (gfc_formal_arglist *dummy_args,
+                                 gfc_actual_arglist *actual_args)
+{
+  gfc_formal_arglist *f;
+  gfc_actual_arglist *a;
+  gfc_symbol *a_sym;
+  for (f = dummy_args, a = actual_args; f && a ; f = f->next, a = a->next)
+    {
+
+      if (f->sym == NULL)
+       continue;
+
+      if (!f->sym->attr.pointer || f->sym->attr.intent == INTENT_IN)
+       continue;
+
+      if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
+       continue;
+      a_sym = a->expr->symtree->n.sym;
+
+      if (!a_sym->attr.pointer)
+       continue;
+
+      a_sym->attr.subref_array_pointer = 1;
+    }
+  return;
+}
 
 /* Check how a procedure is used against its interface.  If all goes
    well, the actual argument list will also end up being properly
@@ -3968,6 +3998,10 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
   if (warn_aliasing)
     check_some_aliasing (dummy_args, *ap);
 
+  /* Set the subref_array_pointer_arg if needed.  */
+  if (dummy_args)
+    gfc_set_subref_array_pointer_arg (dummy_args, *ap);
+
   return true;
 }
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index cb21f55287502cb82b19bd6608878faf01ae2dab..25515c9aa3a90cfcf9491676dfaea284a348a8c9 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,4 +1,9 @@
-2020-04-23 Iain Sandoe <iain@sandoe.co.uk>
+2020-04-23  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR fortran/93956
+       * gfortran.dg/pointer_assign_13.f90: New test.
+
+       2020-04-23 Iain Sandoe <iain@sandoe.co.uk>
 
        * g++.dg/coroutines/coro-bad-alloc-00-bad-op-new.C: Adjust for
        changed inline namespace.

diff --git a/gcc/testsuite/gfortran.dg/pointer_assign_13.f90 b/gcc/testsuite/gfortran.dg/pointer_assign_13.f90
new file mode 100644 (file)
index 0000000..b3f2cd9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_assign_13.f90
@@ -0,0 +1,47 @@
+! { dg-do run }
+! PR 93956 - span was set incorrectly, leading to wrong code.
+! Original test case by "martin".
+program array_temps
+  implicit none
+  
+  type :: tt
+     integer :: u = 1
+     integer :: v = 2
+  end type tt
+
+  type(tt), dimension(:), pointer :: r
+  integer :: n
+  integer, dimension(:), pointer :: p, q, u
+
+  n = 10
+  allocate(r(1:n))
+  call foo(r%v,n)
+  p => get(r(:))
+  call foo(p, n)
+  call get2(r,u)
+  call foo(u,n)
+  q => r%v
+  call foo(q, n)
+
+deallocate(r)
+
+contains
+
+   subroutine foo(a, n)
+      integer, dimension(:), intent(in) :: a
+      integer, intent(in) :: n
+      if (sum(a(1:n)) /= 2*n) stop 1
+   end subroutine foo
+
+   function get(x) result(q)
+      type(tt), dimension(:), target, intent(in) :: x
+      integer, dimension(:), pointer :: q
+      q => x(:)%v
+   end function get
+
+   subroutine get2(x,q)
+      type(tt), dimension(:), target, intent(in) :: x
+      integer, dimension(:), pointer, intent(out) :: q
+      q => x(:)%v
+    end subroutine get2
+end program array_temps