[Patch, fortran] PR51976 - [F2003] Support deferred-length character components of derived types (allocatable string length)
Janus Weil
janus@gcc.gnu.org
Wed Mar 5 13:53:00 GMT 2014
Hi Mikael,
>> The patch was regtested on x86_64-unknown-linux-gnu. Ok for trunk?
>>
> I'm asking for one more minor change, namely:
>
>> @@ -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);
>
> It's not more costly to have a more explicit name like "_%s_length" or
> something, and I prefer having the latter in complicated dumps or in the
> debugger.
I agree.
> OK with that change, with the associated buffer size update. Also Steve
> noted that the buffer size should take the terminating null character
> into account.
Steve's comment somehow got lost in the noise. I have updated both the
name and the buffer size now in resolve_fl_derived0 as well as
gfc_deferred_strlen. Updated patch attached.
A few people expressed mixed feelings, therefore I'll wait a couple of
days to allow the naysayers to chime in. In the absence of further
feedback, I'll commit the patch on the weekend.
Cheers,
Janus
-------------- next part --------------
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 208344)
+++ 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 208344)
+++ 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 208344)
+++ 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+9];
+ gfc_component *strlen;
+ sprintf (name, "_%s_length", 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 208344)
+++ 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 208344)
+++ 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 208344)
+++ 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 208344)
+++ 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 208344)
+++ 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 208344)
+++ 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+9];
+ gfc_component *strlen;
+ if (!(c->ts.type == BT_CHARACTER && c->ts.deferred))
+ return false;
+ sprintf (name, "_%s_length", 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 208344)
+++ 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 <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
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 <burnus@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
More information about the Gcc-patches
mailing list