From patchwork Sun Feb 12 21:11:50 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 140835 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]) by ozlabs.org (Postfix) with SMTP id 4B057B6FA7 for ; Mon, 13 Feb 2012 08:12:17 +1100 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1329685938; h=Comment: DomainKey-Signature:Received:Received:Received:Received:Received: Message-ID:Date:From:User-Agent:MIME-Version:To:Subject: Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:Sender:Delivered-To; bh=h8JjN5T a88mYpkDmdURB8yZG8QI=; b=S4sqTjtcDcOyAYSesTeRqTEWIlLDRZIV328wN/h LY1rUgwxT478ACt06X4gnYsxeL68FPnRfFvuW+vtHr29kCopHSvaq4AsMJOWPBe1 IHzYolsBFFMnOX7HcQvLDGyn02XF1IlEST53FX4kVDILpooxZCf6lfTpiTtFr5nj RrT8= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Received:X-SFR-UUID:Message-ID:Date:From:User-Agent:MIME-Version:To:Subject:Content-Type:X-sfr-mailing:X-IsSubscribed:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=xOawyjHLxSobUGe9v7AN3tgSLeuAMzL63fVNJ7a+DcsR0PV7PIqFm6EELFs6X8 yAvVsrFjFWmY+COYFAeJmnbnGYxcs2QfAFAhvDHwjahfK7YkH5BY8wg+ZbUt6UcD nmykSW4AYv4Z+dmHcBPc0zhh4AsQGJoaq2HapTfcoSHA0=; Received: (qmail 18155 invoked by alias); 12 Feb 2012 21:12:14 -0000 Received: (qmail 18141 invoked by uid 22791); 12 Feb 2012 21:12:13 -0000 X-SWARE-Spam-Status: No, hits=-1.0 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from smtp24.services.sfr.fr (HELO smtp24.services.sfr.fr) (93.17.128.82) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Sun, 12 Feb 2012 21:11:57 +0000 Received: from filter.sfr.fr (localhost [127.0.0.1]) by msfrf2406.sfr.fr (SMTP Server) with ESMTP id DFD707000324; Sun, 12 Feb 2012 22:11:55 +0100 (CET) Received: from gimli.local (105.123.193.77.rev.sfr.net [77.193.123.105]) by msfrf2406.sfr.fr (SMTP Server) with ESMTP id 47D267000276; Sun, 12 Feb 2012 22:11:55 +0100 (CET) X-SFR-UUID: 20120212211155294.47D267000276@msfrf2406.sfr.fr Message-ID: <4F382B16.7090005@sfr.fr> Date: Sun, 12 Feb 2012 22:11:50 +0100 From: Mikael Morin User-Agent: Mozilla/5.0 (X11; FreeBSD amd64; rv:9.0) Gecko/20120112 Thunderbird/9.0 MIME-Version: 1.0 To: gfortran , gcc-patches Subject: [Patch, fortran] PR50981 absent polymorphic scalar actual arguments X-sfr-mailing: LEGIT X-IsSubscribed: yes 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 Hello, this is the next PR50981 fix: when passing polymorphic scalar actual arguments to elemental procedures, we were not adding the "_data" component reference. The fix is straightforward; checking that the expression's type is BT_CLASS was introducing regressions, so this patch uses a helper function to check the type without impacting the testsuite. Regression tested on x86_64-unknown-freebsd9.0. OK for trunk? Mikael 2012-02-12 Mikael Morin * trans-expr.c (is_class_container_ref): New function. (gfc_conv_procedure_call): Add a "_data" component reference to polymorphic actual arguments. 2012-02-12 Mikael Morin * gfortran.dg/elemental_optional_args_5.f03: Add subcomponent actual argument checks. --- elemental_optional_args_5.f03.old 2012-02-12 20:42:21.000000000 +0100 +++ elemental_optional_args_5.f03 2012-02-12 20:42:50.000000000 +0100 @@ -115,6 +115,111 @@ call sub_t (v, tp, .false.) if (s /= 3) call abort() if (any (v /= [9, 33])) call abort() +call sub_t (s, ca, .false.) +call sub_t (v, ca, .false.) +!print *, s, v +if (s /= 3) call abort() +if (any (v /= [9, 33])) call abort() + +call sub_t (s, cp, .false.) +call sub_t (v, cp, .false.) +!print *, s, v +if (s /= 3) call abort() +if (any (v /= [9, 33])) call abort() + +! SCALAR COMPONENTS: alloc/assoc + +allocate (ta, tp, ca, cp) +ta%a = 4 +tp%a = 5 +ca%a = 6 +cp%a = 7 + +call sub_t (s, ta, .true.) +call sub_t (v, ta, .true.) +!print *, s, v +if (s /= 4*2) call abort() +if (any (v /= [4*2, 4*2])) call abort() + +call sub_t (s, tp, .true.) +call sub_t (v, tp, .true.) +!print *, s, v +if (s /= 5*2) call abort() +if (any (v /= [5*2, 5*2])) call abort() + +call sub_t (s, ca, .true.) +call sub_t (v, ca, .true.) +!print *, s, v +if (s /= 6*2) call abort() +if (any (v /= [6*2, 6*2])) call abort() + +call sub_t (s, cp, .true.) +call sub_t (v, cp, .true.) +!print *, s, v +if (s /= 7*2) call abort() +if (any (v /= [7*2, 7*2])) call abort() + +! ARRAY COMPONENTS: Non alloc/assoc + +v = [9, 33] + +call sub_t (v, taa, .false.) +!print *, v +if (any (v /= [9, 33])) call abort() + +call sub_t (v, tpa, .false.) +!print *, v +if (any (v /= [9, 33])) call abort() + +call sub_t (v, caa, .false.) +!print *, v +if (any (v /= [9, 33])) call abort() + +call sub_t (v, cpa, .false.) +!print *, v +if (any (v /= [9, 33])) call abort() + +deallocate(ta, tp, ca, cp) + + +! ARRAY COMPONENTS: alloc/assoc + +allocate (taa(2), tpa(2)) +taa(1:2)%a = [44, 444] +tpa(1:2)%a = [55, 555] +allocate (caa(2), source=[t(66), t(666)]) +allocate (cpa(2), source=[t(77), t(777)]) + +select type (caa) +type is (t) + if (any (caa(:)%a /= [66, 666])) call abort() +end select + +select type (cpa) +type is (t) + if (any (cpa(:)%a /= [77, 777])) call abort() +end select + +call sub_t (v, taa, .true.) +!print *, v +if (any (v /= [44*2, 444*2])) call abort() + +call sub_t (v, tpa, .true.) +!print *, v +if (any (v /= [55*2, 555*2])) call abort() + + +call sub_t (v, caa, .true.) +!print *, v +if (any (v /= [66*2, 666*2])) call abort() + +call sub_t (v, cpa, .true.) +!print *, v +if (any (v /= [77*2, 777*2])) call abort() + +deallocate (taa, tpa, caa, cpa) + + contains elemental subroutine sub1 (x, y, alloc) diff --git a/trans-expr.c b/trans-expr.c index 18ce1a7..ff4360e 100644 --- a/trans-expr.c +++ b/trans-expr.c @@ -3362,6 +3362,39 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, } +/* Tells whether the expression E is a reference to a (scalar) class container. + Scalar because array class containers usually have an array reference after + them, and gfc_fix_class_refs will add the missing "_data" component reference + in that case. */ + +static bool +is_class_container_ref (gfc_expr *e) +{ + gfc_ref *ref; + bool result; + + if (e->expr_type != EXPR_VARIABLE) + return e->ts.type == BT_CLASS; + + if (e->symtree->n.sym->ts.type == BT_CLASS) + result = true; + else + result = false; + + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type != REF_COMPONENT) + result = false; + else if (ref->u.c.component->ts.type == BT_CLASS) + result = true; + else + result = false; + } + + return result; +} + + /* Generate code for a procedure call. Note can return se->post != NULL. If se->direct_byref is set then se->expr contains the return parameter. Return nonzero, if the call has alternate specifiers. @@ -3542,6 +3575,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else gfc_conv_expr_reference (&parmse, e); + if (fsym && fsym->ts.type == BT_DERIVED && is_class_container_ref (e)) + parmse.expr = gfc_class_data_get (parmse.expr); + /* If we are passing an absent array as optional dummy to an elemental procedure, make sure that we pass NULL when the data pointer is NULL. We need this extra conditional because of