Hi Mikael, hi all,
2014-02-22 16:38 GMT+01:00 Mikael Morin <mikael.mo...@sfr.fr>:
> 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 ...
>
> 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.
Done.
> 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...
Fixed (but actually in the code which calls duplicate_allocatable).
>> 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,
Also fixed (again by using size_of_string_in_bytes).
>> + 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.
Actually I don't see a problem here. Also no further modifications
were necessary to get a KIND=4 example to work.
>> /* 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.
Attached is a new version of the patch which fixes the above-mentioned
problems and should make the non-default-kind cases work. I have added
a KIND=4 version of the original test case, which seems to work
properly.
The patch was regtested on x86_64-unknown-linux-gnu. Ok for trunk?
Btw, there was quite some user feedback along the lines of "we want
this feature", but there was not a lot of actual testing. So, if you
are interested in this feature, please try the patch and report back
here with things like "I tested it and it works great on my 100kLOC
code" or "I tested it and found the following problem ..."
Cheers,
Janus
2014-03-01 Paul Thomas <pault <at> gcc.gnu.org>
Janus Weil <ja...@gcc.gnu.org>
PR fortran/51976
* gfortran.h (symbol_attribute): 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-intrinsic (size_of_string_in_bytes): Make non-static.
* 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 (size_of_string_in_bytes,gfc_deferred_strlen): New prototypes.
2014-03-01 Paul Thomas <pault <at> gcc.gnu.org>
Janus Weil <ja...@gcc.gnu.org>
PR fortran/51976
* gfortran.dg/deferred_type_component_1.f90 : New test.
* gfortran.dg/deferred_type_component_2.f90 : New test.
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 208241)
+++ 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 208241)
+++ 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 208241)
+++ 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 208241)
+++ 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 str_sz)
{
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 (str_sz != NULL_TREE)
+ size = str_sz;
+ 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 (str_sz != NULL_TREE)
+ tmp = fold_convert (gfc_array_index_type, str_sz);
+ 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,27 @@ 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, size;
+ 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);
+ size = size_of_string_in_bytes (c->ts.kind, len);
+ tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
+ false, size);
+ 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 +8377,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 208241)
+++ 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,42 @@ 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
+ {
+ tree size;
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, expr);
+ size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_MALLOC),
+ 1, size);
+ 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, size);
+ 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 +7788,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-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c (revision 208241)
+++ gcc/fortran/trans-intrinsic.c (working copy)
@@ -5166,7 +5166,7 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * e
excluding the terminating null characters. The result has
gfc_array_index_type type. */
-static tree
+tree
size_of_string_in_bytes (int kind, tree string_length)
{
tree bytesize;
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (revision 208241)
+++ 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 208241)
+++ 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 208241)
+++ 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 208241)
+++ gcc/fortran/trans.h (working copy)
@@ -422,6 +422,8 @@ tree gfc_evaluate_now (tree, stmtblock_t *);
/* Find the appropriate variant of a math intrinsic. */
tree gfc_builtin_decl_for_float_kind (enum built_in_function, int);
+tree size_of_string_in_bytes (int, tree);
+
/* Intrinsic procedure handling. */
tree gfc_conv_intrinsic_subroutine (gfc_code *);
void gfc_conv_intrinsic_function (gfc_se *, gfc_expr *);
@@ -581,6 +583,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,60 @@
+! { dg-do run }
+!
+! PR 51976: [F2003] Support deferred-length character components of derived
types (allocatable string length)
+!
+! Contributed by Tobias Burnus <bur...@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
Index: gcc/testsuite/gfortran.dg/deferred_type_component_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/deferred_type_component_2.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/deferred_type_component_2.f90 (working copy)
@@ -0,0 +1,60 @@
+! { dg-do run }
+!
+! PR 51976: [F2003] Support deferred-length character components of derived
types (allocatable string length)
+!
+! Contributed by Tobias Burnus <bur...@gcc.gnu.org>
+
+ type t
+ character(len=:,kind=4), allocatable :: str_comp
+ character(len=:,kind=4), allocatable :: str_comp1
+ end type t
+ type(t) :: x
+ type(t), allocatable, dimension(:) :: array
+
+ ! Check scalars
+ allocate (x%str_comp, source = 4_"abc")
+ call check (x%str_comp, 4_"abc")
+ deallocate (x%str_comp)
+ allocate (x%str_comp, source = 4_"abcdefghijklmnop")
+ call check (x%str_comp, 4_"abcdefghijklmnop")
+ x%str_comp = 4_"xyz"
+ call check (x%str_comp, 4_"xyz")
+ x%str_comp = 4_"abcdefghijklmnop"
+ x%str_comp1 = 4_"lmnopqrst"
+ call foo (x%str_comp1, 4_"lmnopqrst")
+ call bar (x, 4_"abcdefghijklmnop", 4_"lmnopqrst")
+
+ ! Check arrays and structure constructors
+ allocate (array(2), source = [t(4_"abcedefg",4_"hi"), t(4_"jkl",4_"mnop")])
+ call check (array(1)%str_comp, 4_"abcedefg")
+ call check (array(1)%str_comp1, 4_"hi")
+ call check (array(2)%str_comp, 4_"jkl")
+ call check (array(2)%str_comp1, 4_"mnop")
+ deallocate (array)
+ allocate (array(3), source = [x, x, x])
+ array(2)%str_comp = 4_"blooey"
+ call bar (array(1), 4_"abcdefghijklmnop", 4_"lmnopqrst")
+ call bar (array(2), 4_"blooey", 4_"lmnopqrst")
+ call bar (array(3), 4_"abcdefghijklmnop", 4_"lmnopqrst")
+
+contains
+
+ subroutine foo (chr1, chr2)
+ character (len=*,kind=4) :: chr1, chr2
+ call check (chr1, chr2)
+ end subroutine
+
+ subroutine bar (a, chr1, chr2)
+ character (len=*,kind=4) :: chr1, chr2
+ type(t) :: a
+ call check (a%str_comp, chr1)
+ call check (a%str_comp1, chr2)
+ end subroutine
+
+ subroutine check (chr1, chr2)
+ character (len=*,kind=4) :: chr1, chr2
+ if (len(chr1) .ne. len (chr2)) call abort
+ if (chr1 .ne. chr2) call abort
+ end subroutine
+
+end
