From patchwork Thu Jun 17 12:26:54 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 56030 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 E261F1007D2 for ; Thu, 17 Jun 2010 22:26:55 +1000 (EST) Received: (qmail 5624 invoked by alias); 17 Jun 2010 12:26:50 -0000 Received: (qmail 5411 invoked by uid 22791); 17 Jun 2010 12:26:47 -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; Thu, 17 Jun 2010 12:26:38 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 2315BCB02AA; Thu, 17 Jun 2010 14:26:44 +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 d3FMBKw5J1Rh; Thu, 17 Jun 2010 14:26:44 +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 10603CB02A7; Thu, 17 Jun 2010 14:26:44 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 1889CD9AB0; Thu, 17 Jun 2010 14:26:54 +0200 (CEST) Date: Thu, 17 Jun 2010 14:26:54 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Interface operations with access formal in constrained extension Message-ID: <20100617122654.GA9182@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 If the parent type in a type extension is a discriminated type with constraints, the compiler creates an anonymous base type for it, and makes the source type into a subtype of this base. If an overridden operation of a progenitor of the type extension has an access parameter, the interface thunk for the overriding operation must use this anonymous base type in the constructed call to the overriding subprogram, to avois spurious type errors. The following must compile and execute quietly: --- package Ref is type I is interface; procedure P (V : access I) is abstract; type C is record V : access I'Class; end record; type Root (V : Integer) is tagged null record; type Child is new Root (1) with null record; type Grand_Child is new Child and I with record null; end record; procedure P (V : access Grand_Child); end Ref; --- package body Ref is procedure P (V : access Grand_Child) is begin null; end; end Ref; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-06-17 Ed Schonberg * exp_disp.adb (Build_Interface_Thunk): Use base type of formal to determine whether it has the controlling type, when the formal is an access parameter. Index: exp_disp.adb =================================================================== --- exp_disp.adb (revision 160895) +++ exp_disp.adb (working copy) @@ -1533,20 +1533,22 @@ package body Exp_Disp is Formal := First (Formals); while Present (Formal) loop - -- Handle concurrent types + -- If the parent is a constrained discriminated type, then the + -- primitive operation will have been defined on a first subtype. + -- For proper matching with controlling type, use base type. if Ekind (Target_Formal) = E_In_Parameter and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type then - Ftyp := Directly_Designated_Type (Etype (Target_Formal)); + Ftyp := + Base_Type (Directly_Designated_Type (Etype (Target_Formal))); else - -- If the parent is a constrained discriminated type, then the - -- primitive operation will have been defined on a first subtype. - -- For proper matching with controlling type, use base type. - Ftyp := Base_Type (Etype (Target_Formal)); end if; + -- For concurrent types, the relevant info is on the corresponding_ + -- record type. + if Is_Concurrent_Type (Ftyp) then Ftyp := Corresponding_Record_Type (Ftyp); end if;