From patchwork Tue May 1 21:10:42 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 156240 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 A4461B6FAA for ; Wed, 2 May 2012 07:11:19 +1000 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1336511481; h=Comment: DomainKey-Signature:Received:Received:Received:Received: MIME-Version:Received:Received:In-Reply-To:References:Date: Message-ID:Subject:From:To:Cc:Content-Type:Mailing-List: Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:Sender:Delivered-To; bh=oZ2kpwp3kWvgoUyVZfkHFx4EpWw=; b=AvGdi9vZLCPScTLo9Wi+caL9sFqwFD0e/iHh5E7ySWsBW/J9wZ1e1Ci42Aluhd ffb0YmRQFBnTAxPYXmCxE+D2dzrNJ3QMDoipYlO6EDHv9znrvxgRVR+yzbvAsrH/ sY101xapgOhdnltraYtXDg8450nTGfxXd/P3tcJ0xurDQ= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:MIME-Version:Received:Received:In-Reply-To:References:Date:Message-ID:Subject:From:To:Cc:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=sMhItEYhS6CGED9DO61JnYo4Nr9fdcJkLDtByDUGThKIeohU79LVdjG/viYshx k5YJN/9O1rsXGYfJPGwiOZuUjna5JFZeY3ohlEq0L9CmalK1lEZIrXr81U0TFW5j LqPs36TTG9N+fNFNSrbNr35Bp2k2YLpCvIQPUjw7yaJvM=; Received: (qmail 4238 invoked by alias); 1 May 2012 21:11:11 -0000 Received: (qmail 3790 invoked by uid 22791); 1 May 2012 21:11:02 -0000 X-SWARE-Spam-Status: No, hits=-4.7 required=5.0 tests=AWL, BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, FREEMAIL_FROM, KHOP_RCVD_TRUST, KHOP_THREADED, RCVD_IN_DNSWL_LOW, RCVD_IN_HOSTKARMA_YE, TW_VP X-Spam-Check-By: sourceware.org Received: from mail-gy0-f175.google.com (HELO mail-gy0-f175.google.com) (209.85.160.175) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 01 May 2012 21:10:43 +0000 Received: by ghbz2 with SMTP id z2so2511569ghb.20 for ; Tue, 01 May 2012 14:10:42 -0700 (PDT) MIME-Version: 1.0 Received: by 10.60.7.196 with SMTP id l4mr32500879oea.8.1335906642547; Tue, 01 May 2012 14:10:42 -0700 (PDT) Received: by 10.182.154.100 with HTTP; Tue, 1 May 2012 14:10:42 -0700 (PDT) In-Reply-To: <4F665ED1.8000601@net-b.de> References: <4F665ED1.8000601@net-b.de> Date: Tue, 1 May 2012 23:10:42 +0200 Message-ID: Subject: Re: [Patch, fortran] PR41600 - [OOP] SELECT TYPE with associate-name => exp: Arrays not supported From: Paul Richard Thomas To: Tobias Burnus Cc: fortran@gcc.gnu.org, gcc-patches 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 Dear Tobias, dear all, Please accept my apologies for the long delay in responding to the review. A combination of overwhelming daytime works and a complete failure of my workstation at home have knocked me out for the last six weeks. Find attached a revised patch to fix PR 41600. On Sun, Mar 18, 2012 at 11:16 PM, Tobias Burnus wrote: > Dear Paul, > > thanks for the patch. > > Paul Richard Thomas wrote: >> >> + /* Transfer the selector typespec to the associate name.  */ >> + >> + copy_ts_from_selector_to_associate (gfc_expr *expr1, gfc_expr *expr2) >> + { > >  I think it is not obvious which type spec is which. Maybe you could add a > "(expr1)" and "(expr2)"  in the comment. (Alternatively, one could rename > expr1 and expr2.) Done - expr1 and expr2 are re > >> +   if (expr2->ts.type == BT_CLASS >> +       &&  CLASS_DATA (expr2)->as >> +       &&  expr2->ref&&  expr2->ref->type == REF_ARRAY) >> +     { >> +       if (expr2->ref->u.ar.type == AR_FULL) >> +       expr2->rank = CLASS_DATA (expr2)->as->rank; >> +       else if (expr2->ref->u.ar.type == AR_SECTION) >> +       expr2->rank = expr2->ref->u.ar.dimen; >> +     } > > > I have a bad feeling about that one for code like: >  dt%class(1:2) >  class%class(1:2) >  dt(1:2)%class >  class(1:2)%class > I fear that at least one of those will fail. In any case, assuming that - if > the last ref is BT_CLASS - the expr->ref is the right one, looks wrong. But > I might have missed some fine print and it is guaranteed to be always the > correct. This has been improved to ensure that the references are correctly treated. Note that array_ref%class is now excluded, except for scalars; see select_type_28.f03 Select_type_27.f03 deals with class%array_ref > >> +   /* Logic is a LOT clearer with separate functions for class and >> derived >> +      type temporaries! There are not many more lines of code either.  */ >>     if (ts->type == BT_CLASS) >> !     tmp = select_class_set_tmp (ts); >> !   else >> !     tmp = select_derived_set_tmp (ts); > > > While I concur with the comment, I think one should remove it. As patch > explanation it makes sense, but as committed it is not helpful. Done > >>     gfc_add_type (tmp->n.sym, ts, NULL); >> >> ! /* Copy across the array spec to the selector, taking care as to >> !    whether or not it is a class object or not.  */ > > > The indention looks wrong. FIxed > > >> (iii) The error that is thrown in resolve_assoc_var is necessary >> because wrong code is produced at the moment since the size of the >> declared type, rather than the dynamic type, is used for allocation of >> the temporary.  The necessary machinery is in place to fix this and I >> will do so soon > > > I assume that's: >> >> !       gfc_error ("CLASS selector at %L needs a temporary which is not " >> !                "yet implemented",&target->where); > > > But I think one should also look into: >> >> !      TODO Understand why class scalar expressions must be excluded.  */ >> !   if (sym->assoc&&  !(sym->ts.type == BT_CLASS&&  e->rank == 0)) I still do not see this but undertake to fix/understand. > > > Overall, the patch looks okay - I am just unsure about the expr2->ref usage > in copy_ts_from_selector_to_associate. Thanks for the review - I hope that the new version is satisfactory. Cheers Paul See above. 2012-05-01 Paul Thomas PR fortran/41600 * trans-array.c (build_array_ref): New static function. (gfc_conv_array_ref, gfc_get_dataptr_offset): Call it. * trans-expr.c (gfc_get_vptr_from_expr): New function. (gfc_conv_derived_to_class): Add a new argument for a caller supplied vptr and use it if it is not NULL. (gfc_conv_procedure_call): Add NULL to call to above. symbol.c (gfc_is_associate_pointer): Return true if symbol is a class object. * trans-stmt.c (trans_associate_var): Handle class associate- names. * expr.c (gfc_get_variable_expr): Supply the array-spec if possible. * trans-types.c (gfc_typenode_for_spec): Set GFC_CLASS_TYPE_P for class types. * trans.h : Add prototypes for gfc_get_vptr_from_expr and gfc_conv_derived_to_class. Define GFC_CLASS_TYPE_P. * resolve.c (resolve_variable): For class arrays, ensure that the target expression has all the necessary _data references. (resolve_assoc_var): Throw a "not yet implemented" error for class array selectors that need a temporary. * match.c (copy_ts_from_selector_to_associate, select_derived_set_tmp, select_class_set_tmp): New functions. (select_type_set_tmp): Call one of last two new functions. (gfc_match_select_type): Copy_ts_from_selector_to_associate is called if associate-name is typed. 2012-05-01 Paul Thomas PR fortran/41600 * gfortran.dg/select_type_26.f03 : New test. * gfortran.dg/select_type_27.f03 : New test. * gfortran.dg/select_type_28.f03 : New test. Index: gcc/fortran/trans-expr.c =================================================================== *** gcc/fortran/trans-expr.c (revision 186918) --- gcc/fortran/trans-expr.c (working copy) *************** gfc_vtable_copy_get (tree decl) *** 147,157 **** #undef VTABLE_COPY_FIELD /* Takes a derived type expression and returns the address of a temporary ! class object of the 'declared' type. */ ! static void gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, ! gfc_typespec class_ts) { gfc_symbol *vtab; gfc_ss *ss; --- 147,171 ---- #undef VTABLE_COPY_FIELD + /* Obtain the vptr of the last class reference in an expression. */ + + tree + gfc_get_vptr_from_expr (tree expr) + { + tree tmp = expr; + while (tmp && !GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) + tmp = TREE_OPERAND (tmp, 0); + tmp = gfc_class_vptr_get (tmp); + return tmp; + } + + /* Takes a derived type expression and returns the address of a temporary ! class object of the 'declared' type. If vptr is not NULL, this is ! used for the temporary class object. */ ! void gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, ! gfc_typespec class_ts, tree vptr) { gfc_symbol *vtab; gfc_ss *ss; *************** gfc_conv_derived_to_class (gfc_se *parms *** 167,177 **** /* Set the vptr. */ ctree = gfc_class_vptr_get (var); ! /* Remember the vtab corresponds to the derived type ! not to the class declared type. */ ! vtab = gfc_find_derived_vtab (e->ts.u.derived); ! gcc_assert (vtab); ! tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp)); --- 181,199 ---- /* Set the vptr. */ ctree = gfc_class_vptr_get (var); ! if (vptr != NULL_TREE) ! { ! /* Use the dynamic vptr. */ ! tmp = vptr; ! } ! else ! { ! /* In this case the vtab corresponds to the derived type and the ! vptr must point to it. */ ! vtab = gfc_find_derived_vtab (e->ts.u.derived); ! gcc_assert (vtab); ! tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); ! } gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp)); *************** gfc_conv_procedure_call (gfc_se * se, gf *** 3531,3537 **** /* The derived type needs to be converted to a temporary CLASS object. */ gfc_init_se (&parmse, se); ! gfc_conv_derived_to_class (&parmse, e, fsym->ts); } else if (se->ss && se->ss->info->useflags) { --- 3553,3559 ---- /* The derived type needs to be converted to a temporary CLASS object. */ gfc_init_se (&parmse, se); ! gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL); } else if (se->ss && se->ss->info->useflags) { Index: gcc/fortran/trans-array.c =================================================================== *** gcc/fortran/trans-array.c (revision 186918) --- gcc/fortran/trans-array.c (working copy) *************** add_to_offset (tree *cst_offset, tree *o *** 3068,3073 **** --- 3068,3103 ---- } } + + static tree + build_array_ref (tree desc, tree offset, tree decl) + { + tree tmp; + + /* Class array references need special treatment because the assigned + type size needs to be used to point to the element. */ + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) + && TREE_CODE (desc) == COMPONENT_REF + && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0)))) + { + tree type = gfc_get_element_type (TREE_TYPE (desc)); + tmp = TREE_OPERAND (desc, 0); + tmp = gfc_get_class_array_ref (offset, tmp); + tmp = fold_convert (build_pointer_type (type), tmp); + tmp = build_fold_indirect_ref_loc (input_location, tmp); + } + else + { + tmp = gfc_conv_array_data (desc); + tmp = build_fold_indirect_ref_loc (input_location, tmp); + tmp = gfc_build_array_ref (tmp, offset, decl); + } + + return tmp; + } + + + /* Build an array reference. se->expr already holds the array descriptor. This should be either a variable, indirect variable reference or component reference. For arrays which do not have a descriptor, se->expr will be *************** gfc_conv_array_ref (gfc_se * se, gfc_arr *** 3195,3204 **** offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, offset, cst_offset); ! /* Access the calculated element. */ ! tmp = gfc_conv_array_data (se->expr); ! tmp = build_fold_indirect_ref (tmp); ! se->expr = gfc_build_array_ref (tmp, offset, sym->backend_decl); } --- 3225,3231 ---- offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, offset, cst_offset); ! se->expr = build_array_ref (se->expr, offset, sym->backend_decl); } *************** gfc_get_dataptr_offset (stmtblock_t *blo *** 6010,6019 **** return; } ! tmp = gfc_conv_array_data (desc); ! tmp = build_fold_indirect_ref_loc (input_location, ! tmp); ! tmp = gfc_build_array_ref (tmp, offset, NULL); /* Offset the data pointer for pointer assignments from arrays with subreferences; e.g. my_integer => my_type(:)%integer_component. */ --- 6037,6043 ---- return; } ! tmp = build_array_ref (desc, offset, NULL); /* Offset the data pointer for pointer assignments from arrays with subreferences; e.g. my_integer => my_type(:)%integer_component. */ Index: gcc/fortran/symbol.c =================================================================== *** gcc/fortran/symbol.c (revision 186918) --- gcc/fortran/symbol.c (working copy) *************** gfc_is_associate_pointer (gfc_symbol* sy *** 4882,4887 **** --- 4882,4890 ---- if (!sym->assoc) return false; + if (sym->ts.type == BT_CLASS) + return true; + if (!sym->assoc->variable) return false; Index: gcc/fortran/trans-stmt.c =================================================================== *** gcc/fortran/trans-stmt.c (revision 186918) --- gcc/fortran/trans-stmt.c (working copy) *************** trans_associate_var (gfc_symbol *sym, gf *** 1140,1145 **** --- 1140,1149 ---- gfc_expr *e; tree tmp; bool class_target; + tree desc; + tree offset; + tree dim; + int n; gcc_assert (sym->assoc); e = sym->assoc->target; *************** trans_associate_var (gfc_symbol *sym, gf *** 1191,1198 **** gfc_finish_block (&se.post)); } ! /* CLASS arrays just need the descriptor to be directly assigned. */ ! else if (class_target && sym->attr.dimension) { gfc_se se; --- 1195,1203 ---- gfc_finish_block (&se.post)); } ! /* Derived type temporaries, arising from TYPE IS, just need the ! descriptor of class arrays to be assigned directly. */ ! else if (class_target && sym->ts.type == BT_DERIVED && sym->attr.dimension) { gfc_se se; *************** trans_associate_var (gfc_symbol *sym, gf *** 1217,1223 **** 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); --- 1222,1268 ---- gcc_assert (!sym->attr.dimension); gfc_init_se (&se, NULL); ! ! /* Class associate-names come this way because they are ! unconditionally associate pointers and the symbol is scalar. */ ! if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension) ! { ! /* For a class array we need a descriptor for the selector. */ ! gfc_conv_expr_descriptor (&se, e, gfc_walk_expr (e)); ! ! /* Obtain a temporary class container for the result. */ ! gfc_conv_class_to_class (&se, e, sym->ts, false); ! se.expr = build_fold_indirect_ref_loc (input_location, se.expr); ! ! /* Set the offset. */ ! desc = gfc_class_data_get (se.expr); ! offset = gfc_index_zero_node; ! for (n = 0; n < e->rank; n++) ! { ! dim = gfc_rank_cst[n]; ! tmp = fold_build2_loc (input_location, MULT_EXPR, ! gfc_array_index_type, ! gfc_conv_descriptor_stride_get (desc, dim), ! gfc_conv_descriptor_lbound_get (desc, dim)); ! offset = fold_build2_loc (input_location, MINUS_EXPR, ! gfc_array_index_type, ! offset, tmp); ! } ! gfc_conv_descriptor_offset_set (&se.pre, desc, offset); ! } ! else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS ! && CLASS_DATA (e)->attr.dimension) ! { ! /* This is bound to be a class array element. */ ! gfc_conv_expr_reference (&se, e); ! /* Get the _vptr component of the class object. */ ! tmp = gfc_get_vptr_from_expr (se.expr); ! /* Obtain a temporary class container for the result. */ ! gfc_conv_derived_to_class (&se, e, sym->ts, tmp); ! se.expr = build_fold_indirect_ref_loc (input_location, se.expr); ! } ! else ! gfc_conv_expr (&se, e); tmp = TREE_TYPE (sym->backend_decl); tmp = gfc_build_addr_expr (tmp, se.expr); Index: gcc/fortran/expr.c =================================================================== *** gcc/fortran/expr.c (revision 186918) --- gcc/fortran/expr.c (working copy) *************** gfc_get_variable_expr (gfc_symtree *var) *** 3821,3826 **** --- 3821,3829 ---- e->ref = gfc_get_ref (); e->ref->type = REF_ARRAY; e->ref->u.ar.type = AR_FULL; + e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS + ? CLASS_DATA (var->n.sym)->as + : var->n.sym->as); } return e; Index: gcc/fortran/trans-types.c =================================================================== *** gcc/fortran/trans-types.c (revision 186918) --- gcc/fortran/trans-types.c (working copy) *************** gfc_typenode_for_spec (gfc_typespec * sp *** 1106,1111 **** --- 1106,1114 ---- case BT_CLASS: basetype = gfc_get_derived_type (spec->u.derived); + if (spec->type == BT_CLASS) + GFC_CLASS_TYPE_P (basetype) = 1; + /* If we're dealing with either C_PTR or C_FUNPTR, we modified the type and kind to fit a (void *) and the basetype returned was a ptr_type_node. We need to pass up this new information to the Index: gcc/fortran/trans.h =================================================================== *** gcc/fortran/trans.h (revision 186918) --- gcc/fortran/trans.h (working copy) *************** tree gfc_vtable_size_get (tree); *** 348,355 **** --- 348,357 ---- tree gfc_vtable_extends_get (tree); tree gfc_vtable_def_init_get (tree); tree gfc_vtable_copy_get (tree); + tree gfc_get_vptr_from_expr (tree); tree gfc_get_class_array_ref (tree, tree); tree gfc_copy_class_to_class (tree, tree, tree); + void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree); void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool); /* Initialize an init/cleanup block. */ *************** struct GTY((variable_size)) lang_decl { *** 827,832 **** --- 829,836 ---- #define GFC_ARRAY_TYPE_P(node) TYPE_LANG_FLAG_2(node) /* Fortran POINTER type. */ #define GFC_POINTER_TYPE_P(node) TYPE_LANG_FLAG_3(node) + /* Fortran CLASS type. */ + #define GFC_CLASS_TYPE_P(node) TYPE_LANG_FLAG_4(node) /* The GFC_TYPE_ARRAY_* members are present in both descriptor and descriptorless array types. */ #define GFC_TYPE_ARRAY_LBOUND(node, dim) \ Index: gcc/fortran/resolve.c =================================================================== *** gcc/fortran/resolve.c (revision 186918) --- gcc/fortran/resolve.c (working copy) *************** resolve_variable (gfc_expr *e) *** 5081,5089 **** } /* 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; if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic) sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived); --- 5081,5095 ---- } /* 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. ! TODO Understand why class scalar expressions must be excluded. */ ! if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0)) ! { ! if (sym->ts.type == BT_CLASS) ! gfc_fix_class_refs (e); ! if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY) ! return FAILURE; ! } if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic) sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived); *************** gfc_type_is_extensible (gfc_symbol *sym) *** 7928,7934 **** } ! /* Resolve an associate name: Resolve target and ensure the type-spec is correct as well as possibly the array-spec. */ static void --- 7934,7940 ---- } ! /* 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 *** 7984,7991 **** sym->attr.dimension = 0; return; } ! if (target->rank > 0) sym->attr.dimension = 1; if (sym->attr.dimension) { --- 7990,8037 ---- sym->attr.dimension = 0; return; } ! ! /* We cannot deal with class selectors that need temporaries. */ ! if (target->ts.type == BT_CLASS ! && gfc_ref_needs_temporary_p (target->ref)) ! { ! gfc_error ("CLASS selector at %L needs a temporary which is not " ! "yet implemented", &target->where); ! return; ! } ! ! if (target->ts.type == BT_CLASS) ! { ! gfc_ref *ref; ! bool seen_array = false; ! for (ref = target->ref; ref; ref = ref->next) ! { ! if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT) ! seen_array = true; ! ! if (!ref->next) ! break; ! } ! ! if (ref && ref->type != REF_ARRAY && seen_array) ! { ! gfc_error ("CLASS selector at %L is an array with CLASS " ! "components; this is not allowed since the " ! "elements could have different dynamic types", ! &target->where); ! return; ! } ! } ! ! if (target->ts.type != BT_CLASS && target->rank > 0) sym->attr.dimension = 1; + else if (target->ts.type == BT_CLASS) + gfc_fix_class_refs (target); + + /* The associate-name will have a correct type by now. Make absolutely + sure that it has not picked up a dimension attribute. */ + if (sym->ts.type == BT_CLASS) + sym->attr.dimension = 0; if (sym->attr.dimension) { Index: gcc/fortran/match.c =================================================================== *** gcc/fortran/match.c (revision 186918) --- gcc/fortran/match.c (working copy) *************** gfc_match_select (void) *** 5112,5117 **** --- 5112,5189 ---- } + /* Transfer the selector typespec to the associate name. */ + + static void + copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector) + { + gfc_ref *ref; + gfc_symbol *assoc_sym; + + assoc_sym = associate->symtree->n.sym; + + /* Ensure that any array reference is resolved. */ + gfc_resolve_expr (selector); + + /* At this stage the expression rank and arrayspec dimensions have + not been completely sorted out. We must get the expr2->rank + right here, so that the correct class container is obtained. */ + ref = selector->ref; + while (ref && ref->next) + ref = ref->next; + + if (selector->ts.type == BT_CLASS + && CLASS_DATA (selector)->as + && ref && ref->type == REF_ARRAY) + { + if (ref->u.ar.type == AR_FULL) + selector->rank = CLASS_DATA (selector)->as->rank; + else if (ref->u.ar.type == AR_SECTION) + selector->rank = ref->u.ar.dimen; + else + selector->rank = 0; + } + + if (selector->ts.type != BT_CLASS) + { + /* The correct class container has to be available. */ + if (selector->rank) + { + assoc_sym->attr.dimension = 1; + assoc_sym->as = gfc_get_array_spec (); + assoc_sym->as->rank = selector->rank; + assoc_sym->as->type = AS_DEFERRED; + } + else + assoc_sym->as = NULL; + + assoc_sym->ts.type = BT_CLASS; + assoc_sym->ts.u.derived = selector->ts.u.derived; + assoc_sym->attr.pointer = 1; + gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, + &assoc_sym->as, false); + } + else + { + /* The correct class container has to be available. */ + if (selector->rank) + { + assoc_sym->attr.dimension = 1; + assoc_sym->as = gfc_get_array_spec (); + assoc_sym->as->rank = selector->rank; + assoc_sym->as->type = AS_DEFERRED; + } + else + assoc_sym->as = NULL; + assoc_sym->ts.type = BT_CLASS; + assoc_sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived; + assoc_sym->attr.pointer = 1; + gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, + &assoc_sym->as, false); + } + } + + /* Push the current selector onto the SELECT TYPE stack. */ static void *************** select_type_push (gfc_symbol *sel) *** 5126,5189 **** } ! /* Set the temporary for the current SELECT TYPE selector. */ ! static void ! select_type_set_tmp (gfc_typespec *ts) { char name[GFC_MAX_SYMBOL_LEN]; gfc_symtree *tmp; ! if (!ts) { ! select_type_stack->tmp = NULL; ! return; } ! if (!gfc_type_is_extensible (ts->u.derived)) ! return; ! if (ts->type == BT_CLASS) ! sprintf (name, "__tmp_class_%s", ts->u.derived->name); ! else ! sprintf (name, "__tmp_type_%s", ts->u.derived->name); gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); gfc_add_type (tmp->n.sym, ts, NULL); ! /* Copy across the array spec to the selector, taking care as to ! whether or not it is a class object or not. */ if (select_type_stack->selector->ts.type == BT_CLASS - && select_type_stack->selector->attr.class_ok && (CLASS_DATA (select_type_stack->selector)->attr.dimension || CLASS_DATA (select_type_stack->selector)->attr.codimension)) { ! if (ts->type == BT_CLASS) ! { ! CLASS_DATA (tmp->n.sym)->attr.dimension = CLASS_DATA (select_type_stack->selector)->attr.dimension; ! CLASS_DATA (tmp->n.sym)->attr.codimension = CLASS_DATA (select_type_stack->selector)->attr.codimension; ! CLASS_DATA (tmp->n.sym)->as = gfc_get_array_spec (); ! CLASS_DATA (tmp->n.sym)->as ! = CLASS_DATA (select_type_stack->selector)->as; ! } ! else ! { ! tmp->n.sym->attr.dimension ! = CLASS_DATA (select_type_stack->selector)->attr.dimension; ! tmp->n.sym->attr.codimension ! = CLASS_DATA (select_type_stack->selector)->attr.codimension; ! tmp->n.sym->as = gfc_get_array_spec (); ! tmp->n.sym->as = CLASS_DATA (select_type_stack->selector)->as; ! } } gfc_set_sym_referenced (tmp->n.sym); gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); tmp->n.sym->attr.select_type_temporary = 1; if (ts->type == BT_CLASS) ! gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr, ! &tmp->n.sym->as, false); /* Add an association for it, so the rest of the parser knows it is an associate-name. The target will be set during resolution. */ --- 5198,5300 ---- } ! /* Set the temporary for the current derived type SELECT TYPE selector. */ ! static gfc_symtree * ! select_derived_set_tmp (gfc_typespec *ts) { char name[GFC_MAX_SYMBOL_LEN]; gfc_symtree *tmp; ! sprintf (name, "__tmp_type_%s", ts->u.derived->name); ! gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); ! gfc_add_type (tmp->n.sym, ts, NULL); ! ! /* Copy across the array spec to the selector. */ ! if (select_type_stack->selector->ts.type == BT_CLASS ! && select_type_stack->selector->attr.class_ok ! && (CLASS_DATA (select_type_stack->selector)->attr.dimension ! || CLASS_DATA (select_type_stack->selector)->attr.codimension)) { ! tmp->n.sym->attr.dimension ! = CLASS_DATA (select_type_stack->selector)->attr.dimension; ! tmp->n.sym->attr.codimension ! = CLASS_DATA (select_type_stack->selector)->attr.codimension; ! tmp->n.sym->as ! = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as); } + + gfc_set_sym_referenced (tmp->n.sym); + gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); + tmp->n.sym->attr.select_type_temporary = 1; + + return tmp; + } + + + /* Set the temporary for the current class SELECT TYPE selector. */ + + static gfc_symtree * + select_class_set_tmp (gfc_typespec *ts) + { + char name[GFC_MAX_SYMBOL_LEN]; + gfc_symtree *tmp; ! if (select_type_stack->selector->ts.type == BT_CLASS ! && !select_type_stack->selector->attr.class_ok) ! return NULL; ! sprintf (name, "__tmp_class_%s", ts->u.derived->name); gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); gfc_add_type (tmp->n.sym, ts, NULL); ! /* Copy across the array spec to the selector. */ if (select_type_stack->selector->ts.type == BT_CLASS && (CLASS_DATA (select_type_stack->selector)->attr.dimension || CLASS_DATA (select_type_stack->selector)->attr.codimension)) { ! tmp->n.sym->attr.pointer = 1; ! tmp->n.sym->attr.dimension = CLASS_DATA (select_type_stack->selector)->attr.dimension; ! tmp->n.sym->attr.codimension = CLASS_DATA (select_type_stack->selector)->attr.codimension; ! tmp->n.sym->as ! = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as); } gfc_set_sym_referenced (tmp->n.sym); gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); tmp->n.sym->attr.select_type_temporary = 1; + gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr, + &tmp->n.sym->as, false); + + return tmp; + } + + + static void + select_type_set_tmp (gfc_typespec *ts) + { + gfc_symtree *tmp; + + if (!ts) + { + select_type_stack->tmp = NULL; + return; + } + + if (!gfc_type_is_extensible (ts->u.derived)) + return; + + /* Logic is a LOT clearer with separate functions for class and derived + type temporaries! There are not many more lines of code either. */ if (ts->type == BT_CLASS) ! tmp = select_class_set_tmp (ts); ! else ! tmp = select_derived_set_tmp (ts); ! ! if (tmp == NULL) ! return; /* Add an association for it, so the rest of the parser knows it is an associate-name. The target will be set during resolution. */ *************** select_type_set_tmp (gfc_typespec *ts) *** 5194,5200 **** select_type_stack->tmp = tmp; } ! /* Match a SELECT TYPE statement. */ match --- 5305,5311 ---- select_type_stack->tmp = tmp; } ! /* Match a SELECT TYPE statement. */ match *************** gfc_match_select_type (void) *** 5204,5209 **** --- 5315,5321 ---- match m; char name[GFC_MAX_SYMBOL_LEN]; bool class_array; + gfc_symbol *sym; m = gfc_match_label (); if (m == MATCH_ERROR) *************** gfc_match_select_type (void) *** 5225,5237 **** m = MATCH_ERROR; goto cleanup; } if (expr2->ts.type == BT_UNKNOWN) ! expr1->symtree->n.sym->attr.untyped = 1; else ! expr1->symtree->n.sym->ts = expr2->ts; ! expr1->symtree->n.sym->attr.flavor = FL_VARIABLE; ! expr1->symtree->n.sym->attr.referenced = 1; ! expr1->symtree->n.sym->attr.class_ok = 1; } else { --- 5337,5352 ---- m = MATCH_ERROR; goto cleanup; } + + sym = expr1->symtree->n.sym; if (expr2->ts.type == BT_UNKNOWN) ! sym->attr.untyped = 1; else ! copy_ts_from_selector_to_associate (expr1, expr2); ! ! sym->attr.flavor = FL_VARIABLE; ! sym->attr.referenced = 1; ! sym->attr.class_ok = 1; } else { Index: gcc/testsuite/gfortran.dg/select_type_26.f03 =================================================================== *** gcc/testsuite/gfortran.dg/select_type_26.f03 (revision 0) --- gcc/testsuite/gfortran.dg/select_type_26.f03 (revision 0) *************** *** 0 **** --- 1,109 ---- + ! { dg-do run } + ! Tests fix for PR41600 and further SELECT TYPE functionality. + ! + ! Reported by Tobias Burnus + ! + implicit none + type t0 + integer :: j = 42 + end type t0 + + type, extends(t0) :: t1 + integer :: k = 99 + end type t1 + + type t + integer :: i + class(t0), allocatable :: foo(:) + end type t + + type t_scalar + integer :: i + class(t0), allocatable :: foo + end type t_scalar + + type(t) :: m + type(t_scalar) :: m1(4) + integer :: n + + ! Test the fix for PR41600 itself - first with m%foo of declared type. + allocate(m%foo(3), source = [(t0(n), n = 1,3)]) + select type(bar => m%foo) + type is(t0) + if (any (bar%j .ne. [1,2,3])) call abort + type is(t1) + call abort + end select + + deallocate(m%foo) + allocate(m%foo(3), source = [(t1(n, n*10), n = 4,6)]) + + ! Then with m%foo of another dynamic type. + select type(bar => m%foo) + type is(t0) + call abort + type is(t1) + if (any (bar%k .ne. [40,50,60])) call abort + end select + + ! Try it with a selector array section. + select type(bar => m%foo(2:3)) + type is(t0) + call abort + type is(t1) + if (any (bar%k .ne. [50,60])) call abort + end select + + ! Try it with a selector array element. + select type(bar => m%foo(2)) + type is(t0) + call abort + type is(t1) + if (bar%k .ne. 50) call abort + end select + + ! Now try class is and a selector which is an array section of an associate name. + select type(bar => m%foo) + type is(t0) + call abort + class is (t1) + if (any (bar%j .ne. [4,5,6])) call abort + select type (foobar => bar(3:2:-1)) + type is (t1) + if (any (foobar%k .ne. [60,50])) call abort + end select + end select + + ! Now try class is and a selector which is an array element of an associate name. + select type(bar => m%foo) + type is(t0) + call abort + class is (t1) + if (any (bar%j .ne. [4,5,6])) call abort + select type (foobar => bar(2)) + type is (t1) + if (foobar%k .ne. 50) call abort + end select + end select + + ! Check class a component of an element of an array. Note that an array of such + ! objects cannot be allowed since the elements could have different dynamic types. + do n = 1, 2 + allocate(m1(n)%foo, source = t1(n*99, n*999)) + end do + do n = 3, 4 + allocate(m1(n)%foo, source = t0(n*99)) + end do + select type(bar => m1(3)%foo) + type is(t0) + if (bar%j .ne. 297) call abort + type is(t1) + call abort + end select + select type(bar => m1(1)%foo) + type is(t0) + call abort + type is(t1) + if (bar%k .ne. 999) call abort + end select + end Index: gcc/testsuite/gfortran.dg/select_type_27.f03 =================================================================== *** gcc/testsuite/gfortran.dg/select_type_27.f03 (revision 0) --- gcc/testsuite/gfortran.dg/select_type_27.f03 (revision 0) *************** *** 0 **** --- 1,114 ---- + ! { dg-do run } + ! Tests fix for PR41600 and further SELECT TYPE functionality. + ! This differs from the original and select_type_26.f03 by 'm' + ! being a class object rather than a derived type. + ! + ! Reported by Tobias Burnus + ! + implicit none + type t0 + integer :: j = 42 + end type t0 + + type, extends(t0) :: t1 + integer :: k = 99 + end type t1 + + type t + integer :: i + class(t0), allocatable :: foo(:) + end type t + + type t_scalar + integer :: i + class(t0), allocatable :: foo + end type t_scalar + + class(t), allocatable :: m + class(t_scalar), allocatable :: m1(:) + integer :: n + + allocate (m) + allocate (m1(4)) + + ! Test the fix for PR41600 itself - first with m%foo of declared type. + allocate(m%foo(3), source = [(t0(n), n = 1,3)]) + select type(bar => m%foo) + type is(t0) + if (any (bar%j .ne. [1,2,3])) call abort + type is(t1) + call abort + end select + + deallocate(m%foo) + allocate(m%foo(3), source = [(t1(n, n*10), n = 4,6)]) + + ! Then with m%foo of another dynamic type. + select type(bar => m%foo) + type is(t0) + call abort + type is(t1) + if (any (bar%k .ne. [40,50,60])) call abort + end select + + ! Try it with a selector array section. + select type(bar => m%foo(2:3)) + type is(t0) + call abort + type is(t1) + if (any (bar%k .ne. [50,60])) call abort + end select + + ! Try it with a selector array element. + select type(bar => m%foo(2)) + type is(t0) + call abort + type is(t1) + if (bar%k .ne. 50) call abort + end select + + ! Now try class is and a selector which is an array section of an associate name. + select type(bar => m%foo) + type is(t0) + call abort + class is (t1) + if (any (bar%j .ne. [4,5,6])) call abort + select type (foobar => bar(3:2:-1)) + type is (t1) + if (any (foobar%k .ne. [60,50])) call abort + end select + end select + + ! Now try class is and a selector which is an array element of an associate name. + select type(bar => m%foo) + type is(t0) + call abort + class is (t1) + if (any (bar%j .ne. [4,5,6])) call abort + select type (foobar => bar(2)) + type is (t1) + if (foobar%k .ne. 50) call abort + end select + end select + + ! Check class a component of an element of an array. Note that an array of such + ! objects cannot be allowed since the elements could have different dynamic types. + do n = 1, 2 + allocate(m1(n)%foo, source = t1(n*99, n*999)) + end do + do n = 3, 4 + allocate(m1(n)%foo, source = t0(n*99)) + end do + select type(bar => m1(3)%foo) + type is(t0) + if (bar%j .ne. 297) call abort + type is(t1) + call abort + end select + select type(bar => m1(1)%foo) + type is(t0) + call abort + type is(t1) + if (bar%k .ne. 999) call abort + end select + end Index: gcc/testsuite/gfortran.dg/select_type_28.f03 =================================================================== *** gcc/testsuite/gfortran.dg/select_type_28.f03 (revision 0) --- gcc/testsuite/gfortran.dg/select_type_28.f03 (revision 0) *************** *** 0 **** --- 1,35 ---- + ! { dg-do compile } + ! SELECT TYPE. + ! + implicit none + type t0 + integer :: j = 42 + end type t0 + type, extends(t0) :: t1 + integer :: k = 99 + end type t1 + type t + integer :: i + class(t0), allocatable :: foo + end type t + type(t) :: m(4) + integer :: n + + do n = 1, 2 + allocate(m(n)%foo, source = t0(n*99)) + end do + do n = 3, 4 + allocate(m(n)%foo, source = t1(n*99, n*999)) + end do + + ! An array of objects with ultimate class components cannot be a selector + ! since each element could have a different dynamic type. + + select type(bar => m%foo) ! { dg-error "is an array with CLASS components" } + type is(t0) + if (any (bar%j .ne. [99, 198, 297, 396])) call abort + type is(t1) + call abort + end select + + end