Fortran: Fixes for pointer function call as variable (PR96896)

gcc/fortran/ChangeLog:

	PR fortran/96896
	* resolve.c (get_temp_from_expr): Also reset proc_pointer +
	use_assoc attribute.
	(resolve_ptr_fcn_assign): Use information from the LHS.

gcc/testsuite/ChangeLog:

	PR fortran/96896
	* gfortran.dg/ptr_func_assign_4.f08: Update dg-error.
	* gfortran.dg/ptr-func-3.f90: New test.

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index fc2431b8aad7bb2e0f4b6f88f7fe6b5fbf35fa7f..ebf89a9b1f52f31557c739673c2e84e4b0889aa6 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -11179,9 +11179,11 @@ get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
   /* Add the attributes and the arrayspec to the temporary.  */
   tmp->n.sym->attr = gfc_expr_attr (e);
   tmp->n.sym->attr.function = 0;
+  tmp->n.sym->attr.proc_pointer = 0;
   tmp->n.sym->attr.result = 0;
   tmp->n.sym->attr.flavor = FL_VARIABLE;
   tmp->n.sym->attr.dummy = 0;
+  tmp->n.sym->attr.use_assoc = 0;
   tmp->n.sym->attr.intent = INTENT_UNKNOWN;
 
   if (as)
@@ -11601,7 +11603,7 @@ resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns)
       return false;
     }
 
-  tmp_ptr_expr = get_temp_from_expr ((*code)->expr2, ns);
+  tmp_ptr_expr = get_temp_from_expr ((*code)->expr1, ns);
 
   /* get_temp_from_expression is set up for ordinary assignments. To that
      end, where array bounds are not known, arrays are made allocatable.

diff --git a/gcc/testsuite/gfortran.dg/ptr-func-3.f90 b/gcc/testsuite/gfortran.dg/ptr-func-3.f90
new file mode 100644 (file)
index 0000000..0f1af64
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ptr-func-3.f90
@@ -0,0 +1,56 @@
+! { dg-do run }
+! PR fortran/96896
+
+call test1
+call reshape_test
+end
+
+subroutine test1
+implicit none
+integer, target :: B
+integer, pointer :: A(:)
+allocate(A(5))
+A = 1
+B = 10
+get_A() = get_B()
+if (any (A /= 10)) stop 1
+get_A() = get_A()
+if (any (A /= 10)) stop 2
+deallocate(A)
+contains
+  function get_A()
+    integer, pointer :: get_A(:)
+    get_A => A
+  end
+  function get_B()
+    integer, pointer :: get_B
+    get_B => B
+  end
+end
+
+subroutine reshape_test
+    implicit none
+    real, target, dimension (1:9) :: b
+    integer :: i
+    b = 1.0
+    myshape(b) = 3.0
+    do i = 1, 3
+      myfunc (b,i,2) = b(i) + i
+      b(i) = b(i) + 2.0
+    end do
+    if (any (b /= [real::5,5,5,4,5,6,3,3,3])) stop 3
+contains
+  function myfunc(b,i,j)
+    real, target, dimension (1:9) :: b
+    real, pointer :: myfunc
+    real, pointer :: p(:,:)
+    integer :: i,j 
+    p => myshape(b)
+    myfunc => p(i,j)
+  end function myfunc
+  function myshape(b)
+    real, target, dimension (1:9) :: b
+    real, pointer :: myshape(:,:)
+    myshape(1:3,1:3) => b
+  end function myshape
+end subroutine reshape_test

diff --git a/gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08 b/gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08
index 46ef2ac556689ef5cb45af80da3fb0557f55fec9..49ba9bcd3d9d1fb627d6e0b65dd1503608508c62 100644 (file)
--- a/gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08
+++ b/gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08
@@ -10,8 +10,8 @@ program p
   integer :: c
 
   c = 3
-  func (b(2, 2)) = b ! { dg-error "Different ranks" }
-  func (c) = b       ! { dg-error "Different ranks" }
+  func (b(2, 2)) = b ! { dg-error "Incompatible ranks 1 and 2 in assignment" }
+  func (c) = b       ! { dg-error "Incompatible ranks 1 and 2 in assignment" }
 
 contains
   function func(arg) result(r)