From patchwork Tue Mar 19 21:17:19 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 229222 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 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (Client CN "localhost", Issuer "www.qmailtoaster.com" (not verified)) by ozlabs.org (Postfix) with ESMTPS id 58E222C007B for ; Wed, 20 Mar 2013 08:17:46 +1100 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:cc:subject:references :in-reply-to:content-type; q=dns; s=default; b=Vr4a+IL9NywIKcmwQ ktQQT1mYmHTrYg40IWKqlvADjrcnbc+GA6cVmHYjZfogBKF1ZNHuxJzjo0NS/1fd lRZcKpk9y0/f2oAeZwWvm1ev6hd6LiVH+q2PjNlRMrmuhy8ZkVRfNeuGlTzsBb// Ge93ox56frEZj93hwh7RiTF8pE= 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 :message-id:date:from:mime-version:to:cc:subject:references :in-reply-to:content-type; s=default; bh=Mwa+cCtW5QQ/phzhAqjsCgt LrxY=; b=K0F++mHDimh9tiYh6cJ9wA7n33JzfKOHs08bJq5xql6ZjCZ/FQEtB1y U921pR+HtpECZskqk1+2GFB+CTPc4gCGn6BYalTav9zgRks4GXISrn1VE1WLSJ8a jrIge771Tfi73lrcVznQuMK2rAuePyOvAiH1h+GxBd0Z1XCknR08= Received: (qmail 14271 invoked by alias); 19 Mar 2013 21:17:40 -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 14233 invoked by uid 89); 19 Mar 2013 21:17:28 -0000 X-Spam-Sware-Status: No, score=-2.2 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE autolearn=ham version=3.3.1 X-Spam-User: qpsmtpd, 2 recipients Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.84/v0.84-167-ge50287c) with ESMTP; Tue, 19 Mar 2013 21:17:22 +0000 Received: from archimedes.net-b.de (port-92-195-211-180.dynamic.qsc.de [92.195.211.180]) by mx01.qsc.de (Postfix) with ESMTP id E6BE53CC1C; Tue, 19 Mar 2013 22:17:19 +0100 (CET) Message-ID: <5148D5DF.9000508@net-b.de> Date: Tue, 19 Mar 2013 22:17:19 +0100 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:17.0) Gecko/20130215 Thunderbird/17.0.3 MIME-Version: 1.0 To: Paul Richard Thomas CC: "fortran@gcc.gnu.org" , gcc-patches Subject: Re: [Patch, fortran] PR51976 - [F2003] Support deferred-length character components of derived types (allocatable string length) References: In-Reply-To: Dear Paul, dear all, On February 24, 2013 Paul Richard Thomas wrote: > The attached patch represents progress to date. It fixes the original > problem in this PR and allows John Reid's version of > iso_varying_string/vocabulary_word_count.f90 to compile and run > correctly. It even bootstraps and regtests! Attached is a re-diffed patch; I have additionally fixed some indenting issues. Additionally, I have tested the patch - and it fails with deferred-length *array* character components. See attached test case. Also, the following line of the included test case leaks memory: allocate (array(2), source = [t("abcedefg","hi"), t("jkl","mnop")]) I think at least the array bug should be fixed prior committal. (Fixing the memory leak and some of the below-mentioned issues would be nice, too.) Otherwise, I think the patch looks fine. For completeness, I have some naming remarks, which I would also like to considered: http://thread.gmane.org/gmane.comp.gcc.fortran/40393/focus=281580 Tobias > However, it doe not fix: > PR51976 comment #6 and PR51550 - allocate with typespec ICEs > PR51976 comment #6 FORALL assignment is messed up and ICEs.. > PR47545 the compiler complains about the lack of an initializer for > the hidden character length field. > PR45170 will need going through from one end to the other - there is a > lot of "stuff" here! > > Of these, I consider the fix of the PR47545 problem to be a must and > the allocate with typespec desirable. 2013-03-19 Paul Thomas gcc.gnu.org> PR fortran/51976 * gfortran.h : Add deferred_parameter attribute. * primary.c (build_actual_constructor): It is not an error if a missing component has the deferred_parameter attribute; equally, if one is given a value, it is an error. * resolve.c (resolve_fl_derived0): Remove error for deferred character length components. Add the hidden string length field to the structure. Give it the deferred_parameter attribute. * trans-array.c (duplicate_allocatable): Add a strlen field which is used as the element size if it is non-null. (gfc_duplicate_allocatable, gfc_copy_allocatable_data): Pass a NULL to the new argument in duplicate_allocatable. (structure_alloc_comps): Set the hidden string length as appropriate. Use it in calls to duplicate_allocatable. (gfc_alloc_allocatable_for_assignment): When a deferred length backend declaration is variable, use that; otherwise use the string length from the expression evaluation. * trans-expr.c (gfc_conv_component_ref): If this is a deferred character length component, the string length should have the value of the hidden string length field. (gfc_trans_subcomponent_assign): Set the hidden string length field for deferred character length components. Allocate the necessary memory for the string. (alloc_scalar_allocatable_for_assignment): Same change as in gfc_alloc_allocatable_for_assignment above. * trans-stmt.c (gfc_trans_allocate): Likewise. * trans-types.c (gfc_get_derived_type): Set the tree type for a deferred character length component. * trans.c (gfc_deferred_strlen): New function. * trans.h : Prototype for the new function. 2013-03-19 Paul Thomas gcc.gnu.org> PR fortran/51976 * gfortran.dg/deferred_type_component_1.f90 : New test. diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 76d2797..6956d33 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -811,6 +811,9 @@ typedef struct /* Attributes set by compiler extensions (!GCC$ ATTRIBUTES). */ unsigned ext_attr:EXT_ATTR_NUM; + /* Is a parameter associated with a deferred type component. */ + unsigned deferred_parameter:1; + /* The namespace where the attribute has been set. */ struct gfc_namespace *volatile_ns, *asynchronous_ns; } diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index d149224..34a55b5 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2349,7 +2349,7 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head, } /* If it was not found, try the default initializer if there's any; - otherwise, it's an error. */ + otherwise, it's an error unless this is a deferred parameter. */ if (!comp_iter) { if (comp->initializer) @@ -2360,7 +2360,7 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head, return FAILURE; value = gfc_copy_expr (comp->initializer); } - else + else if (!comp->attr.deferred_parameter) { gfc_error ("No initializer for component '%s' given in the" " structure constructor at %C!", comp->name); @@ -2443,7 +2443,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c { /* Components without name are not allowed after the first named component initializer! */ - if (!comp) + if (!comp || comp->attr.deferred_parameter) { if (last_name) gfc_error ("Component initializer without name after component" diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index e9b6fb9..f70a749 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -12539,14 +12539,6 @@ resolve_fl_derived0 (gfc_symbol *sym) if (c->attr.artificial) continue; - /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */ - if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function) - { - gfc_error ("Deferred-length character component '%s' at %L is not " - "yet supported", c->name, &c->loc); - return FAILURE; - } - /* F2008, C442. */ if ((!sym->attr.is_class || c != sym->components) && c->attr.codimension @@ -12798,6 +12790,25 @@ resolve_fl_derived0 (gfc_symbol *sym) return FAILURE; } + /* Add the hidden deferred length field. */ + if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function + && !sym->attr.is_class) + { + char name[GFC_MAX_SYMBOL_LEN+1]; + gfc_component *strlen; + sprintf (name, "_%s", c->name); + strlen = gfc_find_component (sym, name, true, true); + if (strlen == NULL) + { + if (gfc_add_component (sym, name, &strlen) == FAILURE) + return FAILURE; + strlen->ts.type = BT_INTEGER; + strlen->ts.kind = gfc_charlen_int_kind; + strlen->attr.access = ACCESS_PRIVATE; + strlen->attr.deferred_parameter = 1; + } + } + if (c->ts.type == BT_DERIVED && sym->component_access != ACCESS_PRIVATE && gfc_check_symbol_access (sym) diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 75fed2f..7a2d5de 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -7308,7 +7308,7 @@ get_full_array_size (stmtblock_t *block, tree decl, int rank) static tree duplicate_allocatable (tree dest, tree src, tree type, int rank, - bool no_malloc) + bool no_malloc, tree strlen) { tree tmp; tree size; @@ -7329,7 +7329,11 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, null_data = gfc_finish_block (&block); gfc_init_block (&block); - size = TYPE_SIZE_UNIT (TREE_TYPE (type)); + if (strlen != NULL_TREE) + size = strlen; + else + size = TYPE_SIZE_UNIT (TREE_TYPE (type)); + if (!no_malloc) { tmp = gfc_call_malloc (&block, type, size); @@ -7349,8 +7353,11 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, gfc_init_block (&block); nelems = get_full_array_size (&block, src, rank); - tmp = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); + if (strlen != NULL_TREE) + tmp = fold_convert (gfc_array_index_type, strlen); + else + tmp = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, nelems, tmp); if (!no_malloc) @@ -7391,7 +7398,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank) { - return duplicate_allocatable (dest, src, type, rank, false); + return duplicate_allocatable (dest, src, type, rank, false, NULL_TREE); } @@ -7400,7 +7407,7 @@ gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank) tree gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank) { - return duplicate_allocatable (dest, src, type, rank, true); + return duplicate_allocatable (dest, src, type, rank, true, NULL_TREE); } @@ -7637,6 +7644,16 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, void_type_node, comp, build_int_cst (TREE_TYPE (comp), 0)); gfc_add_expr_to_block (&fnblock, tmp); + if (gfc_deferred_strlen (c, &comp)) + { + comp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (comp), + decl, comp, NULL_TREE); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (comp), comp, + build_int_cst (TREE_TYPE (comp), 0)); + gfc_add_expr_to_block (&fnblock, tmp); + } } else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) { @@ -7730,8 +7747,25 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, continue; } - if (c->attr.allocatable && !c->attr.proc_pointer - && !cmp_has_alloc_comps) + if (gfc_deferred_strlen (c, &tmp)) + { + tree len; + len = tmp; + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (len), + decl, len, NULL_TREE); + len = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (len), + dest, len, NULL_TREE); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (len), len, tmp); + gfc_add_expr_to_block (&fnblock, tmp); + tmp = duplicate_allocatable (dcmp, comp, ctype, rank, + false, len); + gfc_add_expr_to_block (&fnblock, tmp); + } + else if (c->attr.allocatable && !c->attr.proc_pointer + && !cmp_has_alloc_comps) { rank = c->as ? c->as->rank : 0; tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank); @@ -8183,10 +8217,24 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, /* Get the new lhs size in bytes. */ if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) { - tmp = expr2->ts.u.cl->backend_decl; - gcc_assert (expr1->ts.u.cl->backend_decl); - tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp); - gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp); + if (expr2->ts.deferred) + { + if (TREE_CODE (expr2->ts.u.cl->backend_decl) == VAR_DECL) + tmp = expr2->ts.u.cl->backend_decl; + else + tmp = rss->info->string_length; + } + else + { + tmp = expr2->ts.u.cl->backend_decl; + tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp); + } + + if (expr1->ts.u.cl->backend_decl + && TREE_CODE (expr1->ts.u.cl->backend_decl) == VAR_DECL) + gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp); + else + gfc_add_modify (&fblock, lss->info->string_length, tmp); } else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl) { diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 2c3ff1f..c73741d 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1589,6 +1589,14 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) se->string_length = tmp; } + if (gfc_deferred_strlen (c, &field)) + { + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), + decl, field, NULL_TREE); + se->string_length = tmp; + } + if (((c->attr.pointer || c->attr.allocatable) && (!c->attr.dimension && !c->attr.codimension) && c->ts.type != BT_CHARACTER) @@ -6031,9 +6039,40 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_add_expr_to_block (&block, tmp); } } - else + else if (gfc_deferred_strlen (cm, &tmp)) + { + tree strlen; + strlen = tmp; + gcc_assert (strlen); + strlen = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (strlen), + TREE_OPERAND (dest, 0), + strlen, NULL_TREE); + + if (expr->expr_type == EXPR_NULL) + { + tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0); + gfc_add_modify (&block, dest, tmp); + tmp = build_int_cst (TREE_TYPE (strlen), 0); + gfc_add_modify (&block, strlen, tmp); + } + else + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, expr); + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MALLOC), + 1, se.string_length); + gfc_add_modify (&block, dest, + fold_convert (TREE_TYPE (dest), tmp)); + gfc_add_modify (&block, strlen, se.string_length); + tmp = gfc_build_memcpy_call (dest, se.expr, se.string_length); + gfc_add_expr_to_block (&block, tmp); + } + } + else if (!cm->attr.deferred_parameter) { - /* Scalar component. */ + /* Scalar component (excluding deferred parameters). */ gfc_init_se (&se, NULL); gfc_init_se (&lse, NULL); @@ -7629,7 +7668,10 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, /* Update the lhs character length. */ size = string_length; - gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size); + if (TREE_CODE (expr1->ts.u.cl->backend_decl) == VAR_DECL) + gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size); + else + gfc_add_modify (block, lse.string_length, size); } } diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 430b10e..aad0139 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5009,6 +5009,11 @@ gfc_trans_allocate (gfc_code * code) if (tmp && TREE_CODE (tmp) == VAR_DECL) gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp), memsz)); + else if (al->expr->ts.type == BT_CHARACTER + && al->expr->ts.deferred && se.string_length) + gfc_add_modify (&se.pre, se.string_length, + fold_convert (TREE_TYPE (se.string_length), + memsz)); /* Convert to size in bytes, using the character KIND. */ if (unlimited_char) diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index cdac0da..cda26ab 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2479,12 +2479,15 @@ gfc_get_derived_type (gfc_symbol * derived) field_type = c->ts.u.derived->backend_decl; else { - if (c->ts.type == BT_CHARACTER) + if (c->ts.type == BT_CHARACTER && !c->ts.deferred) { /* Evaluate the string length. */ gfc_conv_const_charlen (c->ts.u.cl); gcc_assert (c->ts.u.cl->backend_decl); } + else if (c->ts.type == BT_CHARACTER) + c->ts.u.cl->backend_decl + = build_int_cst (gfc_charlen_type_node, 0); field_type = gfc_typenode_for_spec (&c->ts); } diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index d7bdf26..986213a 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1843,3 +1843,21 @@ gfc_likely (tree cond) cond = fold_convert (boolean_type_node, cond); return cond; } + + +/* Get the string length for a deferred character length component. */ + +bool +gfc_deferred_strlen (gfc_component *c, tree *decl) +{ + char name[GFC_MAX_SYMBOL_LEN+1]; + gfc_component *strlen; + if (!(c->ts.type == BT_CHARACTER && c->ts.deferred)) + return false; + sprintf (name, "_%s", c->name); + for (strlen = c; strlen; strlen = strlen->next) + if (strcmp (strlen->name, name) == 0) + break; + *decl = strlen ? strlen->backend_decl : NULL_TREE; + return strlen != NULL; +} diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 03adfdd..95c1864 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -578,6 +578,9 @@ bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor_base, tree *); tree gfc_likely (tree); tree gfc_unlikely (tree); +/* Return the string length of a deferred character length component. */ +bool gfc_deferred_strlen (gfc_component *, tree *); + /* Generate a runtime error call. */ tree gfc_trans_runtime_error (bool, locus*, const char*, ...); diff --git a/gcc/testsuite/gfortran.dg/deferred_type_component_1.f90 b/gcc/testsuite/gfortran.dg/deferred_type_component_1.f90 new file mode 100644 index 0000000..17d1ac0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_type_component_1.f90 @@ -0,0 +1,54 @@ +! { dg-do run } +! Test fix for PR51976 - introduce deferred character length components +! +! Contributed by Tobias Burnus +! + type t + character(len=:), allocatable :: str_comp + character(len=:), allocatable :: str_comp1 + end type t + type(t) :: x + type(t), allocatable, dimension(:) :: array + +! Check scalars + allocate (x%str_comp, source = "abc") + call check (x%str_comp, "abc") + deallocate (x%str_comp) + allocate (x%str_comp, source = "abcdefghijklmnop") + call check (x%str_comp, "abcdefghijklmnop") + x%str_comp = "xyz" + call check (x%str_comp, "xyz") + x%str_comp = "abcdefghijklmnop" + x%str_comp1 = "lmnopqrst" + call foo (x%str_comp1, "lmnopqrst") + call bar (x, "abcdefghijklmnop", "lmnopqrst") + +! Check arrays and structure constructors + allocate (array(2), source = [t("abcedefg","hi"), t("jkl","mnop")]) + call check (array(1)%str_comp, "abcedefg") + call check (array(1)%str_comp1, "hi") + call check (array(2)%str_comp, "jkl") + call check (array(2)%str_comp1, "mnop") + deallocate (array) + allocate (array(3), source = [x, x, x]) + array(2)%str_comp = "blooey" + call bar (array(1), "abcdefghijklmnop", "lmnopqrst") + call bar (array(2), "blooey", "lmnopqrst") + call bar (array(3), "abcdefghijklmnop", "lmnopqrst") +contains + subroutine foo (chr1, chr2) + character (*) :: chr1, chr2 + call check (chr1, chr2) + end subroutine + subroutine bar (a, chr1, chr2) + character (*) :: chr1, chr2 + type(t) :: a + call check (a%str_comp, chr1) + call check (a%str_comp1, chr2) + end subroutine + subroutine check (chr1, chr2) + character (*) :: chr1, chr2 + if (len(chr1) .ne. len (chr2)) call abort + if (chr1 .ne. chr2) call abort + end subroutine +end