From patchwork Thu Aug 26 10:31:19 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Daniel Kraft X-Patchwork-Id: 62769 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 77A7DB70DA for ; Thu, 26 Aug 2010 20:26:16 +1000 (EST) Received: (qmail 27732 invoked by alias); 26 Aug 2010 10:26:13 -0000 Received: (qmail 27712 invoked by uid 22791); 26 Aug 2010 10:26:09 -0000 X-SWARE-Spam-Status: No, hits=-2.5 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_LOW, SPF_HELO_PASS X-Spam-Check-By: sourceware.org Received: from taro.utanet.at (HELO taro.utanet.at) (213.90.36.45) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 26 Aug 2010 10:26:01 +0000 Received: from plenty.xoc.tele2net.at ([213.90.36.8]) by taro.utanet.at with esmtp (Exim 4.71) (envelope-from ) id 1OoZeg-0005nN-DI; Thu, 26 Aug 2010 12:25:58 +0200 Received: from d86-33-197-85.cust.tele2.at ([86.33.197.85] helo=[192.168.1.18]) by plenty.xoc.tele2net.at with esmtpa (Exim 4.71) (envelope-from ) id 1OoZef-0003bb-NO; Thu, 26 Aug 2010 12:25:58 +0200 Message-ID: <4C764277.5050904@domob.eu> Date: Thu, 26 Aug 2010 12:31:19 +0200 From: Daniel Kraft User-Agent: Thunderbird 2.0.0.0 (X11/20070425) MIME-Version: 1.0 To: Fortran List , gcc-patches Subject: Re: [Patch, Fortran] SELECT TYPE via ASSOCIATE References: <4C762FED.7020609@domob.eu> In-Reply-To: <4C762FED.7020609@domob.eu> Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Daniel Kraft wrote: > Hi, > > the attached patch fixes ASSOCIATE for polymorphic values and switches > the current implementation of SELECT TYPE to using ASSOCIATE internally. > As a side-effect, this fixes the "double-free" PRs 44047 and 45384. I > also think that the still missing piece (comment #3) of PR 44044 will be > fixed when the testing for variable definition contexts in ASSOCIATE is > extended (but so far the problem is still not detected). > > Regtested on GNU/Linux-x86-32. The only failure was bessel_7.f90, which > goes away when I increase the tolerance according to > http://gcc.gnu.org/ml/fortran/2010-08/msg00308.html. Ok for trunk? As Dominique spotted a bug in this patch, here's an update which hopefully fixes the problem. The only relative change is the new st.c update. Daniel Index: gcc/fortran/symbol.c =================================================================== --- gcc/fortran/symbol.c (revision 163540) +++ gcc/fortran/symbol.c (working copy) @@ -2499,6 +2499,9 @@ gfc_free_symbol (gfc_symbol *sym) gfc_free_namespace (sym->f2k_derived); + if (sym->assoc && sym->assoc->dangling) + gfc_free_association_list (sym->assoc); + gfc_free (sym); } Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (revision 163540) +++ gcc/fortran/gfortran.h (working copy) @@ -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 /* 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 *); Index: gcc/fortran/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (revision 163540) +++ gcc/fortran/trans-stmt.c (working copy) @@ -860,7 +860,7 @@ gfc_trans_block_construct (gfc_code* cod 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); Index: gcc/fortran/trans.h =================================================================== --- gcc/fortran/trans.h (revision 163540) +++ gcc/fortran/trans.h (working copy) @@ -538,7 +538,7 @@ tree gfc_build_library_function_decl_wit 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 *); Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (revision 163540) +++ gcc/fortran/resolve.c (working copy) @@ -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; + + 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; - /* Put SELECT TYPE statement inside a BLOCK. */ + /* 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) + 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->op = EXEC_POINTER_ASSIGN; - gfc_add_component_ref (new_st->expr2, "$data"); + new_st->ext.block.assoc = st->n.sym->assoc; + st->n.sym->assoc->dangling = 0; } - else - new_st->op = EXEC_POINTER_ASSIGN; - new_st->next = body->next; - body->next = new_st; + + 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 } /* 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) Index: gcc/fortran/st.c =================================================================== --- gcc/fortran/st.c (revision 163540) +++ gcc/fortran/st.c (working copy) @@ -242,5 +242,11 @@ gfc_free_association_list (gfc_associati return; gfc_free_association_list (assoc->next); + + /* Make sure to unregister the association from the symbol, so that + we don't try to access it from now on. */ + if (assoc->st) + assoc->st->n.sym->assoc = NULL; + gfc_free (assoc); } Index: gcc/fortran/trans-decl.c =================================================================== --- gcc/fortran/trans-decl.c (revision 163540) +++ gcc/fortran/trans-decl.c (working copy) @@ -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)) @@ -4831,13 +4831,22 @@ gfc_generate_block_data (gfc_namespace * /* 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) { Index: gcc/fortran/match.c =================================================================== --- gcc/fortran/match.c (revision 163540) +++ gcc/fortran/match.c (working copy) @@ -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; } Index: gcc/fortran/parse.h =================================================================== --- gcc/fortran/parse.h (revision 163540) +++ gcc/fortran/parse.h (working copy) @@ -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 */ Index: gcc/testsuite/gfortran.dg/select_type_13.f03 =================================================================== --- gcc/testsuite/gfortran.dg/select_type_13.f03 (revision 0) +++ gcc/testsuite/gfortran.dg/select_type_13.f03 (revision 0) @@ -0,0 +1,26 @@ +! { dg-do run } + +! PR fortran/45384 +! Double free happened, check that it works now. + +! Contributed by Janus Weil, janus@gcc.gnu.org. + +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 Index: gcc/testsuite/gfortran.dg/associate_8.f03 =================================================================== --- gcc/testsuite/gfortran.dg/associate_8.f03 (revision 0) +++ gcc/testsuite/gfortran.dg/associate_8.f03 (revision 0) @@ -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 Index: gcc/testsuite/gfortran.dg/select_type_14.f03 =================================================================== --- gcc/testsuite/gfortran.dg/select_type_14.f03 (revision 0) +++ gcc/testsuite/gfortran.dg/select_type_14.f03 (revision 0) @@ -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