From patchwork Thu Dec 18 18:41:31 2014 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 422636 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]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 7D58F1400B7 for ; Fri, 19 Dec 2014 05:42:02 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:in-reply-to:references :mime-version:content-type; q=dns; s=default; b=a02h/kCX6J+AU+0W A8dbNtgU7ylsAdcAQ/YxEYs9VO6EK3xdLKFzswrO++HQ0BdhlSrzOoXzcE8q/Aqn JkErjL7CNb2EZVl0xerfEjV4e0iGH6CNG/aO0OwHeEroMWpzIxTG+acES17gJ/KU Pb7bnv6zdgHGIcZ1m4DqhvkyTZ0= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:in-reply-to:references :mime-version:content-type; s=default; bh=VnJjB5REqvkQh5Pkunf6O4 Wkju4=; b=lIuTwtD68zk/mTFISozytUKE5YYGM1ja10meAVNy7Pjr8J1g94fLAz 9tYc4yXfbMneTMHjLO8p2z+ZTWnVA1W947OIeVBIgr1dA0+tZB1l0AeLdA9xzWXE Miu55z+yE/mRMSiyHiufUdubmv6di+LT+1GhURPJ41WPiwxsNTYqE= Received: (qmail 3091 invoked by alias); 18 Dec 2014 18:41:53 -0000 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 Received: (qmail 3058 invoked by uid 89); 18 Dec 2014 18:41:52 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.3 required=5.0 tests=AWL, BAYES_00, FREEMAIL_FROM, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 3 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.17.21) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-GCM-SHA384 encrypted) ESMTPS; Thu, 18 Dec 2014 18:41:45 +0000 Received: from localhost ([84.63.49.248]) by mail.gmx.com (mrgmx102) with ESMTPSA (Nemesis) id 0MVJze-1YQUnQ2QLG-00YehS; Thu, 18 Dec 2014 19:41:35 +0100 Date: Thu, 18 Dec 2014 19:41:31 +0100 From: Andre Vehreschild To: Dominique =?UTF-8?B?ZCdIdW1pw6hyZXM=?= Cc: Paul Richard Thomas , "fortran@gcc.gnu.org" , gcc-patches , Janus Weil , Mikael Morin , Antony Lewis Subject: Re: [RFC, PATCH, fortran] PR fortran/60255 Deferred character length Message-ID: <20141218194131.1c43e206@gmx.de> In-Reply-To: <995250F1-3C25-4459-8659-E6CF3CCB2740@lps.ens.fr> References: <20140817123221.31BBB105@mailhost.lps.ens.fr> <20141208183840.45364899@gmx.de> <49705BAA-594C-476D-BE1C-20E1AFEE7F98@lps.ens.fr> <995250F1-3C25-4459-8659-E6CF3CCB2740@lps.ens.fr> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; Hi all, here is my next try on proposing a patch for the issue in pr60255. It took me quite some time to understand the intricacies with handling variables associated in a select type. I think I got most of the issues fixed now: - Added generation of _len component for each unlimited polymorphic pointer. - Removed (my own) _len component creation routine. - Removed the double underscore in get_len_component(). - Associating an unlimited polymorphic entity to a deferred char array now lets the deferred char array use the actual string length from the '_len' component of the unlimited polymorphic entity for the charlen instead of the size component of the vptr. - Removed: Generating a special vtab name for deferred strings. A deferred string assigned to the unlimited polymorphic entity is now stored as having charlen zero again. - Basic support for char array arrays (No stuttering here) in u-poly variables. Bootstraps ok on x86_64-linux-gnu. Comparing regtests I get a difference in unlimited_polymorphic_2.f90 that I don't understand yet. May be that is only, because one error message disappeared. Attached is the full patch for trunk and a delta patch for those of you who already have my pr60255_3 added. I don't provide a changelog entry yet, because I think review will find some issues still to fix. So, comments welcome! Regards, Andre On Tue, 9 Dec 2014 14:16:05 +0100 Dominique d'Humières wrote: > Dear Andre, > > The patch causes an ICE for the test gfortran.dg/unlimited_polymorphic_1.f03: > > f951: internal compiler error: in gfc_add_component_ref, at > fortran/class.c:236 > > f951: internal compiler error: Abort trap: 6 > gfc: internal compiler error: Abort trap: 6 (program f951) > Abort > > Reduced test for which the ICE is triggered by ‘len(w)' > > MODULE m > > contains > subroutine bar (arg, res) > class(*) :: arg > character(100) :: res > select type (w => arg) > type is (character(*)) > write (res, '(I2)') len(w) > end select > end subroutine > > END MODULE > > Note that with your patch at > https://gcc.gnu.org/ml/fortran/2014-08/msg00022.html, I get the same ICE for > the Mikael’s test at https://gcc.gnu.org/ml/fortran/2014-08/msg00055.html > (before your patch for pr60255, it used to give a wrong length: 80 instead of > 20 AFAICR). > > Note that the assert at fortran/class.c:236 is also triggered for pr61115. > > Thanks for working on these issues, > > Dominique > > >> On 8 December 2014 at 18:38, Andre Vehreschild wrote: > >> Hi all, > >> > >> please find attached a more elaborate patch for pr60255. I totally agree > >> that my first attempt was just scratching the surface of the work needed. > >> > >> This patch also is *not* complete, but because I am really new to gfortran > >> patching, I don't want to present a final patch only to learn then, that I > >> have violated design rules, common practice or the like. Therefore please > >> comment and direct me to any sources/ideas to improve the patch. > >> > >> Topic: > >> The pr 60255 is about assigning a char array to an unlimited polymorphic > >> entity. In the comments the concern about the lost length information is > >> raised. The patch adds a _len component to the unlimited polymorphic entity > >> (after _data and _vtab) and adds an assignment of the string length to _len > >> when a string is pointer assigned to the unlimited poly entity. > >> Furthermore is the intrinsic len(unlimited poly pointing to a string) > >> resolved to give the _len component. > >> > >> Yet missing: > >> - assign _len component back to deferred char array length component > >> - transport length along chains of unlimited poly entities, i.e., a => b; > >> c => a where all objects are unlimited poly and b is a string. > >> - allocate() in this context > >> > >> Patch dependencies: > >> none > >> > >> Comments, concerns, candy welcome! > >> > >> Regards, > >> Andre > > diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 0286c9e..f5a815c 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -34,6 +34,12 @@ along with GCC; see the file COPYING3. If not see (pointer/allocatable/dimension/...). * _vptr: A pointer to the vtable entry (see below) of the dynamic type. + Only for unlimited polymorphic classes: + * _len: An integer(4) to store the string length when the unlimited + polymorphic pointer is used to point to a char array. The '_len' + component will be zero when no character array is stored in + '_data'. + For each derived type we set up a "vtable" entry, i.e. a structure with the following fields: * _hash: A hash value serving as a unique identifier for this type. @@ -544,10 +550,41 @@ gfc_intrinsic_hash_value (gfc_typespec *ts) } +/* Get the _len component from a class/derived object storing a string. */ + +gfc_expr * +gfc_get_len_component (gfc_expr *e) +{ + gfc_expr *len_comp; + gfc_ref *ref, **last; + len_comp = gfc_copy_expr (e->symtree->n.sym->assoc->target); + + /* We need to remove the last _data component ref from ptr. */ + last = &(len_comp->ref); + ref = len_comp->ref; + while (ref) + { + if (!ref->next + && ref->type == REF_COMPONENT + && strcmp("_data", ref->u.c.component->name)== 0) + { + gfc_free_ref_list(ref); + *last = NULL; + break; + } + last = &(ref->next); + ref = ref->next; + } + gfc_add_component_ref(len_comp, "_len"); + return len_comp; +} + /* Build a polymorphic CLASS entity, using the symbol that comes from build_sym. A CLASS entity is represented by an encapsulating type, which contains the declared type as '_data' component, plus a pointer - component '_vptr' which determines the dynamic type. */ + component '_vptr' which determines the dynamic type. When this CLASS + entity is unlimited polymorphic, then also add a component '_len' to + store the length of string when that is stored in it. */ bool gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, @@ -645,19 +682,36 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, if (!gfc_add_component (fclass, "_vptr", &c)) return false; c->ts.type = BT_DERIVED; + c->attr.access = ACCESS_PRIVATE; + c->attr.pointer = 1; if (ts->u.derived->attr.unlimited_polymorphic) { vtab = gfc_find_derived_vtab (ts->u.derived); gcc_assert (vtab); c->ts.u.derived = vtab->ts.u.derived; + + /* Add component '_len'. Only unlimited polymorphic pointers may + have a string assigned to them, i.e., only those need the _len + component. */ + if (!gfc_add_component (fclass, "_len", &c)) + return false; + c->ts.type = BT_INTEGER; + c->ts.kind = 4; + c->attr.access = ACCESS_PRIVATE; + c->attr.artificial = 1; + + /* Build minimal expression to initialize component with zero. + TODO: When doing this, one goes to hell in the select type + id association something in generating the constructor + code really goes wrong. Not using an initializer here + needs extra code in the alloc statements. */ +// c->initializer = gfc_get_int_expr (gfc_default_integer_kind, +// NULL, 0); } else /* Build vtab later. */ c->ts.u.derived = NULL; - - c->attr.access = ACCESS_PRIVATE; - c->attr.pointer = 1; } if (!ts->u.derived->attr.unlimited_polymorphic) @@ -2415,18 +2469,9 @@ find_intrinsic_vtab (gfc_typespec *ts) gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; int charlen = 0; - if (ts->type == BT_CHARACTER) - { - if (ts->deferred) - { - gfc_error ("TODO: Deferred character length variable at %C cannot " - "yet be associated with unlimited polymorphic entities"); - return NULL; - } - else if (ts->u.cl && ts->u.cl->length - && ts->u.cl->length->expr_type == EXPR_CONSTANT) - charlen = mpz_get_si (ts->u.cl->length->value.integer); - } + if (ts->type == BT_CHARACTER && !ts->deferred && ts->u.cl && ts->u.cl->length + && ts->u.cl->length->expr_type == EXPR_CONSTANT) + charlen = mpz_get_si (ts->u.cl->length->value.integer); /* Find the top-level namespace. */ for (ns = gfc_current_ns; ns; ns = ns->parent) @@ -2438,8 +2483,8 @@ find_intrinsic_vtab (gfc_typespec *ts) char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; if (ts->type == BT_CHARACTER) - sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type), - charlen, ts->kind); + sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type), + charlen, ts->kind); else sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 1058502..07de61b 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3190,8 +3190,10 @@ bool gfc_is_class_scalar_expr (gfc_expr *); bool gfc_is_class_container_ref (gfc_expr *e); gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *); unsigned int gfc_hash_value (gfc_symbol *); +gfc_expr *gfc_get_len_component (gfc_expr *); bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *, gfc_array_spec **); +void gfc_assign_charlen_to_unlimited_poly(gfc_code *c); gfc_symbol *gfc_find_derived_vtab (gfc_symbol *); gfc_symbol *gfc_find_vtab (gfc_typespec *); gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, bool*, diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 7ccabc7..ed6c057 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -3687,7 +3687,6 @@ gfc_simplify_leadz (gfc_expr *e) return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz); } - gfc_expr * gfc_simplify_len (gfc_expr *e, gfc_expr *kind) { @@ -3711,6 +3710,13 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind) mpz_set (result->value.integer, e->ts.u.cl->length->value.integer); return range_check (result, "LEN"); } + else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER + && e->symtree->n.sym + && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target + && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED) + { + return gfc_get_len_component (e); + } else return NULL; } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 713f969..cb2c656 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -550,15 +550,15 @@ static void gfc_finish_var_decl (tree decl, gfc_symbol * sym) { tree new_type; - /* TREE_ADDRESSABLE means the address of this variable is actually needed. - This is the equivalent of the TARGET variables. - We also need to set this if the variable is passed by reference in a - CALL statement. */ /* Set DECL_VALUE_EXPR for Cray Pointees. */ if (sym->attr.cray_pointee) gfc_finish_cray_pointee (decl, sym); + /* TREE_ADDRESSABLE means the address of this variable is actually needed. + This is the equivalent of the TARGET variables. + We also need to set this if the variable is passed by reference in a + CALL statement. */ if (sym->attr.target) TREE_ADDRESSABLE (decl) = 1; /* If it wasn't used we wouldn't be getting it. */ diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index f8e4df8..d52f3cc 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -94,6 +94,7 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) in future implementations. Use the corresponding APIs. */ #define CLASS_DATA_FIELD 0 #define CLASS_VPTR_FIELD 1 +#define CLASS_LEN_FIELD 2 #define VTABLE_HASH_FIELD 0 #define VTABLE_SIZE_FIELD 1 #define VTABLE_EXTENDS_FIELD 2 @@ -148,6 +149,20 @@ gfc_class_vptr_get (tree decl) } +tree +gfc_class_len_get (tree decl) +{ + tree len; + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, decl); + len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)), + CLASS_LEN_FIELD); + return fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (len), decl, len, + NULL_TREE); +} + + static tree gfc_vtable_field_get (tree decl, int field) { @@ -617,6 +632,40 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, } } + /* When the actual arg is a char array, then set the _len component of the + unlimited polymorphic entity, too. */ + if (e->ts.type == BT_CHARACTER) + { + ctree = gfc_class_len_get (var); + if (e->ts.u.cl->backend_decl) + { + gfc_add_modify (&parmse->pre, ctree, e->ts.u.cl->backend_decl); + } + else if (parmse->string_length) + { + gfc_add_modify (&parmse->pre, ctree, parmse->string_length); + } + else + { + /* Try to simplify the expression. */ + gfc_simplify_expr (e, 0); + if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved) + { + /* Amazingly all data is present to compute the length of a constant + string, but the expression is not yet there. */ + e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER, 1, &e->where); + mpz_set_ui (e->ts.u.cl->length->value.integer, e->value.character.length); + gfc_conv_const_charlen (e->ts.u.cl); + e->ts.u.cl->resolved = 1; + gfc_add_modify (&parmse->pre, ctree, e->ts.u.cl->backend_decl); + } + else + { + gfc_error ("Can't compute the length of the char array at %L.", + &e->where); + } + } + } /* Pass the address of the class object. */ parmse->expr = gfc_build_addr_expr (NULL_TREE, var); } @@ -1034,11 +1083,11 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op) gfc_add_vptr_component (lhs); if (UNLIMITED_POLY (expr1) - && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN) - { - rhs = gfc_get_null_expr (&expr2->where); - goto assign_vptr; - } + && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN) + { + rhs = gfc_get_null_expr (&expr2->where); + goto assign_vptr; + } if (expr2->expr_type == EXPR_NULL) vtab = gfc_find_vtab (&expr1->ts); @@ -6415,6 +6464,14 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) fold_convert (TREE_TYPE (cm->backend_decl), val)); } + else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0) + { + gfc_expr *e = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); + val = gfc_conv_constant_to_tree (e); + CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, + fold_convert (TREE_TYPE (cm->backend_decl), + val)); + } else { val = gfc_conv_initializer (c->expr, &cm->ts, @@ -6491,7 +6548,9 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr) null_pointer_node. C_PTR and C_FUNPTR are converted to match the typespec for the C_PTR and C_FUNPTR symbols, which has already been updated to be an integer with a kind equal to the size of a (void *). */ - if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID) + if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID + /* TODO: Need to check, if this is correctly working for all cases. */ + && expr->ts.u.derived->attr.is_bind_c) { if (expr->expr_type == EXPR_VARIABLE && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR @@ -6695,6 +6754,43 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) } +/* Create the character length assignment to the _len component. */ + +void +add_assignment_of_string_len_to_len_component (stmtblock_t *block, + gfc_expr *ptr, gfc_se *ptr_se, + gfc_se *str) +{ + gfc_expr *len_comp; + gfc_ref *ref, **last; + gfc_se lse; + len_comp = gfc_copy_expr(ptr); + /* We need to remove the last _data component ref from ptr. */ + last = &(len_comp->ref); + ref = len_comp->ref; + while (ref) + { + if (!ref->next + && ref->type == REF_COMPONENT + && strcmp("_data", ref->u.c.component->name)== 0) + { + gfc_free_ref_list(ref); + *last = NULL; + break; + } + last = &(ref->next); + ref = ref->next; + } + gfc_add_component_ref(len_comp, "_len"); + gfc_init_se (&lse, NULL); + gfc_conv_expr (&lse, len_comp); + + /* ptr % _len = len (str) */ + gfc_add_modify (block, lse.expr, str->string_length); + ptr_se->string_length = lse.expr; + gfc_free_expr (len_comp); +} + tree gfc_trans_pointer_assign (gfc_code * code) { @@ -6759,6 +6855,18 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_add_block_to_block (&block, &lse.pre); gfc_add_block_to_block (&block, &rse.pre); + /* For string assignments to unlimited polymorphic pointers add an + assignment of the string_length to the _len component of the pointer. */ + if ((expr1->ts.type == BT_CLASS || expr1->ts.type == BT_DERIVED) + && expr1->ts.u.derived->attr.unlimited_polymorphic + && (expr2->ts.type == BT_CHARACTER || + ((expr2->ts.type == BT_DERIVED || expr2->ts.type == BT_CLASS) + && expr2->ts.u.derived->attr.unlimited_polymorphic)) + ) + { + add_assignment_of_string_len_to_len_component (&block, expr1, &lse, &rse); + } + /* Check character lengths if character expression. The test is only really added if -fbounds-check is enabled. Exclude deferred character length lefthand sides. */ diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index d17b075..7c8974e 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1143,6 +1143,21 @@ gfc_trans_critical (gfc_code *code) } +/* Return true, when the class has a _len component. */ + +static bool +class_has_len_component (gfc_symbol *sym) +{ + gfc_component *comp = sym->ts.u.derived->components; + while (comp) + { + if (strcmp (comp->name, "_len") == 0) + return true; + comp = comp->next; + } + return false; +} + /* Do proper initialization for ASSOCIATE names. */ static void @@ -1156,6 +1171,8 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) tree offset; tree dim; int n; + tree charlen; + bool need_len_assign; gcc_assert (sym->assoc); e = sym->assoc->target; @@ -1166,6 +1183,22 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) unlimited = UNLIMITED_POLY (e); + /* Assignments to the string length need to be generated, when + ( sym is a char array or + sym has a _len component + ) and the associated expression is unlimited polymorphic, which is + not (yet) correctly in 'unlimited', because for an already associated + BT_DERIVED the u-poly flag is not set, i.e., + __tmp_CHARACTER_0_1 => w => arg + ^ generated temp ^ from code, the w does not have the u-poly + flag set, where UNLIMITED_POLY(e) expects it. */ + need_len_assign = ((unlimited || (e->ts.type == BT_DERIVED + && e->ts.u.derived->attr.unlimited_polymorphic)) + && (sym->ts.type == BT_CHARACTER + || ((sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED) + && class_has_len_component (sym)) + ) + ); /* Do a `pointer assignment' with updated descriptor (or assign descriptor to array temporary) for arrays with either unknown shape or if associating to a variable. */ @@ -1217,7 +1250,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp)); gfc_add_modify (&se.pre, GFC_DECL_SPAN(desc), tmp); } - /* Done, register stuff as init / cleanup code. */ gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), gfc_finish_block (&se.post)); @@ -1247,7 +1279,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_add_modify (&se.pre, tmp, gfc_get_dtype (TREE_TYPE (sym->backend_decl))); } - gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), gfc_finish_block (&se.post)); } @@ -1286,6 +1317,22 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_array_index_type, offset, tmp); } + if (need_len_assign) + { + /* Get the _len comp from the target expr. */ + tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym)); + /* Get the component-ref for the temp structure's _len comp. */ + charlen = gfc_class_len_get (se.expr); + /* Add the assign to the beginning of the the block... */ + gfc_add_modify (&se.pre, charlen, + fold_convert (TREE_TYPE (charlen), tmp)); + /* and the oposite way at the end of the block, to hand changes + on the string length back. */ + gfc_add_modify (&se.post, tmp, + fold_convert (TREE_TYPE (tmp), charlen)); + /* Length assignment done, prevent adding it again below. */ + need_len_assign = false; + } gfc_conv_descriptor_offset_set (&se.pre, desc, offset); } else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS @@ -1300,7 +1347,13 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) se.expr = build_fold_indirect_ref_loc (input_location, se.expr); } else - gfc_conv_expr (&se, e); + { + /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign, + which has the string length included. For CHARACTERS it is still + needed and will be done at the end of this routine. */ + gfc_conv_expr (&se, e); + need_len_assign = sym->ts.type == BT_CHARACTER; + } tmp = TREE_TYPE (sym->backend_decl); tmp = gfc_build_addr_expr (tmp, se.expr); @@ -1321,19 +1374,17 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_add_init_cleanup (block, tmp, NULL_TREE); } - /* Set the stringlength from the vtable size. */ - if (sym->ts.type == BT_CHARACTER && sym->attr.select_type_temporary) + /* Set the stringlength, when needed. */ + if (need_len_assign) { - tree charlen; gfc_se se; gfc_init_se (&se, NULL); - gcc_assert (UNLIMITED_POLY (e->symtree->n.sym)); - tmp = gfc_get_symbol_decl (e->symtree->n.sym); - tmp = gfc_vtable_size_get (tmp); + tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym)); gfc_get_symbol_decl (sym); - charlen = sym->ts.u.cl->backend_decl; + charlen = sym->ts.type == BT_CHARACTER ? sym->ts.u.cl->backend_decl + : gfc_class_len_get (sym->backend_decl); gfc_add_modify (&se.pre, charlen, - fold_convert (TREE_TYPE (charlen), tmp)); + fold_convert (TREE_TYPE (charlen), tmp)); gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), gfc_finish_block (&se.post)); } @@ -5048,12 +5099,21 @@ gfc_trans_allocate (gfc_code * code) gfc_add_modify (&se.pre, se.string_length, fold_convert (TREE_TYPE (se.string_length), memsz)); + else if ((al->expr->ts.type == BT_DERIVED + || al->expr->ts.type == BT_CLASS) + && expr->ts.u.derived->attr.unlimited_polymorphic) + { + tmp = gfc_class_len_get (al->expr->symtree->n.sym->backend_decl); + gfc_add_modify (&se.pre, tmp, + fold_convert (TREE_TYPE (tmp), + memsz)); + } /* Convert to size in bytes, using the character KIND. */ if (unlimited_char) tmp = TREE_TYPE (gfc_typenode_for_spec (&code->expr3->ts)); else - tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts)); + tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts)); tmp = TYPE_SIZE_UNIT (tmp); memsz = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), tmp, diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 51ad910..3926c2a 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -348,6 +348,7 @@ gfc_wrapped_block; /* Class API functions. */ tree gfc_class_data_get (tree); tree gfc_class_vptr_get (tree); +tree gfc_class_len_get (tree); void gfc_reset_vptr (stmtblock_t *, gfc_expr *); tree gfc_class_set_static_fields (tree, tree, tree); tree gfc_vtable_hash_get (tree); diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_18.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_18.f90 index 7a0df1a..9044199 100644 --- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_18.f90 +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_18.f90 @@ -1,6 +1,6 @@ ! { dg-do compile } -! Testing fix for -! PR fortran/60414 +! Testing fix for +! PR fortran/60414 ! module m implicit none @@ -23,7 +23,7 @@ contains if ( abs (X - this%expectedScalar) > 0.0001 ) then call abort() end if - class default + class default call abort () end select end subroutine FCheck @@ -62,8 +62,8 @@ end module program test use :: m implicit none - + real :: vec(1:6) = (/ 0, 1, 2, 3, 4, 5 /) call checktextvector(vec, 6, 5.0) -end program test +end program test diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f03 new file mode 100644 index 0000000..6042882 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f03 @@ -0,0 +1,57 @@ +! { dg-do run } +! Testing fix for +! PR fortran/60255 +! +program test + implicit none + character(LEN=:), allocatable :: S + call subP(S) + call sub2() + call sub1("test") + +contains + + subroutine sub1(dcl) + character(len=*), target :: dcl + class(*), pointer :: ucp +! character(len=:), allocatable ::def + + ucp => dcl + + select type (ucp) + type is (character(len=*)) + if (len(ucp) .NE. 4) then + call abort() +! else +! def = ucp +! if (len(def) .NE. 4) then +! call abort() ! This abort is expected currently +! end if + end if + class default + call abort() + end select + end subroutine + + subroutine sub2 + character(len=:), allocatable, target :: dcl + class(*), pointer :: ucp + + dcl = "ttt" + ucp => dcl + + select type (ucp) + type is (character(len=*)) + if (len(ucp) .NE. 3) then + call abort() + end if + class default + call abort() + end select + end subroutine + + subroutine subP(P) + class(*) :: P + end subroutine + +end program diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 index 8e80386..30e4797 100644 --- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 @@ -5,7 +5,7 @@ ! Contributed by Paul Thomas ! and Tobias Burnus ! - CHARACTER(:), allocatable, target :: chr ! { dg-error "TODO: Deferred character length variable" } + CHARACTER(:), allocatable, target :: chr ! F2008: C5100 integer :: i(2) logical :: flag