From patchwork Thu Jun 17 13:30:29 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 56046 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 13FFEB7D89 for ; Thu, 17 Jun 2010 23:30:27 +1000 (EST) Received: (qmail 24945 invoked by alias); 17 Jun 2010 13:30:25 -0000 Received: (qmail 24926 invoked by uid 22791); 17 Jun 2010 13:30:22 -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 13:30:14 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 15729CB02F7; Thu, 17 Jun 2010 15:30:20 +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 80AsxEW3xKAU; Thu, 17 Jun 2010 15:30:20 +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 E2EB5CB02CA; Thu, 17 Jun 2010 15:30:19 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id E60FED9AB0; Thu, 17 Jun 2010 15:30:29 +0200 (CEST) Date: Thu, 17 Jun 2010 15:30:29 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Inherited discriminants, extension aggregates, and allocators Message-ID: <20100617133029.GA23611@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 An extension aggregate is converted into a regular aggregate by collecting the inherited components and discriminants from ancestors and adding the components specified in the extension. If the type extension inherits discriminants from some ancestor, the corresponding values must be obtained before analyzing other components, in order to create the proper subtype for the aggregate. Thus the process of adding associations for those discriminants takes place during analysis even though it is properly an expansion activity. If the aggregate appears in a context that delays its expansion, such as an enclosing aggregate or an allocator, it is eventually reanalyzed and expanded. The re-analysis must not add again the values of inherited discriminants to prevent spurious semantic errors. The following must compile and execute quietly: --- with Ref1; use Ref1; procedure Try is It : Grand_Child; Ptr : Acc := Init (It); begin if Ptr.D /= 1234 then raise Program_Error; end if; end; --- package Ref1 is type Root (D : Integer) is tagged null record; type Child is new Root (1234) with null record; type Grand_Child is new Child with null record; type Acc is access all Grand_Child; function Init (X : Grand_Child) return Acc; end Ref1; --- package body Ref1 is function Init (X : Grand_Child) return Acc is Res : Acc := new Grand_Child'(Child (X) with null record); begin return Res; end Init; end Ref1; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-06-17 Ed Schonberg * sinfo.ads, sinfo.adb (Inherited_Discriminant): New flag on N_Component_Association nodes, to indicate that a component association of an extension aggregate denotes the value of a discriminant of an ancestor type that has been constrained by the derivation. * sem_aggr.adb (Discr_Present): use Inherited_Discriminant to prevent a double expansion of the aggregate appearing in a context that delays expansion, to prevent double insertion of discriminant values when the aggregate is reanalyzed. Index: sem_aggr.adb =================================================================== --- sem_aggr.adb (revision 160834) +++ sem_aggr.adb (working copy) @@ -2488,10 +2488,14 @@ package body Sem_Aggr is -- whose value may already have been specified by N's ancestor part. -- This routine checks whether this is indeed the case and if so returns -- False, signaling that no value for Discr should appear in N's - -- aggregate part. Also, in this case, the routine appends - -- New_Assoc_List Discr the discriminant value specified in the ancestor + -- aggregate part. Also, in this case, the routine appends to + -- New_Assoc_List the discriminant value specified in the ancestor -- part. - -- Can't parse previous sentence, appends what where??? + -- If the aggregate is in a context with expansion delayed, it will be + -- reanalyzed, The inherited discriminant values must not be reinserted + -- in the component list to prevent spurious errors, but it must be + -- present on first analysis to build the proper subtype indications. + -- The flag Inherited_Discriminant is used to prevent the re-insertion. function Get_Value (Compon : Node_Id; @@ -2556,6 +2560,7 @@ package body Sem_Aggr is Loc : Source_Ptr; Ancestor : Node_Id; + Comp_Assoc : Node_Id; Discr_Expr : Node_Id; Ancestor_Typ : Entity_Id; @@ -2570,6 +2575,20 @@ package body Sem_Aggr is return True; end if; + -- Check whether inherited discriminant values have already been + -- inserted in the aggregate. This will be the case if we are + -- re-analyzing an aggregate whose expansion was delayed. + + if Present (Component_Associations (N)) then + Comp_Assoc := First (Component_Associations (N)); + while Present (Comp_Assoc) loop + if Inherited_Discriminant (Comp_Assoc) then + return True; + end if; + Next (Comp_Assoc); + end loop; + end if; + Ancestor := Ancestor_Part (N); Ancestor_Typ := Etype (Ancestor); Loc := Sloc (Ancestor); @@ -2627,6 +2646,7 @@ package body Sem_Aggr is end if; Resolve_Aggr_Expr (Discr_Expr, Discr); + Set_Inherited_Discriminant (Last (New_Assoc_List)); return False; end if; Index: sinfo.adb =================================================================== --- sinfo.adb (revision 160834) +++ sinfo.adb (working copy) @@ -1572,6 +1572,14 @@ package body Sinfo is return Flag11 (N); end Includes_Infinities; + function Inherited_Discriminant + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Association); + return Flag13 (N); + end Inherited_Discriminant; + function Instance_Spec (N : Node_Id) return Node_Id is begin @@ -4466,6 +4474,14 @@ package body Sinfo is Set_Flag11 (N, Val); end Set_Includes_Infinities; + procedure Set_Inherited_Discriminant + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Association); + Set_Flag13 (N, Val); + end Set_Inherited_Discriminant; + procedure Set_Instance_Spec (N : Node_Id; Val : Node_Id) is begin Index: sinfo.ads =================================================================== --- sinfo.ads (revision 160834) +++ sinfo.ads (working copy) @@ -1180,6 +1180,12 @@ package Sinfo is -- range is given by the programmer, even if that range is identical to -- the range for Float. + -- Inherited_Discriminant (Flag13-Sem) + -- This flag is present in N_Component_Association nodes. It indicates + -- that a given component association in an extension aggregate is the + -- value obtained from a constraint on an ancestor. Used to prevent + -- double expansion when the aggregate has expansion delayed. + -- Instance_Spec (Node5-Sem) -- This field is present in generic instantiation nodes, and also in -- formal package declaration nodes (formal package declarations are @@ -3340,6 +3346,7 @@ package Sinfo is -- Loop_Actions (List2-Sem) -- Expression (Node3) -- Box_Present (Flag15) + -- Inherited_Discriminant (Flag13) -- Note: this structure is used for both record component associations -- and array component associations, since the two cases aren't always @@ -8117,6 +8124,9 @@ package Sinfo is function Includes_Infinities (N : Node_Id) return Boolean; -- Flag11 + function Inherited_Discriminant + (N : Node_Id) return Boolean; -- Flag13 + function Instance_Spec (N : Node_Id) return Node_Id; -- Node5 @@ -9041,6 +9051,9 @@ package Sinfo is procedure Set_Includes_Infinities (N : Node_Id; Val : Boolean := True); -- Flag11 + procedure Set_Inherited_Discriminant + (N : Node_Id; Val : Boolean := True); -- Flag13 + procedure Set_Instance_Spec (N : Node_Id; Val : Node_Id); -- Node5 @@ -11332,6 +11345,7 @@ package Sinfo is pragma Inline (Interface_Present); pragma Inline (Includes_Infinities); pragma Inline (In_Present); + pragma Inline (Inherited_Discriminant); pragma Inline (Instance_Spec); pragma Inline (Intval); pragma Inline (Is_Accessibility_Actual); @@ -11636,6 +11650,7 @@ package Sinfo is pragma Inline (Set_Interface_List); pragma Inline (Set_Interface_Present); pragma Inline (Set_In_Present); + pragma Inline (Set_Inherited_Discriminant); pragma Inline (Set_Instance_Spec); pragma Inline (Set_Intval); pragma Inline (Set_Is_Accessibility_Actual);