+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
}
-/* 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.
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)
{
/* 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)
{
}
+/* 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. */
gfc_wrapped_block block;
tree exit_label;
stmtblock_t body;
+ gfc_association_list *ass;
ns = code->ext.block.ns;
gcc_assert (ns);
/* 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);
/* 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);
}
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 *);
+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.
--- /dev/null
+! { 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
projects / platform / upstream / linaro-gcc.git / commitdiff