From patchwork Tue Jun 12 10:09:28 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 164368 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 71115B6FB9 for ; Tue, 12 Jun 2012 20:09:48 +1000 (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=1340100588; h=Comment: DomainKey-Signature:Received:Received:Received:Received:Received: Received:Received:Date:From:To:Cc:Subject:Message-ID: MIME-Version:Content-Type:Content-Disposition:User-Agent: Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive: List-Post:List-Help:Sender:Delivered-To; bh=iKyF/kNP5SJoSHVDB2B7 iJ5vLRo=; b=sguBGv4DkT9rdtZmgjM20EdjdzUsNo+EFjLS8zoxG2MPLzy24KqB qJn9dM7cXRJTiLkrpGUGe/1b5+Wj9kIhd2uJJwJ3yXhgcQFFmr/QW7surjC4FLqR /0q9+zAAiLejPwSgCXYwYt8dPcaMWXKbLIzGaSy3osJRZhD4EmKvUZ0= 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:Received:Received:Date:From:To:Cc:Subject:Message-ID:MIME-Version:Content-Type:Content-Disposition:User-Agent:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=Sr0zsQDbl+Fm2G6KNbQoJ8ygcVLBKdjePJQQYgMiVAk6qu2+9gL/uvU+acbiNR Av+LiBJOWBwNE7zJieRjQffrMzKJQLtwwO5C1n8kN8hsHMebjb4G+0pmhruNAied A8OhGeG4XAcFpCTGgurs+q2jvsROWMO5QUEWyVf1Eil+k=; Received: (qmail 19971 invoked by alias); 12 Jun 2012 10:09:43 -0000 Received: (qmail 19956 invoked by uid 22791); 12 Jun 2012 10:09:42 -0000 X-SWARE-Spam-Status: No, hits=-1.9 required=5.0 tests=AWL, BAYES_00, RCVD_IN_HOSTKARMA_NO X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 12 Jun 2012 10:09:29 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 4E7731C622F; Tue, 12 Jun 2012 06:09:28 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id pMR3jWh-j+KM; Tue, 12 Jun 2012 06:09:28 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 32E001C6207; Tue, 12 Jun 2012 06:09:28 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 30B3E92BF6; Tue, 12 Jun 2012 06:09:28 -0400 (EDT) Date: Tue, 12 Jun 2012 06:09:28 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Thomas Quinot Subject: [Ada] Dereferences and inferable discriminants Message-ID: <20120612100928.GA10805@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) 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 An implicit dereference of an access to constrained unchecked union subtype has inferable discriminants. This change fixes the Has_Inferable_Discriminants function to take this case into account properly. The following program must compile quietly and display "OK" when executed: with Ada.Text_IO; use Ada.Text_IO; procedure UU_Subtype_Eq is type UncU (Disc : Boolean := False) is record case Disc is when False => CC : Character; when True => BC : Boolean; end case; end record; pragma Unchecked_Union (UncU); subtype UncU1 is UncU (Disc => False); type UncA is access all UncU1; X1, Y1 : aliased UncU1; task Tester is entry Test (Y : UncU1; Res : out Boolean); end Tester; task body Tester is begin accept Test (Y : UncU1; Res : out Boolean) do declare Local_Y : constant UncU1 := Y; begin if X1 = Y then Res := True; else Res := False; end if; end; end Test; end Tester; Res : Boolean; begin X1.CC := 'X'; Y1.CC := 'Y'; Tester.Test (Y1, Res); if Res then Put_Line ("KO"); else Put_Line ("OK"); end if; end UU_Subtype_Eq; Tested on x86_64-pc-linux-gnu, committed on trunk 2012-06-12 Thomas Quinot * exp_ch4.adb (Has_Inferable_Discriminants): Reorganize code to treat implicit dereferences with a constrained unchecked union nominal subtype as having inferable discriminants. Index: exp_ch4.adb =================================================================== --- exp_ch4.adb (revision 188428) +++ exp_ch4.adb (working copy) @@ -10048,11 +10048,12 @@ -------------------------------- function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is - Sel_Comp : Node_Id := N; + Sel_Comp : Node_Id; begin -- Move to the left-most prefix by climbing up the tree + Sel_Comp := N; while Present (Parent (Sel_Comp)) and then Nkind (Parent (Sel_Comp)) = N_Selected_Component loop @@ -10065,20 +10066,12 @@ -- Start of processing for Has_Inferable_Discriminants begin - -- For identifiers and indexed components, it is sufficient to have a - -- constrained Unchecked_Union nominal subtype. - - if Nkind_In (N, N_Identifier, N_Indexed_Component) then - return Is_Unchecked_Union (Base_Type (Etype (N))) - and then - Is_Constrained (Etype (N)); - -- For selected components, the subtype of the selector must be a -- constrained Unchecked_Union. If the component is subject to a -- per-object constraint, then the enclosing object must have inferable -- discriminants. - elsif Nkind (N) = N_Selected_Component then + if Nkind (N) = N_Selected_Component then if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then -- A small hack. If we have a per-object constrained selected @@ -10087,19 +10080,20 @@ if Prefix_Is_Formal_Parameter (N) then return True; - end if; -- Otherwise, check the enclosing object and the selector - return Has_Inferable_Discriminants (Prefix (N)) - and then - Has_Inferable_Discriminants (Selector_Name (N)); - end if; + else + return Has_Inferable_Discriminants (Prefix (N)) + and then Has_Inferable_Discriminants (Selector_Name (N)); + end if; -- The call to Has_Inferable_Discriminants will determine whether -- the selector has a constrained Unchecked_Union nominal type. - return Has_Inferable_Discriminants (Selector_Name (N)); + else + return Has_Inferable_Discriminants (Selector_Name (N)); + end if; -- A qualified expression has inferable discriminants if its subtype -- mark is a constrained Unchecked_Union subtype. @@ -10107,9 +10101,14 @@ elsif Nkind (N) = N_Qualified_Expression then return Is_Unchecked_Union (Etype (Subtype_Mark (N))) and then Is_Constrained (Etype (Subtype_Mark (N))); - end if; - return False; + -- For all other names, it is sufficient to have a constrained + -- Unchecked_Union nominal subtype. + + else + return Is_Unchecked_Union (Base_Type (Etype (N))) + and then Is_Constrained (Etype (N)); + end if; end Has_Inferable_Discriminants; -------------------------------