2013-03-19 Paul Thomas <pault <at> gcc.gnu.org>
PR fortran/51976
* gfortran.h : 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-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 : Prototype for the new function.
2013-03-19 Paul Thomas <pault <at> gcc.gnu.org>
PR fortran/51976
* gfortran.dg/deferred_type_component_1.f90 : New test.
@@ -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;
}
@@ -2349,7 +2349,7 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head,
}
/* 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)
@@ -2360,7 +2360,7 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head,
return FAILURE;
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);
@@ -2443,7 +2443,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
{
/* 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"
@@ -12539,14 +12539,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 FAILURE;
- }
-
/* F2008, C442. */
if ((!sym->attr.is_class || c != sym->components)
&& c->attr.codimension
@@ -12798,6 +12790,25 @@ resolve_fl_derived0 (gfc_symbol *sym)
return FAILURE;
}
+ /* 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) == FAILURE)
+ return FAILURE;
+ 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)
@@ -7308,7 +7308,7 @@ get_full_array_size (stmtblock_t *block, tree decl, int rank)
static tree
duplicate_allocatable (tree dest, tree src, tree type, int rank,
- bool no_malloc)
+ bool no_malloc, tree strlen)
{
tree tmp;
tree size;
@@ -7329,7 +7329,11 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
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);
@@ -7349,8 +7353,11 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
gfc_init_block (&block);
nelems = get_full_array_size (&block, src, rank);
- 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)
@@ -7391,7 +7398,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
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);
}
@@ -7400,7 +7407,7 @@ gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
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);
}
@@ -7637,6 +7644,16 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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)
{
@@ -7730,8 +7747,25 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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;
tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
@@ -8183,10 +8217,24 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
/* 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)
{
@@ -1589,6 +1589,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)
@@ -6031,9 +6039,40 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
gfc_add_expr_to_block (&block, tmp);
}
}
- else
+ else if (gfc_deferred_strlen (cm, &tmp))
+ {
+ 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. */
+ /* Scalar component (excluding deferred parameters). */
gfc_init_se (&se, NULL);
gfc_init_se (&lse, NULL);
@@ -7629,7 +7668,10 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
/* 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);
}
}
@@ -5009,6 +5009,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)
@@ -2479,12 +2479,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);
}
@@ -1843,3 +1843,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;
+}
@@ -578,6 +578,9 @@ bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor_base, tree *);
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*, ...);
new file mode 100644
@@ -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