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
Daniel Kraft
parent
707bcb7ae4
commit
3e78238a1e
12 changed files with 284 additions and 107 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 *);
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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 *);
|
||||
|
|
|
|||
|
|
@ -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
37
gcc/testsuite/gfortran.dg/associate_8.f03
Normal 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
26
gcc/testsuite/gfortran.dg/select_type_13.f03
Normal 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
24
gcc/testsuite/gfortran.dg/select_type_14.f03
Normal 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
|
||||
Loading…
Add table
Reference in a new issue