| Message ID | CAKwh3qhiANiAz6ahj9YjHK=quZLyy2rFXkGui=uk-8cNLt2TWA@mail.gmail.com |
|---|---|
| State | New |
| Headers | show |
Dear Janus, I had completely forgotten about this patch... I even thought that it had been applied :-) I'll have time, either tomorrow evening or Saturday to take a look. After nearly 11 months, a couple more days will not hurt! Thanks for bringing it to my attention. Paul On 19 February 2014 16:51, Janus Weil <janus@gcc.gnu.org> wrote: > 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 <janus@gcc.gnu.org>: >> 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 <burnus@net-b.de>: >>> 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.
Hi Paul, Paul Richard Thomas wrote: > I had completely forgotten about this patch... I even thought that it > had been applied :-) I'll have time, either tomorrow evening or Saturday to take a look. > After nearly 11 months, a couple more days will not hurt! I think it went as follows: We found out that some code doesn't - in particular code which uses array-valued deferred-length characters. After trying to fix it, you (Paul) decided that the simplest way to fix it would be the new array descriptor - and then it got stuck. Regarding this patch, I have mixed feelings. I think it is a much wished feature - but I am not sure about the stability of the patch and it is rather large, given that we are in stage 4. Regarding the new array descriptor: I think it would be useful if we could get the new descriptor working early in the GCC 4.10/5.0/2015 development stage. I think the main large task is to convert all all remaining stride-based code to stride-multiplier code without breaking vectorization and causing other regressions. Additionally, it would be nice to get rid of "offset" - and have in the descriptor always an lower_bound of 0, except for pointers/allocatables (cf. TS29113). I think the version on the branch is in a relatively good shape; however, the stride and offset changes seem to be of such a kind that one needs to modify several code locations simultaneously - otherwise, it will break badly. Additionally, all remaining regressions have to be fixed. When that's done, adding some extra field is all what's needed. (As follow up, enough remains to be done: I'd like to use it for all class(*), possibly even for nonarray class(type), assumed-rank needs an update, assumed-shape/-rank/deferred-shape character arrays also have to be adapted (also mandated by TS29113 for interop). And we should do an ABI cleanup in libgfortran as we have now the chance to break the ABI.) - Is anyone volunteering? Also planned for GCC post-4.9: Getting an initial really working coarray version. (Besides more mundane tasks like finishing finalization, completing OOP or ...) Tobias
Le 19/02/2014 16:51, Janus Weil a écrit : > 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 > Review: > PR fortran/51976 > * gfortran.h : Add deferred_parameter attribute. Add the name of the struct before ':' like "(struct symbol_attribute)" or maybe just "(symbol_attribute)" > * trans.c (gfc_deferred_strlen): New function. > * trans.h : Prototype for the new function. This is really nitpicking but "(gfc_deferred_strlen)" should be in front of trans.h as well. Now regarding the patch itself, I don't know character handling very well, but it seems to me that the patch makes the (wrong) assumption that characters are of default kind, so that string length is the same as memory size. Namely: > 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)); > + here... > 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))); ... and/or here, > size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, > nelems, tmp); > if (!no_malloc) > Index: gcc/fortran/trans-expr.c > =================================================================== > --- gcc/fortran/trans-expr.c (revision 207896) > +++ gcc/fortran/trans-expr.c (working copy) > @@ -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); here, > + 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); > > 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)); > and here. There may be other places that I have missed. > /* Convert to size in bytes, using the character KIND. */ > if (unlimited_char) As the patch seems to provide a wanted feature, and as the new code seems to be properly guarded, I'm not against it after the above has been checked and fixed if necessary. Mikael > 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; maybe gfc_find_component could be used here. > + *decl = strlen ? strlen->backend_decl : NULL_TREE; > + return strlen != NULL; > +}
On Sat, Feb 22, 2014 at 04:38:52PM +0100, Mikael Morin wrote: > > + > > +bool > > +gfc_deferred_strlen (gfc_component *c, tree *decl) > > +{ > > + char name[GFC_MAX_SYMBOL_LEN+1]; Shouldn't this be +2? > > + gfc_component *strlen; > > + if (!(c->ts.type == BT_CHARACTER && c->ts.deferred)) > > + return false; > > + sprintf (name, "_%s", c->name); One for NULL termination and one for '_' character. > > + for (strlen = c; strlen; strlen = strlen->next) > > + if (strcmp (strlen->name, name) == 0) > > + break; > maybe gfc_find_component could be used here. > > > + *decl = strlen ? strlen->backend_decl : NULL_TREE; > > + return strlen != NULL; > > +}
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 <burnus@gcc.gnu.org> +! + 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