From patchwork Wed Feb 19 15:51:32 2014 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Janus Weil X-Patchwork-Id: 321965 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 458392C00C0 for ; Thu, 20 Feb 2014 02:51:45 +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 :mime-version:in-reply-to:references:date:message-id:subject :from:to:cc:content-type; q=dns; s=default; b=ZJ6iqIIZMF8H50rnNO hpNubwLtETWyNO6UiC4cp0uqdYfdnJsN2tRhmBYt0gcwwZXGcZsEDVsD+gNN9Gf7 gujpu2MrlYsgJ8U/xUfbBSAQg/xtwWLcYzXVERcKuF21ALZ79PEIRJ3LYiXmNsfX ltdjP0oCWSq9pU+Ol5hiCDEN0= 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 :mime-version:in-reply-to:references:date:message-id:subject :from:to:cc:content-type; s=default; bh=WwlbaFFYWQLffT1PxxNgaw5y juc=; b=KbiFYDGGLibqMKEWgtWmQVY8aN1YBJXgS7e1JQLTo0qYzU6xFu0lvPW6 WkXYIdPDs2D/4tByiP4S/Jt8GM3XpIselK5UpgJuS+jX+9mlStQAzSi0qfaH8Z8Q HHrrxSnuNPAybx2Z9pFib/r/iE2l8mentlT0jHmbJSNmTu+LIL8= Received: (qmail 32229 invoked by alias); 19 Feb 2014 15:51:37 -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 32208 invoked by uid 89); 19 Feb 2014 15:51:37 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-2.1 required=5.0 tests=AWL, BAYES_00, FREEMAIL_ENVFROM_END_DIGIT, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mail-qa0-f48.google.com Received: from mail-qa0-f48.google.com (HELO mail-qa0-f48.google.com) (209.85.216.48) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES128-SHA encrypted) ESMTPS; Wed, 19 Feb 2014 15:51:35 +0000 Received: by mail-qa0-f48.google.com with SMTP id f11so700964qae.7 for ; Wed, 19 Feb 2014 07:51:33 -0800 (PST) MIME-Version: 1.0 X-Received: by 10.140.89.71 with SMTP id u65mr1745665qgd.93.1392825092937; Wed, 19 Feb 2014 07:51:32 -0800 (PST) Received: by 10.96.156.38 with HTTP; Wed, 19 Feb 2014 07:51:32 -0800 (PST) In-Reply-To: References: <5148D5DF.9000508@net-b.de> Date: Wed, 19 Feb 2014 16:51:32 +0100 Message-ID: Subject: Re: [Patch, fortran] PR51976 - [F2003] Support deferred-length character components of derived types (allocatable string length) From: Janus Weil To: Tobias Burnus Cc: Paul Richard Thomas , "fortran@gcc.gnu.org" , gcc-patches The patch was not applying cleanly any more, so here is a re-diffed version for current trunk. It works nicely on the included test case as well as the one provided by Walter Spector in comment 12 of the PR. Since, also in the current state, "character(:)" works only in a subset of all cases, I think it cannot hurt to add more cases that work for 4.9 (even if still not all possible cases work). Please let me know what you think ... Cheers, Janus 2014-02-19 16:16 GMT+01:00 Janus Weil : > Hi all, > > the patch below has been posted a long time ago, but was never > actually committed (although it seems close to being finished). > > Could it still be considered for trunk? I think it is a rather popular > feature, which would be helpful for many users ... > > Cheers, > Janus > > > > 2013-03-19 22:17 GMT+01:00 Tobias Burnus : >> 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. Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (revision 207896) +++ gcc/fortran/gfortran.h (working copy) @@ -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; } Index: gcc/fortran/primary.c =================================================================== --- gcc/fortran/primary.c (revision 207896) +++ gcc/fortran/primary.c (working copy) @@ -2355,7 +2355,7 @@ build_actual_constructor (gfc_structure_ctor_compo } /* 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) @@ -2365,7 +2365,7 @@ build_actual_constructor (gfc_structure_ctor_compo return false; 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); @@ -2447,7 +2447,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, { /* 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" Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (revision 207896) +++ gcc/fortran/resolve.c (working copy) @@ -12105,14 +12105,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 false; - } - /* F2008, C442. */ if ((!sym->attr.is_class || c != sym->components) && c->attr.codimension @@ -12364,6 +12356,25 @@ resolve_fl_derived0 (gfc_symbol *sym) return false; } + /* 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)) + return false; + 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) Index: gcc/fortran/trans-array.c =================================================================== --- gcc/fortran/trans-array.c (revision 207896) +++ gcc/fortran/trans-array.c (working copy) @@ -7365,7 +7365,7 @@ get_full_array_size (stmtblock_t *block, tree decl static tree duplicate_allocatable (tree dest, tree src, tree type, int rank, - bool no_malloc) + bool no_malloc, tree strlen) { tree tmp; tree size; @@ -7386,7 +7386,11 @@ duplicate_allocatable (tree dest, tree src, tree t 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); @@ -7410,8 +7414,11 @@ duplicate_allocatable (tree dest, tree src, tree t else nelems = gfc_index_one_node; - 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) @@ -7452,7 +7459,7 @@ duplicate_allocatable (tree dest, tree src, tree t 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); } @@ -7461,7 +7468,7 @@ gfc_duplicate_allocatable (tree dest, tree src, tr 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); } @@ -7718,6 +7725,16 @@ structure_alloc_comps (gfc_symbol * der_type, tree 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) { @@ -7855,9 +7872,26 @@ structure_alloc_comps (gfc_symbol * der_type, tree 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; if (c->attr.codimension) tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank); @@ -8342,10 +8376,24 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo /* 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) { Index: gcc/fortran/trans-expr.c =================================================================== --- gcc/fortran/trans-expr.c (revision 207896) +++ gcc/fortran/trans-expr.c (working copy) @@ -1689,6 +1689,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) @@ -6043,9 +6051,40 @@ gfc_trans_subcomponent_assign (tree dest, gfc_comp gfc_add_expr_to_block (&block, tmp); } } - else + else if (gfc_deferred_strlen (cm, &tmp)) { - /* Scalar component. */ + 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 (excluding deferred parameters). */ gfc_init_se (&se, NULL); gfc_init_se (&lse, NULL); @@ -7747,7 +7786,10 @@ alloc_scalar_allocatable_for_assignment (stmtblock /* 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); } } Index: gcc/fortran/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (revision 207896) +++ gcc/fortran/trans-stmt.c (working copy) @@ -5028,6 +5028,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) Index: gcc/fortran/trans-types.c =================================================================== --- gcc/fortran/trans-types.c (revision 207896) +++ gcc/fortran/trans-types.c (working copy) @@ -2486,12 +2486,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); } Index: gcc/fortran/trans.c =================================================================== --- gcc/fortran/trans.c (revision 207896) +++ gcc/fortran/trans.c (working copy) @@ -2044,3 +2044,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; +} Index: gcc/fortran/trans.h =================================================================== --- gcc/fortran/trans.h (revision 207896) +++ gcc/fortran/trans.h (working copy) @@ -581,6 +581,9 @@ bool get_array_ctor_strlen (stmtblock_t *, gfc_con 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*, ...); Index: gcc/testsuite/gfortran.dg/deferred_type_component_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/deferred_type_component_1.f90 (revision 0) +++ gcc/testsuite/gfortran.dg/deferred_type_component_1.f90 (working copy) @@ -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