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 <ja...@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 <bur...@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.
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 <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
