@@ -2370,11 +2370,13 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head,
return false;
value = gfc_copy_expr (comp->initializer);
}
- else if (comp->attr.allocatable)
+ else if (comp->attr.allocatable
+ || (comp->ts.type == BT_CLASS
+ && CLASS_DATA (comp)->attr.allocatable))
{
if (!gfc_notify_std (GFC_STD_F2008, "No initializer for "
- "allocatable component '%s' given in the structure "
- "constructor at %C", comp->name))
+ "allocatable component '%qs' given in the "
+ "structure constructor at %C", comp->name))
return false;
}
else if (!comp->attr.deferred_parameter)
@@ -1202,7 +1202,7 @@ realloc_lhs_warning (bt type, bool array, locus *where)
}
-static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
+static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init);
static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
gfc_expr *);
@@ -6303,10 +6303,96 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
}
+/* Allocate or reallocate scalar component, as necessary. */
+
+static void
+alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
+ tree comp,
+ gfc_component *cm,
+ gfc_expr *expr2,
+ gfc_symbol *sym)
+{
+ tree tmp;
+ tree size;
+ tree size_in_bytes;
+ tree lhs_cl_size = NULL_TREE;
+
+ if (!comp)
+ return;
+
+ if (!expr2 || expr2->rank)
+ return;
+
+ realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
+
+ if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
+ {
+ char name[GFC_MAX_SYMBOL_LEN+9];
+ gfc_component *strlen;
+ /* Use the rhs string length and the lhs element size. */
+ gcc_assert (expr2->ts.type == BT_CHARACTER);
+ if (!expr2->ts.u.cl->backend_decl)
+ {
+ gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
+ gcc_assert (expr2->ts.u.cl->backend_decl);
+ }
+
+ size = expr2->ts.u.cl->backend_decl;
+
+ /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
+ component. */
+ sprintf (name, "_%s_length", cm->name);
+ strlen = gfc_find_component (sym, name, true, true);
+ lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
+ gfc_charlen_type_node,
+ TREE_OPERAND (comp, 0),
+ strlen->backend_decl, NULL_TREE);
+
+ tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
+ tmp = TYPE_SIZE_UNIT (tmp);
+ size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (tmp), tmp,
+ fold_convert (TREE_TYPE (tmp), size));
+ }
+ else
+ {
+ /* Otherwise use the length in bytes of the rhs. */
+ size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
+ size_in_bytes = size;
+ }
+
+ size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
+ size_in_bytes, size_one_node);
+
+ if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
+ {
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_CALLOC),
+ 2, build_one_cst (size_type_node),
+ size_in_bytes);
+ tmp = fold_convert (TREE_TYPE (comp), tmp);
+ gfc_add_modify (block, comp, tmp);
+ }
+ else
+ {
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_MALLOC),
+ 1, size_in_bytes);
+ tmp = fold_convert (TREE_TYPE (comp), tmp);
+ gfc_add_modify (block, comp, tmp);
+ }
+
+ if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
+ /* Update the lhs character length. */
+ gfc_add_modify (block, lhs_cl_size, size);
+}
+
+
/* Assign a single component of a derived type constructor. */
static tree
-gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
+gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
+ gfc_symbol *sym, bool init)
{
gfc_se se;
gfc_se lse;
@@ -6317,6 +6403,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
if (cm->attr.pointer || cm->attr.proc_pointer)
{
+ /* Only care about pointers here, not about allocatables. */
gfc_init_se (&se, NULL);
/* Pointer component. */
if ((cm->attr.dimension || cm->attr.codimension)
@@ -6354,7 +6441,8 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
{
/* NULL initialization for CLASS components. */
tmp = gfc_trans_structure_assign (dest,
- gfc_class_initializer (&cm->ts, expr));
+ gfc_class_initializer (&cm->ts, expr),
+ false);
gfc_add_expr_to_block (&block, tmp);
}
else if ((cm->attr.dimension || cm->attr.codimension)
@@ -6373,6 +6461,44 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
gfc_add_expr_to_block (&block, tmp);
}
}
+ else if (init && (cm->attr.allocatable
+ || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable)))
+ {
+ /* Take care about non-array allocatable components here. The alloc_*
+ routine below is motivated by the alloc_scalar_allocatable_for_
+ assignment() routine, but with the realloc portions removed and
+ different input. */
+ alloc_scalar_allocatable_for_subcomponent_assignment (&block,
+ dest,
+ cm,
+ expr,
+ sym);
+ /* The remainder of these instructions follow the if (cm->attr.pointer)
+ if (!cm->attr.dimension) part above. */
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, expr);
+ gfc_add_block_to_block (&block, &se.pre);
+
+ if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
+ && expr->symtree->n.sym->attr.dummy)
+ se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
+ tmp = build_fold_indirect_ref_loc (input_location, dest);
+ /* For deferred strings insert a memcpy. */
+ if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
+ {
+ tree size;
+ gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
+ size = size_of_string_in_bytes (cm->ts.kind, se.string_length
+ ? se.string_length
+ : expr->ts.u.cl->backend_decl);
+ tmp = gfc_build_memcpy_call (tmp, se.expr, size);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ else
+ gfc_add_modify (&block, tmp,
+ fold_convert (TREE_TYPE (tmp), se.expr));
+ gfc_add_block_to_block (&block, &se.post);
+ }
else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
{
if (expr->expr_type != EXPR_STRUCTURE)
@@ -6387,7 +6513,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
else
{
/* Nested constructors. */
- tmp = gfc_trans_structure_assign (dest, expr);
+ tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
gfc_add_expr_to_block (&block, tmp);
}
}
@@ -6443,7 +6569,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
/* Assign a derived type constructor to a variable. */
static tree
-gfc_trans_structure_assign (tree dest, gfc_expr * expr)
+gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init)
{
gfc_constructor *c;
gfc_component *cm;
@@ -6475,13 +6601,22 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr)
c; c = gfc_constructor_next (c), cm = cm->next)
{
/* Skip absent members in default initializers. */
- if (!c->expr)
+ if (!c->expr && !cm->attr.allocatable)
continue;
field = cm->backend_decl;
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
dest, field, NULL_TREE);
- tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
+ if (!c->expr)
+ {
+ gfc_expr *e = gfc_get_null_expr (NULL);
+ tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
+ init);
+ gfc_free_expr (e);
+ }
+ else
+ tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
+ expr->ts.u.derived, init);
gfc_add_expr_to_block (&block, tmp);
}
return gfc_finish_block (&block);
@@ -6508,7 +6643,9 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
{
/* Create a temporary variable and fill it in. */
se->expr = gfc_create_var (type, expr->ts.u.derived->name);
- tmp = gfc_trans_structure_assign (se->expr, expr);
+ /* The symtree in expr is NULL, if the code to generate is for
+ initializing the static members only. */
+ tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL);
gfc_add_expr_to_block (&se->pre, tmp);
return;
}
new file mode 100644
@@ -0,0 +1,43 @@
+! { dg-do run }
+! Test for allocatable scalar components and deferred length char arrays.
+! Check that fix for pr60357 works.
+! Contributed by Antony Lewis <antony@cosmologist.info> and
+! Andre Vehreschild <vehre@gmx.de>
+!
+program test_allocatable_components
+ Type A
+ integer :: X
+ integer, allocatable :: y
+ character(len=:), allocatable :: c
+ end type A
+ Type(A) :: Me
+ Type(A) :: Ea
+
+ Me= A(X= 1, Y= 2, C="correctly allocated")
+
+ if (Me%X /= 1) call abort()
+ if (.not. allocated(Me%y) .or. Me%y /= 2) call abort()
+ if (.not. allocated(Me%c)) call abort()
+ if (len(Me%c) /= 19) call abort()
+ if (Me%c /= "correctly allocated") call abort()
+
+ ! Now check explicitly allocated components.
+ Ea%X = 9
+ allocate(Ea%y)
+ Ea%y = 42
+ ! Implicit allocate on assign in the next line
+ Ea%c = "13 characters"
+
+ if (Ea%X /= 9) call abort()
+ if (.not. allocated(Ea%y) .or. Ea%y /= 42) call abort()
+ if (.not. allocated(Ea%c)) call abort()
+ if (len(Ea%c) /= 13) call abort()
+ if (Ea%c /= "13 characters") call abort()
+
+ deallocate(Ea%y)
+ deallocate(Ea%c)
+ if (allocated(Ea%y)) call abort()
+ if (allocated(Ea%c)) call abort()
+end program
+
+! vim:ts=4:sts=4:sw=4: