sem_util.adb (Build_Actual_Subtype): Record original expression in Related_Expression attribute of the constructed...

2010-06-22  Thomas Quinot  <quinot@adacore.com>

	* sem_util.adb (Build_Actual_Subtype): Record original expression in
	Related_Expression attribute of the constructed subtype.
	* einfo.adb, einfo.ads (Underlying_View): Move to Node28 to free up
	Node24 on types for...
	(Related_Expression): Make attribute available on types as well.

From-SVN: r161138

4 files changed, 42 insertions, 21 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index a1621e1..76c3f15 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,11 @@
+2010-06-22  Thomas Quinot  <quinot@adacore.com>
+
+	* sem_util.adb (Build_Actual_Subtype): Record original expression in
+	Related_Expression attribute of the constructed subtype.
+	* einfo.adb, einfo.ads (Underlying_View): Move to Node28 to free up
+	Node24 on types for...
+	(Related_Expression): Make attribute available on types as well.
+
 2010-06-22  Gary Dismukes  <dismukes@adacore.com>
 
 	* exp_util.adb (Find_Interface_ADT): Retrieve Designated_Type instead of
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 0058231..8686a87 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -208,7 +208,6 @@ package body Einfo is
 
    --    Related_Expression              Node24
    --    Spec_PPC_List                   Node24
-   --    Underlying_Record_View          Node24
 
    --    Interface_Alias                 Node25
    --    Interfaces                      Elist25
@@ -228,6 +227,7 @@ package body Einfo is
    --    Wrapped_Entity                  Node27
 
    --    Extra_Formals                   Node28
+   --    Underlying_Record_View          Node28
 
    ---------------------------------------------
    -- Usage of Flags in Defining Entity Nodes --
@@ -2434,7 +2434,8 @@ package body Einfo is
 
    function Related_Expression (Id : E) return N is
    begin
-      pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
+      pragma Assert (Is_Type (Id)
+                       or else Ekind_In (Id, E_Constant, E_Variable));
       return Node24 (Id);
    end Related_Expression;
 
@@ -2656,7 +2657,7 @@ package body Einfo is
 
    function Underlying_Record_View (Id : E) return E is
    begin
-      return Node24 (Id);
+      return Node28 (Id);
    end Underlying_Record_View;
 
    function Universal_Aliasing (Id : E) return B is
@@ -2938,6 +2939,12 @@ package body Einfo is
    -- Attribute Set Procedures --
    ------------------------------
 
+   --  Note: in many of these set procedures an "obvious" assertion is missing.
+   --  The reason for this is that in many cases, a field is set before the
+   --  Ekind field is set, so that the field is set when Ekind = E_Void. It
+   --  it is possible to add assertions that specifically include the E_Void
+   --  possibility, but in some cases, we just omit the assertions.
+
    procedure Set_Accept_Address (Id : E; V : L) is
    begin
       Set_Elist21 (Id, V);
@@ -5114,7 +5121,7 @@ package body Einfo is
    procedure Set_Underlying_Record_View (Id : E; V : E) is
    begin
       pragma Assert (Ekind (Id) = E_Record_Type);
-      Set_Node24 (Id, V);
+      Set_Node28 (Id, V);
    end Set_Underlying_Record_View;
 
    procedure Set_Universal_Aliasing (Id : E; V : B := True) is
@@ -7894,14 +7901,11 @@ package body Einfo is
          when Subprogram_Kind                              =>
             Write_Str ("Spec_PPC_List");
 
-         when E_Record_Type                                =>
-            Write_Str ("Underlying_Record_View");
-
-         when E_Variable | E_Constant                      =>
+         when E_Variable | E_Constant | Type_Kind          =>
             Write_Str ("Related_Expression");
 
          when others                                       =>
-            Write_Str ("???");
+            Write_Str ("Field24???");
       end case;
    end Write_Field24_Name;
 
@@ -8005,6 +8009,9 @@ package body Einfo is
          when E_Procedure | E_Function | E_Entry           =>
             Write_Str ("Extra_Formals");
 
+         when E_Record_Type =>
+            Write_Str ("Underlying_Record_View");
+
          when others                                       =>
             Write_Str ("Field28??");
       end case;
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 27c0b66e..3eb3528 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -3244,9 +3244,13 @@ package Einfo is
 --       only for type-related error messages.
 
 --    Related_Expression (Node24)
---       Present in variables generated internally. Denotes the source
---       expression whose elaboration created the variable declaration.
---       Used for clearer messages from CodePeer.
+--       Present in variables and types. Set only for internally generated
+--       entities, where it may be used to denote the source expression whose
+--       elaboration created the variable declaration. If set, it is used
+--       for generating clearer messages from CodePeer.
+--
+--       Shouldn't it also be used for the same purpose in errout? It seems
+--       odd to have two mechanisms here???
 
 --    Related_Instance (Node15)
 --       Present in the wrapper packages created for subprogram instances.
@@ -3539,12 +3543,13 @@ package Einfo is
 --       value may be passed around, and if used, may clobber a local variable.
 
 --    Task_Body_Procedure (Node25)
---       Present in task types and subtypes. Points to the entity for
---       the task body procedure (as further described in Exp_Ch9, task
---       bodies are expanded into procedures). A convenient function to
---       retrieve this field is Sem_Util.Get_Task_Body_Procedure.
---       The last sentence is odd ??? Why not have Task_Body_Procedure
---       go to the Underlying_Type of the Root_Type???
+--       Present in task types and subtypes. Points to the entity for the task
+--       task body procedure (as further described in Exp_Ch9, task bodies are
+--       expanded into procedures). A convenient function to retrieve this
+--       field is Sem_Util.Get_Task_Body_Procedure.
+--
+--       The last sentence is odd??? Why not have Task_Body_Procedure go to the
+--       Underlying_Type of the Root_Type???
 
 --    Treat_As_Volatile (Flag41)
 --       Present in all type entities, and also in constants, components and
@@ -3591,7 +3596,7 @@ package Einfo is
 --       private completion. If Td is already constrained, then its full view
 --       can serve directly as the full view of T.
 
---    Underlying_Record_View (Node24)
+--    Underlying_Record_View (Node28)
 --       Present in record types. Set for record types that are extensions of
 --       types with unknown discriminants, and also set for internally built
 --       underlying record views to reference its original record type. Record
@@ -4599,6 +4604,7 @@ package Einfo is
    --    Esize                               (Uint12)
    --    RM_Size                             (Uint13)
    --    Alignment                           (Uint14)
+   --    Related_Expression                  (Node24)
 
    --    Depends_On_Private                  (Flag14)
    --    Discard_Names                       (Flag88)
@@ -5290,8 +5296,8 @@ package Einfo is
    --    Discriminant_Constraint             (Elist21)
    --    Corresponding_Remote_Type           (Node22)
    --    Stored_Constraint                   (Elist23)
-   --    Underlying_Record_View              (Node24)   (base type only)
    --    Interfaces                          (Elist25)
+   --    Underlying_Record_View              (Node28)   (base type only)
    --    Component_Alignment                 (special)  (base type only)
    --    C_Pass_By_Copy                      (Flag125)  (base type only)
    --    Has_Dispatch_Table                  (Flag220)  (base tagged type only)
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 04f8341..df56bc5 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -398,7 +398,7 @@ package body Sem_Util is
          end loop;
       end if;
 
-      Subt := Make_Temporary (Loc, 'S');
+      Subt := Make_Temporary (Loc, 'S', Related_Node => N);
       Set_Is_Internal (Subt);
 
       Decl :=