FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
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.
This commit is contained in:
Tobias Burnus 2020-09-07 12:29:05 +02:00
parent c9c87dc958
commit 2b0df0a6ac
3 changed files with 61 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
gcc/fortran/resolve.c
View file

@ -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.

56
gcc/testsuite/gfortran.dg/ptr-func-3.f90 Normal file
View file

@ -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

4
gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08
View file

@ -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)