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

Fortran: Fix some bugs in associate [PR87477]

Browse source 
2023-06-21  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/87477
	PR fortran/88688
	PR fortran/94380
	PR fortran/107900
	PR fortran/110224
	* decl.cc (char_len_param_value): Fix memory leak.
	(resolve_block_construct): Remove unnecessary static decls.
	* expr.cc (gfc_is_ptr_fcn): New function.
	(gfc_check_vardef_context): Use it to permit pointer function
	result selectors to be used for associate names in variable
	definition context.
	* gfortran.h: Prototype for gfc_is_ptr_fcn.
	* match.cc (build_associate_name): New function.
	(gfc_match_select_type): Use the new function to replace inline
	version and to build a new associate name for the case where
	the supplied associate name is already used for that purpose.
	* resolve.cc (resolve_assoc_var): Call gfc_is_ptr_fcn to allow
	associate names with pointer function targets to be used in
	variable definition context.
	* trans-decl.cc (gfc_get_symbol_decl): Unlimited polymorphic
	variables need deferred initialisation of the vptr.
	(gfc_trans_deferred_vars): Do the vptr initialisation.
	* trans-stmt.cc (trans_associate_var): Ensure that a pointer
	associate name points to the target of the selector and not
	the selector itself.

gcc/testsuite/
	PR fortran/87477
	PR fortran/107900
	* gfortran.dg/pr107900.f90 : New test

	PR fortran/110224
	* gfortran.dg/pr110224.f90 : New test

	PR fortran/88688
	* gfortran.dg/pr88688.f90 : New test

	PR fortran/94380
	* gfortran.dg/pr94380.f90 : New test

	PR fortran/95398
	* gfortran.dg/pr95398.f90 : Set -std=f2008, bump the line
	numbers in the error tests by two and change the text in two.
This commit is contained in:
Paul Thomas 2023-06-21 17:05:58 +01:00
parent caf0892eea
commit 577223aebc
12 changed files with 286 additions and 29 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
gcc/fortran/decl.cc
View file

@ -1086,6 +1086,8 @@ char_len_param_value (gfc_expr **expr, bool *deferred)
p = gfc_copy_expr (*expr);
if (gfc_is_constant_expr (p) && gfc_simplify_expr (p, 1))
gfc_replace_expr (*expr, p);
else
gfc_free_expr (p);
if ((*expr)->expr_type == EXPR_FUNCTION)
{

26
gcc/fortran/expr.cc
View file

@ -812,6 +812,16 @@ gfc_has_vector_index (gfc_expr *e)
}
bool
gfc_is_ptr_fcn (gfc_expr *e)
{
return e != NULL && e->expr_type == EXPR_FUNCTION
&& (gfc_expr_attr (e).pointer
|| (e->ts.type == BT_CLASS
&& CLASS_DATA (e)->attr.class_pointer));
}
/* Copy a shape array. */
mpz_t *
@ -6470,6 +6480,22 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
}
return false;
}
else if (context && gfc_is_ptr_fcn (assoc->target))
{
if (!gfc_notify_std (GFC_STD_F2018, "%qs at %L associated to "
"pointer function target being used in a "
"variable definition context (%s)", name,
&e->where, context))
return false;
else if (gfc_has_vector_index (e))
{
gfc_error ("%qs at %L associated to vector-indexed target"
" cannot be used in a variable definition"
" context (%s)",
name, &e->where, context);
return false;
}
}
/* Target must be allowed to appear in a variable definition context. */
if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL))

1
gcc/fortran/gfortran.h
View file

@ -3659,6 +3659,7 @@ bool gfc_is_constant_expr (gfc_expr *);
bool gfc_simplify_expr (gfc_expr *, int);
bool gfc_try_simplify_expr (gfc_expr *, int);
bool gfc_has_vector_index (gfc_expr *);
bool gfc_is_ptr_fcn (gfc_expr *);
gfc_expr *gfc_get_expr (void);
gfc_expr *gfc_get_array_expr (bt type, int kind, locus *);

60
gcc/fortran/match.cc
View file

@ -6379,6 +6379,39 @@ build_class_sym:
}
/* Build the associate name */
static int
build_associate_name (const char *name, gfc_expr **e1, gfc_expr **e2)
{
gfc_expr *expr1 = *e1;
gfc_expr *expr2 = *e2;
gfc_symbol *sym;
/* For the case where the associate name is already an associate name. */
if (!expr2)
expr2 = expr1;
expr1 = gfc_get_expr ();
expr1->expr_type = EXPR_VARIABLE;
expr1->where = expr2->where;
if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
return 1;
sym = expr1->symtree->n.sym;
if (expr2->ts.type == BT_UNKNOWN)
sym->attr.untyped = 1;
else
copy_ts_from_selector_to_associate (expr1, expr2);
sym->attr.flavor = FL_VARIABLE;
sym->attr.referenced = 1;
sym->attr.class_ok = 1;
*e1 = expr1;
*e2 = expr2;
return 0;
}
/* Push the current selector onto the SELECT TYPE stack. */
static void
@ -6534,7 +6567,6 @@ gfc_match_select_type (void)
match m;
char name[GFC_MAX_SYMBOL_LEN + 1];
bool class_array;
gfc_symbol *sym;
gfc_namespace *ns = gfc_current_ns;
m = gfc_match_label ();
@ -6556,24 +6588,11 @@ gfc_match_select_type (void)
m = gfc_match (" %n => %e", name, &expr2);
if (m == MATCH_YES)
{
expr1 = gfc_get_expr ();
expr1->expr_type = EXPR_VARIABLE;
expr1->where = expr2->where;
if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
if (build_associate_name (name, &expr1, &expr2))
{
m = MATCH_ERROR;
goto cleanup;
}
sym = expr1->symtree->n.sym;
if (expr2->ts.type == BT_UNKNOWN)
sym->attr.untyped = 1;
else
copy_ts_from_selector_to_associate (expr1, expr2);
sym->attr.flavor = FL_VARIABLE;
sym->attr.referenced = 1;
sym->attr.class_ok = 1;
}
else
{
@ -6620,6 +6639,17 @@ gfc_match_select_type (void)
goto cleanup;
}
/* Prevent an existing associate name from reuse here by pushing expr1 to
expr2 and building a new associate name. */
if (!expr2 && expr1->symtree->n.sym->assoc
&& !expr1->symtree->n.sym->attr.select_type_temporary
&& !expr1->symtree->n.sym->attr.select_rank_temporary
&& build_associate_name (expr1->symtree->n.sym->name, &expr1, &expr2))
{
m = MATCH_ERROR;
goto cleanup;
}
new_st.op = EXEC_SELECT_TYPE;
new_st.expr1 = expr1;
new_st.expr2 = expr2;

7
gcc/fortran/resolve.cc
View file

@ -9254,9 +9254,10 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
gcc_assert (sym->ts.type != BT_UNKNOWN);
/* See if this is a valid association-to-variable. */
sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
&& !parentheses
&& !gfc_has_vector_subscript (target));
sym->assoc->variable = ((target->expr_type == EXPR_VARIABLE
&& !parentheses
&& !gfc_has_vector_subscript (target))
|| gfc_is_ptr_fcn (target));
/* Finally resolve if this is an array or not. */
if (sym->attr.dimension && target->rank == 0)

33
gcc/fortran/trans-decl.cc
View file

@ -1875,6 +1875,15 @@ gfc_get_symbol_decl (gfc_symbol * sym)
&& !(sym->attr.use_assoc && !intrinsic_array_parameter)))
gfc_defer_symbol_init (sym);
/* Set the vptr of unlimited polymorphic pointer variables so that
they do not cause segfaults in select type, when the selector
is an intrinsic type. Arrays are captured above. */
if (sym->ts.type == BT_CLASS && UNLIMITED_POLY (sym)
&& CLASS_DATA (sym)->attr.class_pointer
&& !CLASS_DATA (sym)->attr.dimension && !sym->attr.dummy
&& sym->attr.flavor == FL_VARIABLE && !sym->assoc)
gfc_defer_symbol_init (sym);
if (sym->ts.type == BT_CHARACTER
&& sym->attr.allocatable
&& !sym->attr.dimension
@ -1906,6 +1915,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
gcc_assert (!sym->value || sym->value->expr_type == EXPR_NULL);
}
gfc_finish_var_decl (decl, sym);
if (sym->ts.type == BT_CHARACTER)
@ -4652,6 +4662,29 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
if (sym->assoc)
continue;
/* Set the vptr of unlimited polymorphic pointer variables so that
they do not cause segfaults in select type, when the selector
is an intrinsic type. */
if (sym->ts.type == BT_CLASS && UNLIMITED_POLY (sym)
&& sym->attr.flavor == FL_VARIABLE && !sym->assoc
&& !sym->attr.dummy && CLASS_DATA (sym)->attr.class_pointer)
{
gfc_symbol *vtab;
gfc_init_block (&tmpblock);
vtab = gfc_find_vtab (&sym->ts);
if (!vtab->backend_decl)
{
if (!vtab->attr.referenced)
gfc_set_sym_referenced (vtab);
gfc_get_symbol_decl (vtab);
}
tmp = gfc_class_vptr_get (sym->backend_decl);
gfc_add_modify (&tmpblock, tmp,
gfc_build_addr_expr (TREE_TYPE (tmp),
vtab->backend_decl));
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL);
}
if (sym->ts.type == BT_DERIVED
&& sym->ts.u.derived
&& sym->ts.u.derived->attr.pdt_type)

20
gcc/fortran/trans-stmt.cc
View file

@ -2139,11 +2139,14 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
tree ctree = gfc_get_class_from_expr (se.expr);
tmp = TREE_TYPE (sym->backend_decl);
/* Coarray scalar component expressions can emerge from
the front end as array elements of the _data field. */
/* F2018:19.5.1.6 "If a selector has the POINTER attribute,
it shall be associated; the associate name is associated
with the target of the pointer and does not have the
POINTER attribute." */
if (sym->ts.type == BT_CLASS
&& e->ts.type == BT_CLASS && e->rank == 0
&& !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)) && ctree)
&& e->ts.type == BT_CLASS && e->rank == 0 && ctree
&& (!GFC_CLASS_TYPE_P (TREE_TYPE (se.expr))
|| CLASS_DATA (e)->attr.class_pointer))
{
tree stmp;
tree dtmp;
@ -2153,10 +2156,10 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
ctree = gfc_create_var (dtmp, "class");
stmp = gfc_class_data_get (se.expr);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp)));
/* Set the fields of the target class variable. */
stmp = gfc_conv_descriptor_data_get (stmp);
/* Coarray scalar component expressions can emerge from
the front end as array elements of the _data field. */
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp)))
stmp = gfc_conv_descriptor_data_get (stmp);
dtmp = gfc_class_data_get (ctree);
stmp = fold_convert (TREE_TYPE (dtmp), stmp);
gfc_add_modify (&se.pre, dtmp, stmp);
@ -2170,6 +2173,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
dtmp = gfc_class_len_get (ctree);
stmp = fold_convert (TREE_TYPE (dtmp), stmp);
gfc_add_modify (&se.pre, dtmp, stmp);
need_len_assign = false;
}
se.expr = ctree;
}

49
gcc/testsuite/gfortran.dg/pr107900.f90 Normal file
View file

@ -0,0 +1,49 @@
! { dg-do run }
!
! Contributed by Karl Kaiser <kaiserkarl31@yahoo.com>
!
program test
class(*), pointer :: ptr1, ptr2(:)
integer, target :: i = 42
integer :: check = 0
! First with associate name and no selector in select types
associate (c => ptr1)
select type (c) ! Segfault - vptr not set
type is (integer)
stop 1
class default
check = 1
end select
end associate
! Now do the same with the array version
associate (c => ptr2)
select type (d =>c) ! Segfault - vptr not set
type is (integer)
stop 2
class default
check = check + 10
end select
end associate
! And now with the associate name and selector
associate (c => ptr1)
select type (d => c) ! Segfault - vptr not set
type is (integer)
stop 3
class default
check = check + 100
end select
end associate
! Now do the same with the array version
! ptr2 => NULL() !This did not fix the problem
associate (c => ptr2)
select type (d => c) ! Segfault - vptr not set
type is (integer)
stop 4
class default
check = check + 1000
end select
end associate
if (check .ne. 1111) stop 5
end program test

29
gcc/testsuite/gfortran.dg/pr110224.f90 Normal file
View file

@ -0,0 +1,29 @@
! { dg-do compile }
!
! Contributed by Neil Carlson <neil.n.carlson@gmail.com>
!
module mod
type :: foo
real, pointer :: var
contains
procedure :: var_ptr
end type
contains
function var_ptr(this) result(ref)
class(foo) :: this
real, pointer :: ref
ref => this%var
end function
end module
program main
use mod
type(foo) :: x
allocate (x%var, source = 2.0)
associate (var => x%var_ptr())
var = 1.0
end associate
if (x%var .ne. 1.0) stop 1
x%var_ptr() = 2.0
if (x%var .ne. 2.0) stop 2
deallocate (x%var)
end program

62
gcc/testsuite/gfortran.dg/pr88688.f90 Normal file
View file

@ -0,0 +1,62 @@
! { dg-do run }
!
! Contributed by Thomas Fanning <thfanning@gmail.com>
!
!
module mod
type test
class(*), pointer :: ptr
contains
procedure :: setref
end type
contains
subroutine setref(my,ip)
implicit none
class(test) :: my
integer, pointer :: ip
my%ptr => ip
end subroutine
subroutine set7(ptr)
implicit none
class(*), pointer :: ptr
select type (ptr)
type is (integer)
ptr = 7
end select
end subroutine
end module
!---------------------------------------
!---------------------------------------
program bug
use mod
implicit none
integer, pointer :: i, j
type(test) :: tp
class(*), pointer :: lp
allocate(i,j)
i = 3; j = 4
call tp%setref(i)
select type (ap => tp%ptr)
class default
call tp%setref(j)
lp => ap
call set7(lp)
end select
! gfortran used to give i=3 and j=7 because the associate name was not pointing
! to the target of tp%ptr as required by F2018:19.5.1.6 but, rather, to the
! selector itself.
if (i .ne. 7) stop 1
if (j .ne. 4) stop 2
end program
!---------------------------------------

18
gcc/testsuite/gfortran.dg/pr94380.f90 Normal file
View file

@ -0,0 +1,18 @@
! { dg-do compile }
!
! Contributed by Vladimir Nikishkin <lockywolf@gmail.com>
!
module test
type testtype
class(*), allocatable :: t
end type testtype
contains
subroutine testproc( x )
class(testtype) :: x
associate ( temp => x%t)
select type (temp)
type is (integer)
end select
end associate
end subroutine testproc
end module test

8
gcc/testsuite/gfortran.dg/pr95398.f90
View file

@ -1,5 +1,7 @@
! { dg-do compile }
! { dg-options "-std=f2008" }
program test
implicit none
@ -46,8 +48,8 @@ program test
end
! { dg-error "cannot be used in a variable definition context .assignment." " " { target *-*-* } 21 }
! { dg-error "cannot be used in a variable definition context .actual argument to INTENT = OUT.INOUT." " " { target *-*-* } 23 }
! { dg-error "Pointer assignment target is neither TARGET nor POINTER" " " { target *-*-* } 35 }
! { dg-error "being used in a variable definition context .assignment." " " { target *-*-* } 23 }
! { dg-error "being used in a variable definition context .actual argument to INTENT = OUT.INOUT." " " { target *-*-* } 25 }
! { dg-error "Pointer assignment target is neither TARGET nor POINTER" " " { target *-*-* } 37 }
! { dg-error "Pointer assignment target is neither TARGET nor POINTER" " " { target *-*-* } 39 }