From patchwork Mon Jun 14 15:05:04 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 55545 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 04C6BB7D1C for ; Tue, 15 Jun 2010 01:05:04 +1000 (EST) Received: (qmail 3314 invoked by alias); 14 Jun 2010 15:05:02 -0000 Received: (qmail 3295 invoked by uid 22791); 14 Jun 2010 15:05:00 -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, 14 Jun 2010 15:04:54 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 9E72DCB0241; Mon, 14 Jun 2010 17:04:55 +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 8xRW6VA7LrUf; Mon, 14 Jun 2010 17:04:55 +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 87C17CB01EF; Mon, 14 Jun 2010 17:04:55 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 0AD7ED9B31; Mon, 14 Jun 2010 17:05:04 +0200 (CEST) Date: Mon, 14 Jun 2010 17:05:04 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Extensions of constrained discriminated with other progenitors Message-ID: <20100614150504.GA7590@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 it. If the derived type declaration includes an interface list, it is attached to the anonymous base type. However, the extension may contain current instances of the source type, whose subtype declaration has not been elaborated yet. The interface list must be linked to the source type as soon as constructed for the base. The presence of the anonymous base type must also be taken into account when building the interface thunks for overridden interface operations: the overriding operation is declared on the subtype, but the inherited primitive has the signature of the anonymous base. The following must compile and execute quietly: --- with Ref; use Ref; procedure Proc is Obj :Grand_Child; begin Dispatch (I'Class (Obj)); end; --- package Ref is type I is interface; procedure Check (Obj : I) is null; procedure Dispatch (Obj : I'class); 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 X : C := (V => Grand_Child'Unrestricted_Access); end record; procedure Check (Obj : Grand_Child); end Ref; --- package body Ref is procedure Dispatch (Obj : I'class) is begin Check (Obj); end; procedure Check (Obj : Grand_Child) is begin if Obj.X.V /= Obj'Unrestricted_Access then raise Program_Error; end if; end; end Ref; --- Tested on x86_64-pc-linux-gnu, committed on trunk 2010-06-14 Ed Schonberg * sem_ch3.adb (Build_Derived_Record_Type): if derived type is an anonymous base generated when the parent is a constrained discriminated type, propagate interface list to first subtype because it may appear in a current instance within the extension part of the derived type declaration, and its own subtype declaration has not been elaborated yet. * exp_disp.adb (Build_Interface_Thunk): Use base type of formal to determine whether it has the controlling type. Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 160731) +++ sem_ch3.adb (working copy) @@ -3750,10 +3750,10 @@ if Present (Generic_Parent_Type (N)) and then (Nkind - (Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration + (Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration or else Nkind (Formal_Type_Definition (Parent (Generic_Parent_Type (N)))) - /= N_Formal_Private_Type_Definition) + /= N_Formal_Private_Type_Definition) then if Is_Tagged_Type (Id) then @@ -7356,6 +7356,27 @@ Exclude_Parents => True); Set_Interfaces (Derived_Type, Ifaces_List); + + -- If the derived type is the anonymous type created for + -- a declaration whose parent has a constraint, propagate + -- the interface list to the source type. This must be done + -- prior to the completion of the analysis of the source type + -- because the components in the extension may contain current + -- instances whose legality depends on some ancestor. + + if Is_Itype (Derived_Type) then + declare + Def : constant Node_Id := + Associated_Node_For_Itype (Derived_Type); + begin + if Present (Def) + and then Nkind (Def) = N_Full_Type_Declaration + then + Set_Interfaces + (Defining_Identifier (Def), Ifaces_List); + end if; + end; + end if; end; end if; Index: exp_disp.adb =================================================================== --- exp_disp.adb (revision 160705) +++ exp_disp.adb (working copy) @@ -1528,14 +1528,19 @@ Formal := First (Formals); while Present (Formal) loop - -- Handle concurrent types + -- Handle concurrent types. 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)); else - Ftyp := Etype (Target_Formal); + + -- if the parent is a constrained discriminated type. 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; if Is_Concurrent_Type (Ftyp) then