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)