This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch, Fortran] SELECT TYPE via ASSOCIATE
- From: Daniel Kraft <d at domob dot eu>
- To: Fortran List <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Thu, 26 Aug 2010 12:31:19 +0200
- Subject: Re: [Patch, Fortran] SELECT TYPE via ASSOCIATE
- References: <4C762FED.7020609@domob.eu>
Daniel Kraft wrote:
Hi,
the attached patch fixes ASSOCIATE for polymorphic values and switches
the current implementation of SELECT TYPE to using ASSOCIATE internally.
As a side-effect, this fixes the "double-free" PRs 44047 and 45384. I
also think that the still missing piece (comment #3) of PR 44044 will be
fixed when the testing for variable definition contexts in ASSOCIATE is
extended (but so far the problem is still not detected).
Regtested on GNU/Linux-x86-32. The only failure was bessel_7.f90, which
goes away when I increase the tolerance according to
http://gcc.gnu.org/ml/fortran/2010-08/msg00308.html. Ok for trunk?
As Dominique spotted a bug in this patch, here's an update which
hopefully fixes the problem. The only relative change is the new st.c
update.
Daniel
--
http://www.pro-vegan.info/
--
Done: Arc-Bar-Cav-Kni-Ran-Rog-Sam-Tou-Val-Wiz
To go: Hea-Mon-Pri
2010-08-26 Daniel Kraft <d@domob.eu>
PR fortran/38936
PR fortran/44047
PR fortran/45384
* gfortran.h (struct gfc_association_list): New flag `dangling'.
(gfc_build_block_ns): Declared here...
* parse.h (gfc_build_block_ns): ...instead of here.
* trans.h (gfc_process_block_locals): Expect additionally the
gfc_association_list of BLOCK (if present).
* match.c (select_type_set_tmp): Create sym->assoc for temporary.
* symbol.c (gfc_free_symbol): Free a dangling association-list.
* resolve.c (resolve_variable): Only check for invalid *array*
references on associate-names.
(resolve_assoc_var): New method with code previously in resolve_symbol.
(resolve_select_type): Use association to give the selector and
temporaries their values instead of ordinary assignment.
(resolve_fl_var_and_proc): Allow CLASS associate-names.
(resolve_symbol): Use new `resolve_assoc_var' instead of inlining here.
* st.c (gfc_free_association_list): NULLify assoc of symbol.
* trans-stmt.c (gfc_trans_block_construct): Pass association-list
to `gfc_process_block_locals' to match new interface.
* trans-decl.c (gfc_get_symbol_decl): Don't defer associate-names
here automatically.
(gfc_process_block_locals): Defer them rather here when linked to
from the BLOCK's association list.
2010-08-26 Daniel Kraft <d@domob.eu>
PR fortran/38936
PR fortran/44047
PR fortran/45384
* gfortran.dg/associate_8.f03: New test.
* gfortran.dg/select_type_13.f03: New test.
* gfortran.dg/select_type_14.f03: New test.
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 163540)
+++ gcc/fortran/symbol.c (working copy)
@@ -2499,6 +2499,9 @@ gfc_free_symbol (gfc_symbol *sym)
gfc_free_namespace (sym->f2k_derived);
+ if (sym->assoc && sym->assoc->dangling)
+ gfc_free_association_list (sym->assoc);
+
gfc_free (sym);
}
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 163540)
+++ gcc/fortran/gfortran.h (working copy)
@@ -2007,6 +2007,12 @@ typedef struct gfc_association_list
lvalue. */
unsigned variable:1;
+ /* True if this struct is currently only linked to from a gfc_symbol rather
+ than as part of a real list in gfc_code->ext.block.assoc. This may
+ happen for SELECT TYPE temporaries and must be considered
+ for memory handling. */
+ unsigned dangling:1;
+
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symtree *st; /* Symtree corresponding to name. */
locus where;
@@ -2831,6 +2837,7 @@ void gfc_dump_parse_tree (gfc_namespace
/* parse.c */
gfc_try gfc_parse_file (void);
void gfc_global_used (gfc_gsymbol *, locus *);
+gfc_namespace* gfc_build_block_ns (gfc_namespace *);
/* dependency.c */
int gfc_dep_compare_expr (gfc_expr *, gfc_expr *);
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (revision 163540)
+++ gcc/fortran/trans-stmt.c (working copy)
@@ -860,7 +860,7 @@ gfc_trans_block_construct (gfc_code* cod
gcc_assert (!sym->tlink);
sym->tlink = sym;
- gfc_process_block_locals (ns);
+ gfc_process_block_locals (ns, code->ext.block.assoc);
gfc_start_wrapped_block (&body, gfc_trans_code (ns->code));
gfc_trans_deferred_vars (sym, &body);
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (revision 163540)
+++ gcc/fortran/trans.h (working copy)
@@ -538,7 +538,7 @@ tree gfc_build_library_function_decl_wit
tree rettype, int nargs, ...);
/* Process the local variable decls of a block construct. */
-void gfc_process_block_locals (gfc_namespace*);
+void gfc_process_block_locals (gfc_namespace*, gfc_association_list*);
/* Output initialization/clean-up code that was deferred. */
void gfc_trans_deferred_vars (gfc_symbol*, gfc_wrapped_block *);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 163540)
+++ gcc/fortran/resolve.c (working copy)
@@ -4921,9 +4921,9 @@ resolve_variable (gfc_expr *e)
return FAILURE;
sym = e->symtree->n.sym;
- /* If this is an associate-name, it may be parsed with references in error
- even though the target is scalar. Fail directly in this case. */
- if (sym->assoc && !sym->attr.dimension && e->ref)
+ /* If this is an associate-name, it may be parsed with an array reference
+ in error even though the target is scalar. Fail directly in this case. */
+ if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
return FAILURE;
/* On the other hand, the parser may not have known this is an array;
@@ -7551,6 +7551,88 @@ gfc_type_is_extensible (gfc_symbol *sym)
}
+/* Resolve an associate name: Resolve target and ensure the type-spec is
+ correct as well as possibly the array-spec. */
+
+static void
+resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
+{
+ gfc_expr* target;
+ bool to_var;
+
+ gcc_assert (sym->assoc);
+ gcc_assert (sym->attr.flavor == FL_VARIABLE);
+
+ /* If this is for SELECT TYPE, the target may not yet be set. In that
+ case, return. Resolution will be called later manually again when
+ this is done. */
+ target = sym->assoc->target;
+ if (!target)
+ return;
+ gcc_assert (!sym->assoc->dangling);
+
+ if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
+ return;
+
+ /* For variable targets, we get some attributes from the target. */
+ if (target->expr_type == EXPR_VARIABLE)
+ {
+ gfc_symbol* tsym;
+
+ gcc_assert (target->symtree);
+ tsym = target->symtree->n.sym;
+
+ sym->attr.asynchronous = tsym->attr.asynchronous;
+ sym->attr.volatile_ = tsym->attr.volatile_;
+
+ sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
+ }
+
+ sym->ts = target->ts;
+ gcc_assert (sym->ts.type != BT_UNKNOWN);
+
+ /* See if this is a valid association-to-variable. */
+ to_var = (target->expr_type == EXPR_VARIABLE
+ && !gfc_has_vector_subscript (target));
+ if (sym->assoc->variable && !to_var)
+ {
+ if (target->expr_type == EXPR_VARIABLE)
+ gfc_error ("'%s' at %L associated to vector-indexed target can not"
+ " be used in a variable definition context",
+ sym->name, &sym->declared_at);
+ else
+ gfc_error ("'%s' at %L associated to expression can not"
+ " be used in a variable definition context",
+ sym->name, &sym->declared_at);
+
+ return;
+ }
+ sym->assoc->variable = to_var;
+
+ /* Finally resolve if this is an array or not. */
+ if (sym->attr.dimension && target->rank == 0)
+ {
+ gfc_error ("Associate-name '%s' at %L is used as array",
+ sym->name, &sym->declared_at);
+ sym->attr.dimension = 0;
+ return;
+ }
+ if (target->rank > 0)
+ sym->attr.dimension = 1;
+
+ if (sym->attr.dimension)
+ {
+ sym->as = gfc_get_array_spec ();
+ sym->as->rank = target->rank;
+ sym->as->type = AS_DEFERRED;
+
+ /* Target must not be coindexed, thus the associate-variable
+ has no corank. */
+ sym->as->corank = 0;
+ }
+}
+
+
/* Resolve a SELECT TYPE statement. */
static void
@@ -7628,37 +7710,42 @@ resolve_select_type (gfc_code *code)
}
}
- if (error>0)
+ if (error > 0)
return;
+ /* Transform SELECT TYPE statement to BLOCK and associate selector to
+ target if present. */
+ code->op = EXEC_BLOCK;
if (code->expr2)
{
- /* Insert assignment for selector variable. */
- new_st = gfc_get_code ();
- new_st->op = EXEC_ASSIGN;
- new_st->expr1 = gfc_copy_expr (code->expr1);
- new_st->expr2 = gfc_copy_expr (code->expr2);
- ns->code = new_st;
+ gfc_association_list* assoc;
+
+ assoc = gfc_get_association_list ();
+ assoc->st = code->expr1->symtree;
+ assoc->target = gfc_copy_expr (code->expr2);
+ /* assoc->variable will be set by resolve_assoc_var. */
+
+ code->ext.block.assoc = assoc;
+ code->expr1->symtree->n.sym->assoc = assoc;
+
+ resolve_assoc_var (code->expr1->symtree->n.sym, false);
}
+ else
+ code->ext.block.assoc = NULL;
- /* Put SELECT TYPE statement inside a BLOCK. */
+ /* Add EXEC_SELECT to switch on type. */
new_st = gfc_get_code ();
new_st->op = code->op;
new_st->expr1 = code->expr1;
new_st->expr2 = code->expr2;
new_st->block = code->block;
+ code->expr1 = code->expr2 = NULL;
+ code->block = NULL;
if (!ns->code)
ns->code = new_st;
else
ns->code->next = new_st;
- code->op = EXEC_BLOCK;
- code->ext.block.assoc = NULL;
- code->expr1 = code->expr2 = NULL;
- code->block = NULL;
-
code = new_st;
-
- /* Transform to EXEC_SELECT. */
code->op = EXEC_SELECT;
gfc_add_component_ref (code->expr1, "$vptr");
gfc_add_component_ref (code->expr1, "$hash");
@@ -7675,24 +7762,37 @@ resolve_select_type (gfc_code *code)
else if (c->ts.type == BT_UNKNOWN)
continue;
- /* Assign temporary to selector. */
+ /* Associate temporary to selector. This should only be done
+ when this case is actually true, so build a new ASSOCIATE
+ that does precisely this here (instead of using the
+ 'global' one). */
+
if (c->ts.type == BT_CLASS)
sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
else
sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
st = gfc_find_symtree (ns->sym_root, name);
- new_st = gfc_get_code ();
- new_st->expr1 = gfc_get_variable_expr (st);
- new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree);
+ gcc_assert (st->n.sym->assoc);
+ st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
if (c->ts.type == BT_DERIVED)
+ gfc_add_component_ref (st->n.sym->assoc->target, "$data");
+
+ new_st = gfc_get_code ();
+ new_st->op = EXEC_BLOCK;
+ new_st->ext.block.ns = gfc_build_block_ns (ns);
+ new_st->ext.block.ns->code = body->next;
+ body->next = new_st;
+
+ /* Chain in the new list only if it is marked as dangling. Otherwise
+ there is a CASE label overlap and this is already used. Just ignore,
+ the error is diagonsed elsewhere. */
+ if (st->n.sym->assoc->dangling)
{
- new_st->op = EXEC_POINTER_ASSIGN;
- gfc_add_component_ref (new_st->expr2, "$data");
+ new_st->ext.block.assoc = st->n.sym->assoc;
+ st->n.sym->assoc->dangling = 0;
}
- else
- new_st->op = EXEC_POINTER_ASSIGN;
- new_st->next = body->next;
- body->next = new_st;
+
+ resolve_assoc_var (st->n.sym, false);
}
/* Take out CLASS IS cases for separate treatment. */
@@ -8405,7 +8505,7 @@ resolve_block_construct (gfc_code* code)
gfc_resolve (code->ext.block.ns);
/* For an ASSOCIATE block, the associations (and their targets) are already
- resolved during gfc_resolve_symbol. */
+ resolved during resolve_symbol. */
}
@@ -9634,8 +9734,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym
}
/* F03:C509. */
- /* Assume that use associated symbols were checked in the module ns. */
- if (!sym->attr.class_ok && !sym->attr.use_assoc)
+ /* Assume that use associated symbols were checked in the module ns.
+ Class-variables that are associate-names are also something special
+ and excepted from the test. */
+ if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
{
gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
"or pointer", sym->name, &sym->declared_at);
@@ -11701,76 +11803,9 @@ resolve_symbol (gfc_symbol *sym)
&& resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
return;
- /* For associate names, resolve corresponding expression and make sure
- they get their type-spec set this way. */
+ /* Resolve associate names. */
if (sym->assoc)
- {
- gfc_expr* target;
- bool to_var;
-
- gcc_assert (sym->attr.flavor == FL_VARIABLE);
-
- target = sym->assoc->target;
- if (gfc_resolve_expr (target) != SUCCESS)
- return;
-
- /* For variable targets, we get some attributes from the target. */
- if (target->expr_type == EXPR_VARIABLE)
- {
- gfc_symbol* tsym;
-
- gcc_assert (target->symtree);
- tsym = target->symtree->n.sym;
-
- sym->attr.asynchronous = tsym->attr.asynchronous;
- sym->attr.volatile_ = tsym->attr.volatile_;
-
- sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
- }
-
- sym->ts = target->ts;
- gcc_assert (sym->ts.type != BT_UNKNOWN);
-
- /* See if this is a valid association-to-variable. */
- to_var = (target->expr_type == EXPR_VARIABLE
- && !gfc_has_vector_subscript (target));
- if (sym->assoc->variable && !to_var)
- {
- if (target->expr_type == EXPR_VARIABLE)
- gfc_error ("'%s' at %L associated to vector-indexed target can not"
- " be used in a variable definition context",
- sym->name, &sym->declared_at);
- else
- gfc_error ("'%s' at %L associated to expression can not"
- " be used in a variable definition context",
- sym->name, &sym->declared_at);
-
- return;
- }
- sym->assoc->variable = to_var;
-
- /* Finally resolve if this is an array or not. */
- if (sym->attr.dimension && target->rank == 0)
- {
- gfc_error ("Associate-name '%s' at %L is used as array",
- sym->name, &sym->declared_at);
- sym->attr.dimension = 0;
- return;
- }
- if (target->rank > 0)
- sym->attr.dimension = 1;
-
- if (sym->attr.dimension)
- {
- sym->as = gfc_get_array_spec ();
- sym->as->rank = target->rank;
- sym->as->type = AS_DEFERRED;
-
- /* Target must not be coindexed, thus the associate-variable
- has no corank. */
- sym->as->corank = 0;
- }
- }
+ resolve_assoc_var (sym, true);
/* Assign default type to symbols that need one and don't have one. */
if (sym->ts.type == BT_UNKNOWN)
Index: gcc/fortran/st.c
===================================================================
--- gcc/fortran/st.c (revision 163540)
+++ gcc/fortran/st.c (working copy)
@@ -242,5 +242,11 @@ gfc_free_association_list (gfc_associati
return;
gfc_free_association_list (assoc->next);
+
+ /* Make sure to unregister the association from the symbol, so that
+ we don't try to access it from now on. */
+ if (assoc->st)
+ assoc->st->n.sym->assoc = NULL;
+
gfc_free (assoc);
}
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 163540)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -1218,7 +1218,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
}
/* Remember this variable for allocation/cleanup. */
- if (sym->attr.dimension || sym->attr.allocatable || sym->assoc
+ if (sym->attr.dimension || sym->attr.allocatable
|| (sym->ts.type == BT_CLASS &&
(CLASS_DATA (sym)->attr.dimension
|| CLASS_DATA (sym)->attr.allocatable))
@@ -4831,13 +4831,22 @@ gfc_generate_block_data (gfc_namespace *
/* Process the local variables of a BLOCK construct. */
void
-gfc_process_block_locals (gfc_namespace* ns)
+gfc_process_block_locals (gfc_namespace* ns, gfc_association_list* assoc)
{
tree decl;
gcc_assert (saved_local_decls == NULL_TREE);
generate_local_vars (ns);
+ /* Mark associate names to be initialized. The symbol's namespace may not
+ be the BLOCK's, we have to force this so that the deferring
+ works as expected. */
+ for (; assoc; assoc = assoc->next)
+ {
+ assoc->st->n.sym->ns = ns;
+ gfc_defer_symbol_init (assoc->st->n.sym);
+ }
+
decl = saved_local_decls;
while (decl)
{
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c (revision 163540)
+++ gcc/fortran/match.c (working copy)
@@ -4479,6 +4479,12 @@ select_type_set_tmp (gfc_typespec *ts)
tmp->n.sym->attr.class_ok = 1;
}
+ /* Add an association for it, so the rest of the parser knows it is
+ an associate-name. The target will be set during resolution. */
+ tmp->n.sym->assoc = gfc_get_association_list ();
+ tmp->n.sym->assoc->dangling = 1;
+ tmp->n.sym->assoc->st = tmp;
+
select_type_stack->tmp = tmp;
}
Index: gcc/fortran/parse.h
===================================================================
--- gcc/fortran/parse.h (revision 163540)
+++ gcc/fortran/parse.h (working copy)
@@ -68,5 +68,4 @@ match gfc_match_enumerator_def (void);
void gfc_free_enum_history (void);
extern bool gfc_matching_function;
match gfc_match_prefix (gfc_typespec *);
-gfc_namespace* gfc_build_block_ns (gfc_namespace *);
#endif /* GFC_PARSE_H */
Index: gcc/testsuite/gfortran.dg/select_type_13.f03
===================================================================
--- gcc/testsuite/gfortran.dg/select_type_13.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/select_type_13.f03 (revision 0)
@@ -0,0 +1,26 @@
+! { dg-do run }
+
+! PR fortran/45384
+! Double free happened, check that it works now.
+
+! Contributed by Janus Weil, janus@gcc.gnu.org.
+
+program bug20
+
+ type :: d_base_sparse_mat
+ integer :: v(10) = 0.
+ end type d_base_sparse_mat
+
+ class(d_base_sparse_mat),allocatable :: a
+
+ allocate (d_base_sparse_mat :: a)
+
+ select type(aa => a)
+ type is (d_base_sparse_mat)
+ write(0,*) 'NV = ',size(aa%v)
+ if (size(aa%v) /= 10) call abort ()
+ class default
+ write(0,*) 'Not implemented yet '
+ end select
+
+end program bug20
Index: gcc/testsuite/gfortran.dg/associate_8.f03
===================================================================
--- gcc/testsuite/gfortran.dg/associate_8.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/associate_8.f03 (revision 0)
@@ -0,0 +1,37 @@
+! { dg-do run}
+! { dg-options "-std=f2003 -fall-intrinsics" }
+
+! PR fortran/38936
+! Check associate to polymorphic entities.
+
+! Contributed by Tobias Burnus, burnus@gcc.gnu.org.
+
+type t
+end type t
+
+type, extends(t) :: t2
+end type t2
+
+class(t), allocatable :: a, b
+allocate( t :: a)
+allocate( t2 :: b)
+
+associate ( one => a, two => b)
+ select type(two)
+ type is (t)
+ call abort ()
+ type is (t2)
+ print *, 'OK', two
+ class default
+ call abort ()
+ end select
+ select type(one)
+ type is (t2)
+ call abort ()
+ type is (t)
+ print *, 'OK', one
+ class default
+ call abort ()
+ end select
+end associate
+end
Index: gcc/testsuite/gfortran.dg/select_type_14.f03
===================================================================
--- gcc/testsuite/gfortran.dg/select_type_14.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/select_type_14.f03 (revision 0)
@@ -0,0 +1,24 @@
+! { dg-do run }
+
+! PR fortran/44047
+! Double free happened, check that it works now.
+
+! Contributed by Janus Weil, janus@gcc.gnu.org.
+
+implicit none
+type t0
+ integer :: j = 42
+end type t0
+type t
+ integer :: i
+ class(t0), allocatable :: foo
+end type t
+type(t) :: m
+allocate(t0 :: m%foo)
+m%i = 5
+select type(bar => m%foo)
+type is(t0)
+ print *, bar
+ if (bar%j /= 42) call abort ()
+end select
+end