From patchwork Mon Dec 29 13:12:43 2014 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 424437 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 C867E1400DD for ; Tue, 30 Dec 2014 00:13:09 +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=B20itqNkk1SQNblz C7RAXmtgKIZPKKmepH81+cK09Ekfm0VtAP0ZAwydKgqzKnck6WuBD/7ZYn98CDXY lI5Uv9jvhSD9vWSfWrQcKCFC1+Y39uSbHPa266I0h8VnS8v9lKSLWgr9wRimOgUa 3BkfJDo39ZK7tcHTZiUVyje7YIs= 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=DXe3gHBFX0uyCY2UQYVgGF WRxuM=; b=g9b8eEYE9mbm0jZU+HUtpGz1Hap4MFFojzyNxFUVMe/teZ7J4t6niY tpmL5f2HEdCgYywB7QTimcGpB5M3M2odTa1dV1sGbODc66fr4jIpkO6ukrug01UA vpfTA5sptUJFq0evDBFKQ3EWM9BxB4uqKp1KnumznK1C7V4P9h5js= Received: (qmail 29865 invoked by alias); 29 Dec 2014 13:12: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 29841 invoked by uid 89); 29 Dec 2014 13:12:55 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.4 required=5.0 tests=AWL, BAYES_00, 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.17.20) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-GCM-SHA384 encrypted) ESMTPS; Mon, 29 Dec 2014 13:12:53 +0000 Received: from localhost ([84.63.49.248]) by mail.gmx.com (mrgmx101) with ESMTPSA (Nemesis) id 0Lkjuq-1XXcst2gKK-00aTCo; Mon, 29 Dec 2014 14:12:47 +0100 Date: Mon, 29 Dec 2014 14:12:43 +0100 From: Andre Vehreschild To: Paul Richard Thomas Cc: Dominique Dhumieres , Mikael Morin , "fortran@gcc.gnu.org" , gcc-patches , Antony Lewis , Janus Weil Subject: [PATCH, Fortran] PR fortran/60289 Fixing character array allocation for class(*) type variable Message-ID: <20141229141243.668f9935@gmx.de> In-Reply-To: <20141221114922.072de33a@gmx.de> References: <20140817124653.1F3C2105@mailhost.lps.ens.fr> <53F0D4DF.6050907@sfr.fr> <20140817163904.A66CB105@mailhost.lps.ens.fr> <20141220163823.7bda41f6@gmx.de> <20141221114922.072de33a@gmx.de> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; Hi all, this patches fixes PR60289 for allocating unlimited polymorphic entities retyping them to a char array. The patch depends on my former patch for pr60255 at: https://gcc.gnu.org/ml/fortran/2014-12/msg00130.html because it needs the _len component introduced. I have extend Janus' patch given in the PR and added a testcase. This is the fifth version of the patch, where the previous hasn't gotten any comments, so I think it is well enough for commit. What do you think? Bootstraps and regtests ok on x86_64-linux-gnu. Depends on: https://gcc.gnu.org/ml/fortran/2014-12/msg00130.html Regards, Andre diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 05a948b..6038dd5 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6930,7 +6930,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) goto failure; } - if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred) + /* Check F08:C632. */ + if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred + && !UNLIMITED_POLY (e)) { int cmp = gfc_dep_compare_expr (e->ts.u.cl->length, code->ext.alloc.ts.u.cl->length); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index c560d05..82ecf31 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5139,8 +5139,15 @@ gfc_trans_allocate (gfc_code * code) gfc_add_block_to_block (&se.pre, &se_sz.pre); se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre); gfc_add_block_to_block (&se.pre, &se_sz.post); - /* Store the string length. */ - tmp = al->expr->ts.u.cl->backend_decl; + /* Store the string length. Get the backend_decl of the _len + component for that. */ + if ((expr->symtree->n.sym->ts.type == BT_CLASS + || expr->symtree->n.sym->ts.type == BT_DERIVED) + && expr->ts.u.derived->attr.unlimited_polymorphic) + tmp = gfc_class_len_get (gfc_get_symbol_decl ( + expr->symtree->n.sym)); + else + tmp = al->expr->ts.u.cl->backend_decl; gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp), se_sz.expr)); tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts)); diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_21.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_21.f90 new file mode 100644 index 0000000..18a66b0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_21.f90 @@ -0,0 +1,57 @@ +! { dg-do run } +! Testing fix for PR fortran/60289 +! Contributed by: Andre Vehreschild +! +program test + implicit none + + class(*), pointer :: P + integer :: string_len = 10 *2 + + allocate(character(string_len)::P) + + select type(P) + type is (character(*)) + P ="some test string" + if (P .ne. "some test string") then + call abort () + end if + if (len(P) .ne. 20) then + call abort () + end if + if (len(P) .eq. len("some test string")) then + call abort () + end if + class default + call abort () + end select + + deallocate(P) + + ! Now for kind=4 chars. + + allocate(character(len=20,kind=4)::P) + + select type(P) + type is (character(len=*,kind=4)) + P ="some test string" + if (P .ne. 4_"some test string") then + call abort () + end if + if (len(P) .ne. 20) then + call abort () + end if + if (len(P) .eq. len("some test string")) then + call abort () + end if + type is (character(len=*,kind=1)) + call abort () + class default + call abort () + end select + + deallocate(P) + + +end program test +