mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-09 20:31:36 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/46581 ([OOP] segfault in SELECT TYPE with associate-name)

Browse Source 
2010-11-25  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/46581
	* trans.h (gfc_process_block_locals): Removed second argument.
	* trans-decl.c (trans_associate_var): Moved to trans-stmt.c.
	(gfc_trans_deferred_vars): Skip ASSOCIATE variables.
	(gfc_process_block_locals): Don't mark associate names to be
	initialized.
	* trans-stmt.c (trans_associate_var): Moved here from trans-decl.c.
	(gfc_trans_block_construct): Call 'trans_associate_var' from here
	to make sure SELECT TYPE with associate-name is treated correctly.

2010-11-25  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/46581
	* gfortran.dg/select_type_19.f03: New.

From-SVN: r167154
This commit is contained in:
Janus Weil 2010-11-25 23:04:59 +01:00
parent be82759165
commit 6312ef4519
6 changed files with 135 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
gcc/fortran/ChangeLog
View File

@ -1,3 +1,15 @@
2010-11-25 Janus Weil <janus@gcc.gnu.org>
PR fortran/46581
* trans.h (gfc_process_block_locals): Removed second argument.
* trans-decl.c (trans_associate_var): Moved to trans-stmt.c.
(gfc_trans_deferred_vars): Skip ASSOCIATE variables.
(gfc_process_block_locals): Don't mark associate names to be
initialized.
* trans-stmt.c (trans_associate_var): Moved here from trans-decl.c.
(gfc_trans_block_construct): Call 'trans_associate_var' from here
to make sure SELECT TYPE with associate-name is treated correctly.
2010-11-24 Tobias Burnus <burnus@net-b.de>
PR fortran/46638

101
gcc/fortran/trans-decl.c
View File

@ -3165,91 +3165,6 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
}
/* Do proper initialization for ASSOCIATE names. */
static void
trans_associate_var (gfc_symbol* sym, gfc_wrapped_block* block)
{
gfc_expr* e;
tree tmp;
gcc_assert (sym->assoc);
e = sym->assoc->target;
/* Do a `pointer assignment' with updated descriptor (or assign descriptor
to array temporary) for arrays with either unknown shape or if associating
to a variable. */
if (sym->attr.dimension
&& (sym->as->type == AS_DEFERRED || sym->assoc->variable))
{
gfc_se se;
gfc_ss* ss;
tree desc;
desc = sym->backend_decl;
/* If association is to an expression, evaluate it and create temporary.
Otherwise, get descriptor of target for pointer assignment. */
gfc_init_se (&se, NULL);
ss = gfc_walk_expr (e);
if (sym->assoc->variable)
{
se.direct_byref = 1;
se.expr = desc;
}
gfc_conv_expr_descriptor (&se, e, ss);
/* If we didn't already do the pointer assignment, set associate-name
descriptor to the one generated for the temporary. */
if (!sym->assoc->variable)
{
int dim;
gfc_add_modify (&se.pre, desc, se.expr);
/* The generated descriptor has lower bound zero (as array
temporary), shift bounds so we get lower bounds of 1. */
for (dim = 0; dim < e->rank; ++dim)
gfc_conv_shift_descriptor_lbound (&se.pre, desc,
dim, gfc_index_one_node);
}
/* Done, register stuff as init / cleanup code. */
gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
gfc_finish_block (&se.post));
}
/* Do a scalar pointer assignment; this is for scalar variable targets. */
else if (gfc_is_associate_pointer (sym))
{
gfc_se se;
gcc_assert (!sym->attr.dimension);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, e);
tmp = TREE_TYPE (sym->backend_decl);
tmp = gfc_build_addr_expr (tmp, se.expr);
gfc_add_modify (&se.pre, sym->backend_decl, tmp);
gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
gfc_finish_block (&se.post));
}
/* Do a simple assignment. This is for scalar expressions, where we
can simply use expression assignment. */
else
{
gfc_expr* lhs;
lhs = gfc_lval_expr_from_sym (sym);
tmp = gfc_trans_assignment (lhs, e, false, true);
gfc_add_init_cleanup (block, tmp, NULL_TREE);
}
}
/* Generate function entry and exit code, and add it to the function body.
This includes:
Allocation and initialization of array variables.
@ -3316,8 +3231,9 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
&& sym->ts.u.derived->attr.alloc_comp;
if (sym->assoc)
trans_associate_var (sym, block);
else if (sym->attr.dimension)
continue;
if (sym->attr.dimension)
{
switch (sym->as->type)
{
@ -4890,22 +4806,13 @@ gfc_generate_block_data (gfc_namespace * ns)
/* Process the local variables of a BLOCK construct. */
void
gfc_process_block_locals (gfc_namespace* ns, gfc_association_list* assoc)
gfc_process_block_locals (gfc_namespace* ns)
{
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)
{

92
gcc/fortran/trans-stmt.c
View File

@ -866,6 +866,91 @@ gfc_trans_critical (gfc_code *code)
}
/* Do proper initialization for ASSOCIATE names. */
static void
trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
{
gfc_expr *e;
tree tmp;
gcc_assert (sym->assoc);
e = sym->assoc->target;
/* Do a `pointer assignment' with updated descriptor (or assign descriptor
to array temporary) for arrays with either unknown shape or if associating
to a variable. */
if (sym->attr.dimension
&& (sym->as->type == AS_DEFERRED || sym->assoc->variable))
{
gfc_se se;
gfc_ss *ss;
tree desc;
desc = sym->backend_decl;
/* If association is to an expression, evaluate it and create temporary.
Otherwise, get descriptor of target for pointer assignment. */
gfc_init_se (&se, NULL);
ss = gfc_walk_expr (e);
if (sym->assoc->variable)
{
se.direct_byref = 1;
se.expr = desc;
}
gfc_conv_expr_descriptor (&se, e, ss);
/* If we didn't already do the pointer assignment, set associate-name
descriptor to the one generated for the temporary. */
if (!sym->assoc->variable)
{
int dim;
gfc_add_modify (&se.pre, desc, se.expr);
/* The generated descriptor has lower bound zero (as array
temporary), shift bounds so we get lower bounds of 1. */
for (dim = 0; dim < e->rank; ++dim)
gfc_conv_shift_descriptor_lbound (&se.pre, desc,
dim, gfc_index_one_node);
}
/* Done, register stuff as init / cleanup code. */
gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
gfc_finish_block (&se.post));
}
/* Do a scalar pointer assignment; this is for scalar variable targets. */
else if (gfc_is_associate_pointer (sym))
{
gfc_se se;
gcc_assert (!sym->attr.dimension);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, e);
tmp = TREE_TYPE (sym->backend_decl);
tmp = gfc_build_addr_expr (tmp, se.expr);
gfc_add_modify (&se.pre, sym->backend_decl, tmp);
gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
gfc_finish_block (&se.post));
}
/* Do a simple assignment. This is for scalar expressions, where we
can simply use expression assignment. */
else
{
gfc_expr *lhs;
lhs = gfc_lval_expr_from_sym (sym);
tmp = gfc_trans_assignment (lhs, e, false, true);
gfc_add_init_cleanup (block, tmp, NULL_TREE);
}
}
/* Translate a BLOCK construct. This is basically what we would do for a
procedure body. */
@ -877,6 +962,7 @@ gfc_trans_block_construct (gfc_code* code)
gfc_wrapped_block block;
tree exit_label;
stmtblock_t body;
gfc_association_list *ass;
ns = code->ext.block.ns;
gcc_assert (ns);
@ -886,7 +972,7 @@ gfc_trans_block_construct (gfc_code* code)
/* Process local variables. */
gcc_assert (!sym->tlink);
sym->tlink = sym;
gfc_process_block_locals (ns, code->ext.block.assoc);
gfc_process_block_locals (ns);
/* Generate code including exit-label. */
gfc_init_block (&body);
@ -898,7 +984,9 @@ gfc_trans_block_construct (gfc_code* code)
/* Finish everything. */
gfc_start_wrapped_block (&block, gfc_finish_block (&body));
gfc_trans_deferred_vars (sym, &block);
for (ass = code->ext.block.assoc; ass; ass = ass->next)
trans_associate_var (ass->st->n.sym, &block);
return gfc_finish_wrapped_block (&block);
}

2
gcc/fortran/trans.h
View File

@ -554,7 +554,7 @@ tree gfc_build_library_function_decl_with_spec (tree name, const char *spec,
tree rettype, int nargs, ...);
/* Process the local variable decls of a block construct. */
void gfc_process_block_locals (gfc_namespace*, gfc_association_list*);
void gfc_process_block_locals (gfc_namespace*);
/* Output initialization/clean-up code that was deferred. */
void gfc_trans_deferred_vars (gfc_symbol*, gfc_wrapped_block *);

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2010-11-25 Janus Weil <janus@gcc.gnu.org>
PR fortran/46581
* gfortran.dg/select_type_19.f03: New.
2010-11-25 Nicola Pero <nicola.pero@meta-innovation.com>
* objc.dg/ivar-problem-1.m: New.

23
gcc/testsuite/gfortran.dg/select_type_19.f03 Normal file
View File

@ -0,0 +1,23 @@
! { dg-do run }
!
! PR 46581: [4.6 Regression] [OOP] segfault in SELECT TYPE with associate-name
!
! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
implicit none
type :: t1
integer, allocatable :: ja(:)
end type
class(t1), allocatable :: a
allocate(a)
select type (aa=>a)
type is (t1)
if (allocated(aa%ja)) call abort()
end select
end