diff mbox series

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

Message ID c4a0acaf-975f-44d6-c867-cca54213d1c4@codesourcery.com
State New
Headers show
Series Fortran: Fixes for pointer function call as variable (PR96896) | expand

Commit Message

Tobias Burnus Sept. 2, 2020, 3:02 p.m. UTC 
During some discussion such an example as attached came up:
   f() = 0.0
where 'f' is a function which returns a pointer to an array.
This gets handled as
   _F.D0 => f()
   _F.D0 = 0.0
However, the first line did fail with a rank error as the rank
was taken from the RHS.

Changing this to the LHS express failed due to 'use_assoc',
which added an 'extern' to the variable and 'proc_pointer'
also caused problems – in principle, either problem could
have also occurred for the RHS.

Side effect: The error message is better for rank mismatch
as for 'f() = a' no pointer assignment is involved (in terms
of the user code) but before we had the error message
'Different ranks in pointer assignment'.

OK?

Tobias

-----------------
Mentor Graphics (Deutschland) GmbH, Arnulfstraße 201, 80634 München / Germany
Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Alexander Walter

Comments

Tobias Burnus Sept. 7, 2020, 9:38 a.m. UTC | #1 
*PING*

On 9/2/20 5:02 PM, Tobias Burnus wrote:
> During some discussion such an example as attached came up:
>   f() = 0.0
> where 'f' is a function which returns a pointer to an array.
> This gets handled as
>   _F.D0 => f()
>   _F.D0 = 0.0
> However, the first line did fail with a rank error as the rank
> was taken from the RHS.
>
> Changing this to the LHS express failed due to 'use_assoc',
> which added an 'extern' to the variable and 'proc_pointer'
> also caused problems – in principle, either problem could
> have also occurred for the RHS.
>
> Side effect: The error message is better for rank mismatch
> as for 'f() = a' no pointer assignment is involved (in terms
> of the user code) but before we had the error message
> 'Different ranks in pointer assignment'.
>
> OK?
>
> Tobias
>
-----------------
Mentor Graphics (Deutschland) GmbH, Arnulfstraße 201, 80634 München / Germany
Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Alexander Walter
Thomas Koenig Sept. 7, 2020, 10:18 a.m. UTC | #2 
Hi Tobias,

> *PING*

OK.

Thanks for the patch!

Regards

	Thomas
diff mbox series

Patch

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:
	* gfortran.dg/ptr-func-3.f90: New test.

 gcc/fortran/resolve.c                           |  4 +-
 gcc/testsuite/gfortran.dg/ptr-func-3.f90        | 56 +++++++++++++++++++++++++
 gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08 |  4 +-
 3 files changed, 61 insertions(+), 3 deletions(-)

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index e4232717e42..a3e1e427ba7 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -11173,9 +11173,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)
@@ -11595,7 +11597,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
index 00000000000..0f1af64002a
--- /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 46ef2ac5566..49ba9bcd3d9 100644
--- 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)