OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/38936 ([F03] ASSOCIATE construct / improved SELECT TYPE (a=>expr)) 

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

From-SVN: r163572
This commit is contained in:
Daniel Kraft 2010-08-26 21:48:43 +02:00 committed by Daniel Kraft
parent 707bcb7ae4
commit 3e78238a1e
12 changed files with 284 additions and 107 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
gcc/fortran/ChangeLog
View File

@ -1,3 +1,28 @@
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.
* 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.
* 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-25 Jakub Jelinek <jakub@redhat.com>
* trans-decl.c (gfc_build_intrinsic_function_decls): Set

7
gcc/fortran/gfortran.h
View File

@ -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 *, FILE *);
/* 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 *);

6
gcc/fortran/match.c
View File

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

1
gcc/fortran/parse.h
View File

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

239
gcc/fortran/resolve.c
View File

@ -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;
/* Put SELECT TYPE statement inside a BLOCK. */
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;
/* 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)
{
new_st->op = EXEC_POINTER_ASSIGN;
gfc_add_component_ref (new_st->expr2, "$data");
}
else
new_st->op = EXEC_POINTER_ASSIGN;
new_st->next = body->next;
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->ext.block.assoc = st->n.sym->assoc;
st->n.sym->assoc->dangling = 0;
}
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, int mp_flag)
}
/* 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)

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

@ -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))
@ -4869,13 +4869,22 @@ gfc_generate_block_data (gfc_namespace * ns)
/* 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)
{

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

@ -860,7 +860,7 @@ gfc_trans_block_construct (gfc_code* code)
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);

2
gcc/fortran/trans.h
View File

@ -538,7 +538,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*);
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 *);

9
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,12 @@
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.
2010-08-26 Jakub Jelinek <jakub@redhat.com>
PR tree-optimization/44485

37
gcc/testsuite/gfortran.dg/associate_8.f03 Normal file
View File

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

26
gcc/testsuite/gfortran.dg/select_type_13.f03 Normal file
View File

@ -0,0 +1,26 @@
! { dg-do run }
! PR fortran/45384
! Double free happened, check that it works now.
! Contributed by Salvatore Filippone <salvatore.filippone@uniroma2.it>
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

24
gcc/testsuite/gfortran.dg/select_type_14.f03 Normal file
View File

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