diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 58eaf155616..4377bd2e0da 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,28 @@ +2010-08-26 Daniel Kraft + + 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 * trans-decl.c (gfc_build_intrinsic_function_decls): Set diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 9fb46d55dc2..689b9df636b 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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 *); diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index c1cef962248..21dbcde8b7b 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -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; } diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 65d1a7e604a..3fac1c774b7 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -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 */ diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 1d56ec6a867..68faf8be815 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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) diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 5a73b4cd97e..af54a7de004 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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) { diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 44195870bcc..747f08a20b0 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -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); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 04934e50e6d..ff91413edf5 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -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 *); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8eb2f3a322f..5da1f904b1a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2010-08-26 Daniel Kraft + + 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 PR tree-optimization/44485 diff --git a/gcc/testsuite/gfortran.dg/associate_8.f03 b/gcc/testsuite/gfortran.dg/associate_8.f03 new file mode 100644 index 00000000000..0c95acb8c2b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_8.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/select_type_13.f03 b/gcc/testsuite/gfortran.dg/select_type_13.f03 new file mode 100644 index 00000000000..8546ccbe825 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_13.f03 @@ -0,0 +1,26 @@ +! { dg-do run } + +! PR fortran/45384 +! Double free happened, check that it works now. + +! Contributed by Salvatore Filippone + +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 diff --git a/gcc/testsuite/gfortran.dg/select_type_14.f03 b/gcc/testsuite/gfortran.dg/select_type_14.f03 new file mode 100644 index 00000000000..2d37bbc7f8b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_14.f03 @@ -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