From patchwork Wed Mar 5 13:53:05 2014 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Janus Weil X-Patchwork-Id: 326784 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3FDA52C00BD for ; Thu, 6 Mar 2014 00:53:26 +1100 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :mime-version:in-reply-to:references:date:message-id:subject :from:to:cc:content-type; q=dns; s=default; b=XiS+pyEieuav3rtqYJ D3blKPkkf1YcWe1LNbemRN/Xh+RF1J8lI2y/35dP3nt8xtyRZYGmc6bPvJOYNquu +O0glejrc2hfcmOJfP5laHeJOZc+YRjCfINnwlnSpunP/rpE0ZPoK6acMSLJoFvg Rqt+DeG6Y/iNIS4xqz+T/e2z0= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :mime-version:in-reply-to:references:date:message-id:subject :from:to:cc:content-type; s=default; bh=wy+wZ9oEl+0ack+vTPpRNbuo z2o=; b=cB66IBcGSwzZEaRBmb3g8jSwlbCtCCp+odq42EX1Qo8MsKhj9/wMTutY oDFxeIlDQitgDbGk9SKkWzN1fnBJ9MwpDkVRbjTIEiKxrnGJeIhj3DY5s9bACg9z l3obVKKw8b5YS0PO89dmeO+JeoKmkfx/+HhzCHu8nFkgDcxmyk0= Received: (qmail 24510 invoked by alias); 5 Mar 2014 13:53:11 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 24483 invoked by uid 89); 5 Mar 2014 13:53:10 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-2.1 required=5.0 tests=AWL, BAYES_00, FREEMAIL_ENVFROM_END_DIGIT, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mail-qa0-f50.google.com Received: from mail-qa0-f50.google.com (HELO mail-qa0-f50.google.com) (209.85.216.50) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES128-SHA encrypted) ESMTPS; Wed, 05 Mar 2014 13:53:08 +0000 Received: by mail-qa0-f50.google.com with SMTP id o15so967827qap.37 for ; Wed, 05 Mar 2014 05:53:05 -0800 (PST) MIME-Version: 1.0 X-Received: by 10.140.89.71 with SMTP id u65mr6240754qgd.93.1394027585708; Wed, 05 Mar 2014 05:53:05 -0800 (PST) Received: by 10.96.156.38 with HTTP; Wed, 5 Mar 2014 05:53:05 -0800 (PST) In-Reply-To: <5316F34A.9060702@sfr.fr> References: <5148D5DF.9000508@net-b.de> <5308C48C.9080102@sfr.fr> <5316F34A.9060702@sfr.fr> Date: Wed, 5 Mar 2014 14:53:05 +0100 Message-ID: Subject: Re: [Patch, fortran] PR51976 - [F2003] Support deferred-length character components of derived types (allocatable string length) From: Janus Weil To: Mikael Morin Cc: Tobias Burnus , Paul Richard Thomas , "fortran@gcc.gnu.org" , gcc-patches 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 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 + + 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 + + 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