[Ada] Enhance output of discriminants with -gnatR in JSON mode

This arranges for the Discriminant_Number of discriminants to be output
by -gnatR in JSON mode.  This number is referenced in symbolic expressions
present for offsets and sizes, so its definition is also required for the
sake of completeness.

2018-05-29  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

	* repinfo.ads (JSON format): Document new pair for components.
	* repinfo.adb (Derived_Discriminant): New function.
	(List_Structural_Record_Layout): Add Outer_Ent parameter and pass it
	in recursive calls. If the record type is the parent of an extension,
	find and list the derived discriminant from the extension, if any.
	(List_Component_Layout): List the Discriminant_Number in JSON mode.
	(List_Record_Info): Adjust call to List_Structural_Record_Layout.

From-SVN: r260869

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index cc6ae0e..21d1324 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,15 @@
 2018-05-29  Eric Botcazou  <ebotcazou@adacore.com>
 
+       * repinfo.ads (JSON format): Document new pair for components.
+       * repinfo.adb (Derived_Discriminant): New function.
+       (List_Structural_Record_Layout): Add Outer_Ent parameter and pass it
+       in recursive calls. If the record type is the parent of an extension,
+       find and list the derived discriminant from the extension, if any.
+       (List_Component_Layout): List the Discriminant_Number in JSON mode.
+       (List_Record_Info): Adjust call to List_Structural_Record_Layout.
+
+2018-05-29  Eric Botcazou  <ebotcazou@adacore.com>
+
        * doc/gnat_ugn/building_executable_programs_with_gnat.rst (Alphabetical
        List of All Switches): Document -gnatRj.
        (Debugging Control): Likewise.

diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb
index 83267c8..6c35423 100644 (file)
--- a/gcc/ada/repinfo.adb
+++ b/gcc/ada/repinfo.adb
@@ -207,8 +207,8 @@ package body Repinfo is
 
    function Back_End_Layout return Boolean is
    begin
-      --  We have back end layout if the back end has made any entries in the
-      --  table of GCC expressions, otherwise we have front end layout.
+      --  We have back-end layout if the back end has made any entries in the
+      --  table of GCC expressions, otherwise we have front-end layout.
 
       return Rep_Table.Last > 0;
    end Back_End_Layout;
@@ -1069,9 +1069,10 @@ package body Repinfo is
       --  Internal recursive procedure to display the layout
 
       procedure List_Structural_Record_Layout
-        (Ent     : Entity_Id;
-         Variant : Node_Id := Empty;
-         Indent  : Natural := 0);
+        (Ent       : Entity_Id;
+         Outer_Ent : Entity_Id;
+         Variant   : Node_Id := Empty;
+         Indent    : Natural := 0);
       --  Internal recursive procedure to display the structural layout
 
       Max_Name_Length : Natural := 0;
@@ -1205,6 +1206,12 @@ package body Repinfo is
             Write_Str (Prefix);
             Write_Str (Name_Buffer (1 .. Name_Len));
             Write_Line (""",");
+            if Ekind (Ent) = E_Discriminant then
+               Spaces (Indent);
+               Write_Str ("      ""discriminant"": ");
+               UI_Write (Discriminant_Number (Ent));
+               Write_Line (",");
+            end if;
             Spaces (Indent);
             Write_Str ("      ""Position"": ");
          else
@@ -1304,8 +1311,8 @@ package body Repinfo is
          else
             Write_Val (Esiz, Paren => not List_Representation_Info_To_JSON);
 
-            --  If in front end layout mode, then dynamic size is stored
-            --  in storage units, so renormalize for output
+            --  If in front-end layout mode, then dynamic size is stored
+            --  in storage units, so renormalize for output.
 
             if not Back_End_Layout then
                Write_Str (" * ");
@@ -1416,15 +1423,67 @@ package body Repinfo is
       -----------------------------------
 
       procedure List_Structural_Record_Layout
-        (Ent     : Entity_Id;
-         Variant : Node_Id := Empty;
-         Indent  : Natural := 0)
+        (Ent       : Entity_Id;
+         Outer_Ent : Entity_Id;
+         Variant   : Node_Id := Empty;
+         Indent    : Natural := 0)
       is
+
+         function Derived_Discriminant (Disc : Entity_Id) return Entity_Id;
+         --  This function assumes that Outer_Ent is an extension of Ent.
+         --  Disc is a discriminant of Ent that does not itself constrain a
+         --  discriminant of the parent type of Ent. Return the discriminant
+         --  of Outer_Ent that ultimately constrains Disc, if any.
+
+         ----------------------------
+         --  Derived_Discriminant  --
+         ----------------------------
+
+         function Derived_Discriminant (Disc : Entity_Id) return Entity_Id is
+            Corr_Disc, Derived_Disc : Entity_Id;
+
+         begin
+            Derived_Disc := First_Stored_Discriminant (Outer_Ent);
+
+            --  Loop over the discriminants of the extension
+
+            while Present (Derived_Disc) loop
+
+               --  Check if this discriminant constrains another discriminant.
+               --  If so, find the ultimately constrained discriminant and
+               --  compare with the original components in the base type.
+
+               if Present (Corresponding_Discriminant (Derived_Disc)) then
+                  Corr_Disc := Corresponding_Discriminant (Derived_Disc);
+
+                  while Present (Corresponding_Discriminant (Corr_Disc)) loop
+                     Corr_Disc := Corresponding_Discriminant (Corr_Disc);
+                  end loop;
+
+                  if Original_Record_Component (Corr_Disc)
+                                             = Original_Record_Component (Disc)
+                  then
+                     return Derived_Disc;
+                  end if;
+               end if;
+
+               Next_Stored_Discriminant (Derived_Disc);
+            end loop;
+
+            --  Disc is not constrained by a discriminant of Outer_Ent
+
+            return Empty;
+         end Derived_Discriminant;
+
+         --  Local declarations
+
          Comp       : Node_Id;
          Comp_List  : Node_Id;
          Var        : Node_Id;
          First      : Boolean := True;
 
+      --  Start of processing for List_Structural_Record_Layout
+
       begin
          --  If we are dealing with a variant, just process the components
 
@@ -1442,14 +1501,15 @@ package body Repinfo is
                  Is_Tagged_Type (Ent)
                    and then
                  Nkind (Definition) = N_Derived_Type_Definition;
-               Disc : Entity_Id;
+               Disc, Listed_Disc : Entity_Id;
+
             begin
                --  If this is an extension, first list the layout of the parent
                --  and then proceed to the extension part, if any.
 
                if Is_Extension then
                   List_Structural_Record_Layout
-                    (Base_Type (Parent_Subtype (Ent)), Variant, Indent);
+                    (Base_Type (Parent_Subtype (Ent)), Outer_Ent);
 
                   if Present (Record_Extension_Part (Definition)) then
                      Definition := Record_Extension_Part (Definition);
@@ -1474,7 +1534,20 @@ package body Repinfo is
                         goto Continue_Disc;
                      end if;
 
-                     Get_Decoded_Name_String (Chars (Disc));
+                     --  If this is the parent type of an extension, retrieve
+                     --  the derived discriminant from the extension, if any.
+
+                     if Ent /= Outer_Ent then
+                        Listed_Disc := Derived_Discriminant (Disc);
+
+                        if No (Listed_Disc) then
+                           goto Continue_Disc;
+                        end if;
+                     else
+                        Listed_Disc := Disc;
+                     end if;
+
+                     Get_Decoded_Name_String (Chars (Listed_Disc));
                      Set_Casing (Unit_Casing);
 
                      if First then
@@ -1484,7 +1557,7 @@ package body Repinfo is
                         Write_Line (",");
                      end if;
 
-                     List_Component_Layout (Disc, Indent => Indent);
+                     List_Component_Layout (Listed_Disc, Indent => Indent);
 
                   <<Continue_Disc>>
                      Next_Stored_Discriminant (Disc);
@@ -1564,7 +1637,7 @@ package body Repinfo is
             Spaces (Indent);
             Write_Str ("      ""record"": [");
 
-            List_Structural_Record_Layout (Ent, Var, Indent + 4);
+            List_Structural_Record_Layout (Ent, Outer_Ent, Var, Indent + 4);
 
             Write_Eol;
             Spaces (Indent);
@@ -1597,7 +1670,7 @@ package body Repinfo is
          Write_Line (",");
          Write_Str ("  ""record"": [");
 
-         List_Structural_Record_Layout (Ent);
+         List_Structural_Record_Layout (Ent, Ent);
 
          Write_Eol;
          Write_Str ("  ]");

diff --git a/gcc/ada/repinfo.ads b/gcc/ada/repinfo.ads
index 477ac0e..79f93f9 100644 (file)
--- a/gcc/ada/repinfo.ads
+++ b/gcc/ada/repinfo.ads
@@ -231,15 +231,19 @@ package Repinfo is
    --  A component is an object whose members are pairs taken from:
 
    --    "name"                 :  string
+   --    "discriminant"         :  number
    --    "Position"             :  numerical expression
    --    "First_Bit"            :  number
    --    "Size"                 :  numerical expression
 
-   --    The four pairs are present for every component. "name" comes from the
-   --    declaration of the component in the record type and its value is the
-   --    unqualified Ada name. The other three pairs come from the layout of
-   --    the type and their value is that of the eponymous attribute set by
-   --    the language.
+   --    "name" is present for every component and comes from the declaration
+   --    of the type; its value is the unqualified Ada name. "discriminant" is
+   --    present only if the component is a discriminant, and its value is the
+   --    ranking of the discriminant in the list of discriminants of the type,
+   --    i.e. an integer index ranging from 1 to the number of discriminants.
+   --    The other three pairs are present for every component and come from
+   --    the layout of the type; their value is the value of the eponymous
+   --    attribute set by the language.
 
    --  A variant is an object whose members are pairs taken from: