From patchwork Mon Oct 4 13:38:43 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 66652 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 91560B70CB for ; Tue, 5 Oct 2010 00:38:54 +1100 (EST) Received: (qmail 23059 invoked by alias); 4 Oct 2010 13:38:52 -0000 Received: (qmail 23049 invoked by uid 22791); 4 Oct 2010 13:38:50 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (212.99.106.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 04 Oct 2010 13:38:45 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id DB195CB0260; Mon, 4 Oct 2010 15:38:43 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id ZHl6SG80aQVI; Mon, 4 Oct 2010 15:38:43 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id C92A9CB025F; Mon, 4 Oct 2010 15:38:43 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id A601CD9BB4; Mon, 4 Oct 2010 15:38:43 +0200 (CEST) Date: Mon, 4 Oct 2010 15:38:43 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Functions returning dispatching results Message-ID: <20101004133843.GA8862@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i 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 This patch disables a tag check for an assignment statement where the left hand side is an interface object. In this case the right hand side must only cover the interface and the tags of both sides do not need to be compared at run time. The following program should compile and execute silently. package Types is type Root_Iface is interface; function Create (Element : Integer) return Root_Iface is abstract; package Pkg is type Parent is abstract tagged null record; type Child is new Parent and Root_Iface with record Element : Integer; end record; function Create (Element : Integer) return Child; Default : constant Child := (Element => 0); end Pkg; end Types; package body Types is package body Pkg is function Create (Element : Integer) return Child is Result : Child := Child'(Element => Element); begin return Result; end Create; end Pkg; end Types; with Types; use Types; use Types.Pkg; procedure Main is My_Object : Root_Iface'Class := Default; begin My_Object := Types.Create (10); end Main; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-04 Hristian Kirtchev * exp_ch5.adb (Expand_N_Assignment_Statement): Do not generate a tag check when the target object is an interface since the expression of the right hand side must only cover the interface. Index: exp_ch5.adb =================================================================== --- exp_ch5.adb (revision 164906) +++ exp_ch5.adb (working copy) @@ -1956,6 +1956,12 @@ package body Exp_Ch5 is if Is_Class_Wide_Type (Typ) and then Is_Tagged_Type (Typ) and then Is_Tagged_Type (Underlying_Type (Etype (Rhs))) + + -- Do not generate a tag check when the target object is + -- an interface since the expression of the right hand + -- side must only cover the interface. + + and then not Is_Interface (Typ) then Append_To (L, Make_Raise_Constraint_Error (Loc,