From 2b3dc0db6276666c03156b7b6c5081a87d6ac276 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Thu, 6 Mar 2014 21:45:31 +0000 Subject: [PATCH] re PR fortran/51976 ([F2003] Support deferred-length character components of derived types (allocatable string length)) 2014-03-06 Paul Thomas Janus Weil PR fortran/51976 * gfortran.h (symbol_attribute): 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-intrinsic (size_of_string_in_bytes): Make non-static. * 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 (size_of_string_in_bytes,gfc_deferred_strlen): New prototypes. 2014-03-06 Paul Thomas Janus Weil PR fortran/51976 * gfortran.dg/deferred_type_component_1.f90 : New test. * gfortran.dg/deferred_type_component_2.f90 : New test. Co-Authored-By: Janus Weil From-SVN: r208386 --- gcc/fortran/ChangeLog | 36 +++++++++++ gcc/fortran/gfortran.h | 3 + gcc/fortran/primary.c | 6 +- gcc/fortran/resolve.c | 27 +++++--- gcc/fortran/trans-array.c | 73 ++++++++++++++++++---- gcc/fortran/trans-expr.c | 50 ++++++++++++++- gcc/fortran/trans-intrinsic.c | 2 +- gcc/fortran/trans-stmt.c | 5 ++ gcc/fortran/trans-types.c | 5 +- gcc/fortran/trans.c | 18 ++++++ gcc/fortran/trans.h | 5 ++ gcc/testsuite/ChangeLog | 7 +++ .../gfortran.dg/deferred_type_component_1.f90 | 60 ++++++++++++++++++ .../gfortran.dg/deferred_type_component_2.f90 | 60 ++++++++++++++++++ 14 files changed, 329 insertions(+), 28 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/deferred_type_component_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/deferred_type_component_2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 549421f..f68353a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,39 @@ +2014-03-06 Paul Thomas + Janus Weil + + PR fortran/51976 + * gfortran.h (symbol_attribute): 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-intrinsic (size_of_string_in_bytes): Make non-static. + * 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 (size_of_string_in_bytes,gfc_deferred_strlen): New prototypes. + 2014-03-01 Mikael Morin PR fortran/60341 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 197798c..cd2a913 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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; } diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 7d7fbad..e2eb467 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2355,7 +2355,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) @@ -2365,7 +2365,7 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head, 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, 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" diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 8d5ca1b..bcdfcad 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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) diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 8e7b75e..153ef67 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -7365,7 +7365,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 str_sz) { tree tmp; tree size; @@ -7386,7 +7386,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 (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 type, int rank, 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 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); } @@ -7461,7 +7468,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); } @@ -7718,6 +7725,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) { @@ -7855,8 +7872,26 @@ 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, 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) @@ -8342,10 +8377,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) { diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 297ff67..269fcc5 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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_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 + { + 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. */ + /* 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_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); } } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index cff8e89..75bd20a 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -5166,7 +5166,7 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) 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; diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 19e29a7..c7ff7a8 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -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) diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index adc34dd..be268cf 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -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); } diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index c5b3b9e..073e34f 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -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; +} diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index e05a375..5fb0cbf 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -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_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*, ...); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 779fa96..fe4a19b 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2014-03-06 Paul Thomas + Janus Weil + + PR fortran/51976 + * gfortran.dg/deferred_type_component_1.f90 : New test. + * gfortran.dg/deferred_type_component_2.f90 : New test. + 2014-03-06 Marek Polacek PR c/60197 diff --git a/gcc/testsuite/gfortran.dg/deferred_type_component_1.f90 b/gcc/testsuite/gfortran.dg/deferred_type_component_1.f90 new file mode 100644 index 0000000..a7826d9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_type_component_1.f90 @@ -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 + + 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 diff --git a/gcc/testsuite/gfortran.dg/deferred_type_component_2.f90 b/gcc/testsuite/gfortran.dg/deferred_type_component_2.f90 new file mode 100644 index 0000000..63e7fa3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_type_component_2.f90 @@ -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 + + 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 -- 2.7.4