Patchwork [Ada] Inherited discriminants, extension aggregates, and allocators

login
register
mail settings
Submitter Arnaud Charlet
Date June 17, 2010, 1:30 p.m.
Message ID <20100617133029.GA23611@adacore.com>
Download mbox | patch
Permalink /patch/56046/
State New
Headers show

Comments

Arnaud Charlet - June 17, 2010, 1:30 p.m.
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  <schonberg@adacore.com>

	* 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.

Patch

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);