From patchwork Mon Dec 8 17:38:40 2014 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 418764 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 B22751400D5 for ; Tue, 9 Dec 2014 04:39:03 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:in-reply-to:references :mime-version:content-type; q=dns; s=default; b=b3UT2pp/iu4cYcE9 obq+QUH2mZ9ojqz58meo+hsqV7nRSYqfMYlbqWLy2eVIcC/uYrI3KKsCsJE1+2PK Tj3TPAPFspuOYv6qUF+FkXgMBV3hCu5+GdRWzX80sJhO/b+v/LGikUA+Wrc4+SI5 WS80zPuHpOhdoGIMkTZ/XKxrD0I= 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:date :from:to:cc:subject:message-id:in-reply-to:references :mime-version:content-type; s=default; bh=UT+phtDYA2uY/02bvV3wWd f5G6Y=; b=RR24BHuZIRZnfxqJdWLUt4mEljnvbf0WAHzTm/cys9YxyuAzK97z2C 70nWNVAuUGtGhSe1l0WuRuGA7CE/x6iOxtxTz0xS4Um9B/4saN1z4yNlBCIU6BCT 2YVhjFlmv8yXb4mBhiDf8H9M0SmLXyOhRBz+mlYHbXnh+oU1YCuTo= Received: (qmail 329 invoked by alias); 8 Dec 2014 17:38:56 -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 302 invoked by uid 89); 8 Dec 2014 17:38:55 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=0.1 required=5.0 tests=AWL, BAYES_50, FREEMAIL_FROM, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 3 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.15.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-GCM-SHA384 encrypted) ESMTPS; Mon, 08 Dec 2014 17:38:52 +0000 Received: from localhost ([84.63.49.248]) by mail.gmx.com (mrgmx002) with ESMTPSA (Nemesis) id 0M8edX-1XkvEf1bLn-00wD1f; Mon, 08 Dec 2014 18:38:42 +0100 Date: Mon, 8 Dec 2014 18:38:40 +0100 From: Andre Vehreschild To: dominiq@lps.ens.fr (Dominique Dhumieres) Cc: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org, janus@gcc.gnu.org, mikael.morin@sfr.fr, Antony Lewis Subject: Re: [RFC, PATCH, fortran] PR fortran/60255 Deferred character length Message-ID: <20141208183840.45364899@gmx.de> In-Reply-To: <20140817123221.31BBB105@mailhost.lps.ens.fr> References: <20140817123221.31BBB105@mailhost.lps.ens.fr> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; Hi all, please find attached a more elaborate patch for pr60255. I totally agree that my first attempt was just scratching the surface of the work needed. This patch also is *not* complete, but because I am really new to gfortran patching, I don't want to present a final patch only to learn then, that I have violated design rules, common practice or the like. Therefore please comment and direct me to any sources/ideas to improve the patch. Topic: The pr 60255 is about assigning a char array to an unlimited polymorphic entity. In the comments the concern about the lost length information is raised. The patch adds a _len component to the unlimited polymorphic entity (after _data and _vtab) and adds an assignment of the string length to _len when a string is pointer assigned to the unlimited poly entity. Furthermore is the intrinsic len(unlimited poly pointing to a string) resolved to give the _len component. Yet missing: - assign _len component back to deferred char array length component - transport length along chains of unlimited poly entities, i.e., a => b; c => a where all objects are unlimited poly and b is a string. - allocate() in this context Patch dependencies: none Comments, concerns, candy welcome! Regards, Andre On Sun, 17 Aug 2014 14:32:21 +0200 dominiq@lps.ens.fr (Dominique Dhumieres) wrote: > > the testcase should check that the code generated is actually working, > > not just that the ICE disappeared. > > I agree. Note that there is a test in the comment 3 of PR60255 that > can be used to check the run time behavior (and possibly check the > vtab issue). > > Dominique diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 0286c9e..29e31e1 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -2403,6 +2403,38 @@ yes: return true; } +/* Add the component _len to the class-type variable in c->expr1. */ + +void +gfc_add_len_component (gfc_code *c) +{ + /* Just make sure input is correct. This is already at the calling site, + but may be this routine is called from somewhere else in the furure. */ + gcc_assert (UNLIMITED_POLY(c->expr1) + && c->expr2 + && c->expr2->ts.type== BT_CHARACTER); + + gfc_component *len; + gfc_expr *e; + /* Check that _len is not present already. */ + if ((len= gfc_find_component (c->expr1->ts.u.derived, "_len", true, true))) + return; + /* Create the new component. */ + if (!gfc_add_component (c->expr1->ts.u.derived, "_len", &len)) + // Possible errors are already reported in add_component + return; + len->ts.type = BT_INTEGER; + len->ts.kind = 4; + len->attr.access = ACCESS_PRIVATE; + + /* Build minimal expression to initialize component with zero. */ + e = gfc_get_expr(); + e->ts = c->expr1->ts; + e->expr_type = EXPR_VARIABLE; + len->initializer = gfc_get_int_expr (gfc_default_integer_kind, + NULL, 0); + gfc_free_expr (e); +} /* Find (or generate) the symbol for an intrinsic type's vtab. This is needed to support unlimited polymorphism. */ @@ -2415,18 +2447,9 @@ find_intrinsic_vtab (gfc_typespec *ts) gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; int charlen = 0; - if (ts->type == BT_CHARACTER) - { - if (ts->deferred) - { - gfc_error ("TODO: Deferred character length variable at %C cannot " - "yet be associated with unlimited polymorphic entities"); - return NULL; - } - else if (ts->u.cl && ts->u.cl->length - && ts->u.cl->length->expr_type == EXPR_CONSTANT) - charlen = mpz_get_si (ts->u.cl->length->value.integer); - } + if (ts->type == BT_CHARACTER && !ts->deferred && ts->u.cl && ts->u.cl->length + && ts->u.cl->length->expr_type == EXPR_CONSTANT) + charlen = mpz_get_si (ts->u.cl->length->value.integer); /* Find the top-level namespace. */ for (ns = gfc_current_ns; ns; ns = ns->parent) @@ -2437,10 +2460,16 @@ find_intrinsic_vtab (gfc_typespec *ts) { char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; - if (ts->type == BT_CHARACTER) - sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type), - charlen, ts->kind); - else + if (ts->type == BT_CHARACTER) { + if (!ts->deferred) + sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type), + charlen, ts->kind); + else + /* The type is deferred here. Ensure that this is easily seen in the + vtable. */ + sprintf (tname, "%s_DEFERRED_%d", gfc_basic_typename (ts->type), + ts->kind); + } else sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind); sprintf (name, "__vtab_%s", tname); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 1058502..f99c3f8 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3192,6 +3192,8 @@ gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *); unsigned int gfc_hash_value (gfc_symbol *); bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *, gfc_array_spec **); +void gfc_add_len_component(gfc_code *); +void gfc_assign_charlen_to_unlimited_poly(gfc_code *c); gfc_symbol *gfc_find_derived_vtab (gfc_symbol *); gfc_symbol *gfc_find_vtab (gfc_typespec *); gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, bool*, diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 9d7d3c2..6e14e74 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -10081,7 +10081,11 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns) if (!t) break; - gfc_check_pointer_assign (code->expr1, code->expr2); + if (gfc_check_pointer_assign (code->expr1, code->expr2) + && UNLIMITED_POLY(code->expr1) + && code->expr2->ts.type== BT_CHARACTER) + gfc_add_len_component (code); + break; } diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 7ccabc7..88cd8e7 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -3687,6 +3687,31 @@ gfc_simplify_leadz (gfc_expr *e) return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz); } +static gfc_expr * +get__len_component (gfc_expr *e) +{ + gfc_expr *len_comp; + gfc_ref *ref, **last; + len_comp = gfc_copy_expr(e->symtree->n.sym->assoc->target); + /* We need to remove the last _data component ref from ptr. */ + last = &(len_comp->ref); + ref = len_comp->ref; + while (ref) + { + if (!ref->next + && ref->type == REF_COMPONENT + && strcmp("_data", ref->u.c.component->name)== 0) + { + gfc_free_ref_list(ref); + *last = NULL; + break; + } + last = &(ref->next); + ref = ref->next; + } + gfc_add_component_ref(len_comp, "_len"); + return len_comp; +} gfc_expr * gfc_simplify_len (gfc_expr *e, gfc_expr *kind) @@ -3711,6 +3736,13 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind) mpz_set (result->value.integer, e->ts.u.cl->length->value.integer); return range_check (result, "LEN"); } + else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER + && e->symtree->n.sym + && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target + && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED) + { + return get__len_component (e); + } else return NULL; } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index f8e4df8..9a08bde 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1034,11 +1034,11 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op) gfc_add_vptr_component (lhs); if (UNLIMITED_POLY (expr1) - && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN) - { - rhs = gfc_get_null_expr (&expr2->where); - goto assign_vptr; - } + && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN) + { + rhs = gfc_get_null_expr (&expr2->where); + goto assign_vptr; + } if (expr2->expr_type == EXPR_NULL) vtab = gfc_find_vtab (&expr1->ts); @@ -6695,6 +6695,43 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) } +/* Create the character length assignment to the _len component. */ + +void +add_assignment_of_string_len_to_len_component (stmtblock_t *block, + gfc_expr *ptr, gfc_se *ptr_se, + gfc_se *str) +{ + gfc_expr *len_comp; + gfc_ref *ref, **last; + gfc_se lse; + len_comp = gfc_copy_expr(ptr); + /* We need to remove the last _data component ref from ptr. */ + last = &(len_comp->ref); + ref = len_comp->ref; + while (ref) + { + if (!ref->next + && ref->type == REF_COMPONENT + && strcmp("_data", ref->u.c.component->name)== 0) + { + gfc_free_ref_list(ref); + *last = NULL; + break; + } + last = &(ref->next); + ref = ref->next; + } + gfc_add_component_ref(len_comp, "_len"); + gfc_init_se (&lse, NULL); + gfc_conv_expr (&lse, len_comp); + + /* ptr % _len = len (str) */ + gfc_add_modify (block, lse.expr, str->string_length); + ptr_se->string_length = lse.expr; + gfc_free_expr (len_comp); +} + tree gfc_trans_pointer_assign (gfc_code * code) { @@ -6759,6 +6796,15 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_add_block_to_block (&block, &lse.pre); gfc_add_block_to_block (&block, &rse.pre); + /* For string assignments to unlimited polymorphic pointers add an + assignment of the string_length to the _len component of the pointer. */ + if (expr1->ts.type == BT_DERIVED + && expr1->ts.u.derived->attr.unlimited_polymorphic + && expr2->ts.type == BT_CHARACTER) + { + add_assignment_of_string_len_to_len_component (&block, expr1, &lse, &rse); + } + /* Check character lengths if character expression. The test is only really added if -fbounds-check is enabled. Exclude deferred character length lefthand sides. */ diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f03 new file mode 100644 index 0000000..6042882 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f03 @@ -0,0 +1,57 @@ +! { dg-do run } +! Testing fix for +! PR fortran/60255 +! +program test + implicit none + character(LEN=:), allocatable :: S + call subP(S) + call sub2() + call sub1("test") + +contains + + subroutine sub1(dcl) + character(len=*), target :: dcl + class(*), pointer :: ucp +! character(len=:), allocatable ::def + + ucp => dcl + + select type (ucp) + type is (character(len=*)) + if (len(ucp) .NE. 4) then + call abort() +! else +! def = ucp +! if (len(def) .NE. 4) then +! call abort() ! This abort is expected currently +! end if + end if + class default + call abort() + end select + end subroutine + + subroutine sub2 + character(len=:), allocatable, target :: dcl + class(*), pointer :: ucp + + dcl = "ttt" + ucp => dcl + + select type (ucp) + type is (character(len=*)) + if (len(ucp) .NE. 3) then + call abort() + end if + class default + call abort() + end select + end subroutine + + subroutine subP(P) + class(*) :: P + end subroutine + +end program diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 index 8e80386..30e4797 100644 --- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 @@ -5,7 +5,7 @@ ! Contributed by Paul Thomas ! and Tobias Burnus ! - CHARACTER(:), allocatable, target :: chr ! { dg-error "TODO: Deferred character length variable" } + CHARACTER(:), allocatable, target :: chr ! F2008: C5100 integer :: i(2) logical :: flag