From 9b5485174b808986614d6d1d1f0ec319831c9ec4 Mon Sep 17 00:00:00 2001 From: Andre Vehreschild Date: Sat, 17 Jan 2015 19:08:38 +0100 Subject: [PATCH] re PR fortran/60357 ([F08] structure constructor with unspecified values for allocatable components) 2015-01-17 Andre Vehreschild PR fortran/60357 * primary.c (build_actual_constructor): Prevent warning. * trans-expr.c (alloc_scalar_allocatable_for_subcomponent_ assignment): New function encapsulates treatment of allocatable components. (gfc_trans_subcomponent_assign): Needed to distinguish between regular assignment and initilization. (gfc_trans_structure_assign): Same. (gfc_conv_structure): Same. PR fortran/61275 * gfortran.h: deferred_parameter is not needed, because it artificial does the trick completely. * primary.c (build_actual_constructor): Same. (gfc_convert_to_structure_constructor): Same. * resolve.c (resolve_fl_derived0): Same. * trans-expr.c (gfc_conv_component_ref): Prevent treating allocatable deferred length char arrays here. (gfc_trans_subcomponent_assign): Same as above. * trans-types.c (gfc_sym_type): This is done in gfc_get_derived_type already. 2015-01-17 Andre Vehreschild PR fortran/60357 * gfortran.dg/alloc_comp_assign_13.f08: New test. PR fortran/61275 * gfortran.dg/alloc_comp_assign_14.f08: New test. PR fortran/55932 * gfortran.dg/alloc_comp_initializer_4.f03: New test. From-SVN: r219801 --- gcc/fortran/ChangeLog | 24 +++ gcc/fortran/gfortran.h | 3 - gcc/fortran/primary.c | 12 +- gcc/fortran/resolve.c | 2 +- gcc/fortran/trans-expr.c | 160 ++++++++++++++++-- gcc/fortran/trans-types.c | 11 +- gcc/testsuite/ChangeLog | 11 ++ .../gfortran.dg/alloc_comp_assign_13.f08 | 43 +++++ .../gfortran.dg/alloc_comp_assign_14.f08 | 46 +++++ .../gfortran.dg/alloc_comp_initializer_4.f03 | 14 ++ 10 files changed, 300 insertions(+), 26 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/alloc_comp_assign_13.f08 create mode 100644 gcc/testsuite/gfortran.dg/alloc_comp_assign_14.f08 create mode 100644 gcc/testsuite/gfortran.dg/alloc_comp_initializer_4.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index eb02d88d8d1..41dd282a24d 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,27 @@ +2015-01-17 Andre Vehreschild + + PR fortran/60357 + * primary.c (build_actual_constructor): Prevent warning. + * trans-expr.c (alloc_scalar_allocatable_for_subcomponent_ + assignment): New function encapsulates treatment of allocatable + components. + (gfc_trans_subcomponent_assign): Needed to distinguish between + regular assignment and initilization. + (gfc_trans_structure_assign): Same. + (gfc_conv_structure): Same. + + PR fortran/61275 + * gfortran.h: deferred_parameter is not needed, because + it artificial does the trick completely. + * primary.c (build_actual_constructor): Same. + (gfc_convert_to_structure_constructor): Same. + * resolve.c (resolve_fl_derived0): Same. + * trans-expr.c (gfc_conv_component_ref): Prevent treating + allocatable deferred length char arrays here. + (gfc_trans_subcomponent_assign): Same as above. + * trans-types.c (gfc_sym_type): This is done in + gfc_get_derived_type already. + 2015-01-17 Andre Vehreschild PR fortran/60334 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 4e2089534a6..5049c2a5e38 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -856,9 +856,6 @@ 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; } diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index a47ea92562f..cbe7aa60e7b 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2367,14 +2367,16 @@ 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) + else if (!comp->attr.artificial) { gfc_error ("No initializer for component %qs given in the" " structure constructor at %C!", comp->name); @@ -2456,7 +2458,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 || comp->attr.deferred_parameter) + if (!comp || comp->attr.artificial) { if (last_name) gfc_error ("Component initializer without name after component" diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 88f35ffb065..7a16add06b8 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -12707,7 +12707,7 @@ resolve_fl_derived0 (gfc_symbol *sym) strlen->ts.type = BT_INTEGER; strlen->ts.kind = gfc_charlen_int_kind; strlen->attr.access = ACCESS_PRIVATE; - strlen->attr.deferred_parameter = 1; + strlen->attr.artificial = 1; } } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 420d6ad59ee..328ed008542 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1158,7 +1158,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 *); @@ -1907,7 +1907,10 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) se->expr = tmp; - if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer) + /* Allocatable deferred char arrays are to be handled by the gfc_deferred_ + strlen () conditional below. */ + if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer + && !(c->attr.allocatable && c->ts.deferred)) { tmp = c->ts.u.cl->backend_decl; /* Components must always be constant length. */ @@ -6268,10 +6271,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; @@ -6282,6 +6371,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) @@ -6319,7 +6409,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) @@ -6338,6 +6429,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) @@ -6352,7 +6481,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); } } @@ -6389,7 +6518,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_add_expr_to_block (&block, tmp); } } - else if (!cm->attr.deferred_parameter) + else if (!cm->attr.artificial) { /* Scalar component (excluding deferred parameters). */ gfc_init_se (&se, NULL); @@ -6408,7 +6537,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; @@ -6440,13 +6569,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); @@ -6473,7 +6611,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; } diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index bc92abc09b5..1ee490e35f4 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1112,12 +1112,7 @@ gfc_typenode_for_spec (gfc_typespec * spec) break; case BT_CHARACTER: -#if 0 - if (spec->deferred) - basetype = gfc_get_character_type (spec->kind, NULL); - else -#endif - basetype = gfc_get_character_type (spec->kind, spec->u.cl); + basetype = gfc_get_character_type (spec->kind, spec->u.cl); break; case BT_HOLLERITH: @@ -2163,7 +2158,9 @@ gfc_sym_type (gfc_symbol * sym) && ((sym->attr.function && sym->attr.is_bind_c) || (sym->attr.result && sym->ns->proc_name - && sym->ns->proc_name->attr.is_bind_c))) + && sym->ns->proc_name->attr.is_bind_c) + || (sym->ts.deferred && (!sym->ts.u.cl + || !sym->ts.u.cl->backend_decl)))) type = gfc_character1_type_node; else type = gfc_typenode_for_spec (&sym->ts); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index dcebc53fad3..088c0f712f5 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,14 @@ +2015-01-17 Andre Vehreschild + + PR fortran/60357 + * gfortran.dg/alloc_comp_assign_13.f08: New test. + + PR fortran/61275 + * gfortran.dg/alloc_comp_assign_14.f08: New test. + + PR fortran/55932 + * gfortran.dg/alloc_comp_initializer_4.f03: New test. + 2015-01-17 Andre Vehreschild PR fortran/60334 diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_assign_13.f08 b/gcc/testsuite/gfortran.dg/alloc_comp_assign_13.f08 new file mode 100644 index 00000000000..fe697908a2d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_assign_13.f08 @@ -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 and +! Andre Vehreschild +! +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: diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_assign_14.f08 b/gcc/testsuite/gfortran.dg/alloc_comp_assign_14.f08 new file mode 100644 index 00000000000..0fd4d91f0c1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_assign_14.f08 @@ -0,0 +1,46 @@ +! { dg-do run } +! Test for allocatable scalar components and deferred length char arrays. +! Check that fix for pr61275 works. +! Contributed by Antony Lewis and +! Andre Vehreschild +! +module typeA + Type A + integer :: X + integer, allocatable :: y + character(len=:), allocatable :: c + end type A +end module + +program test_allocatable_components + use typeA + 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 + diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_initializer_4.f03 b/gcc/testsuite/gfortran.dg/alloc_comp_initializer_4.f03 new file mode 100644 index 00000000000..66a5553dec4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_initializer_4.f03 @@ -0,0 +1,14 @@ +! { dg-do run } +! Fixed by the patch for PRs 60357 and 61275 +! +! Contributed by Stefan Mauerberger +! +PROGRAM main + IMPLICIT NONE + TYPE :: test_typ + REAL, ALLOCATABLE :: a + END TYPE + TYPE(test_typ) :: my_test_typ + my_test_typ = test_typ (a = 1.0) + if (abs (my_test_typ%a - 1.0) .gt. 1e-6) call abort +END PROGRAM main -- 2.30.2