[Ada] Fix bugs in Base_Type_Only (etc.) fields

gcc/ada/

	* gen_il-gen.adb (Put_Seinfo): Generate type
	Seinfo.Type_Only_Enum based on type
	Gen_IL.Internals.Type_Only_Enum. Automatically generating a copy
	of the type will help keep them in sync.  (Note that there are
	no Ada compiler packages imported into Gen_IL.)  Add a Type_Only
	field to Field_Descriptor, so this information is available in
	the Ada compiler (as opposed to just in the Gen_IL "compiler").
	(One_Comp): Add initialization of the Type_Only field of
	Field_Descriptor.
	* gen_il-internals.ads (Image): Image function for
	Type_Only_Enum.
	* atree.ads (Node_To_Fetch_From): New function to compute which
	node to fetch from, based on the Type_Only aspect.
	* atree.adb (Get_Field_Value): Call Node_To_Fetch_From.
	* treepr.adb (Print_Entity_Field): Call Node_To_Fetch_From.
	(Print_Node_Field): Assert.
	* sinfo-utils.adb (Walk_Sinfo_Fields,
	Walk_Sinfo_Fields_Pairwise): Asserts.

6 files changed, 56 insertions, 7 deletions

diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
index 98614e8..88d766a 100644
--- a/gcc/ada/atree.adb
+++ b/gcc/ada/atree.adb
@@ -854,14 +854,15 @@ package body Atree is
      (N : Node_Id; Field : Node_Or_Entity_Field) return Field_Size_32_Bit
    is
       Desc : Field_Descriptor renames Field_Descriptors (Field);
+      NN : constant Node_Or_Entity_Id := Node_To_Fetch_From (N, Field);
 
    begin
       case Field_Size (Desc.Kind) is
-         when 1 => return Field_Size_32_Bit (Get_1_Bit_Val (N, Desc.Offset));
-         when 2 => return Field_Size_32_Bit (Get_2_Bit_Val (N, Desc.Offset));
-         when 4 => return Field_Size_32_Bit (Get_4_Bit_Val (N, Desc.Offset));
-         when 8 => return Field_Size_32_Bit (Get_8_Bit_Val (N, Desc.Offset));
-         when others => return Get_32_Bit_Val (N, Desc.Offset);  -- 32
+         when 1 => return Field_Size_32_Bit (Get_1_Bit_Val (NN, Desc.Offset));
+         when 2 => return Field_Size_32_Bit (Get_2_Bit_Val (NN, Desc.Offset));
+         when 4 => return Field_Size_32_Bit (Get_4_Bit_Val (NN, Desc.Offset));
+         when 8 => return Field_Size_32_Bit (Get_8_Bit_Val (NN, Desc.Offset));
+         when others => return Get_32_Bit_Val (NN, Desc.Offset);  -- 32
       end case;
    end Get_Field_Value;
 
diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads
index 4861236..c239507 100644
--- a/gcc/ada/atree.ads
+++ b/gcc/ada/atree.ads
@@ -47,6 +47,7 @@
 with Alloc;
 with Sinfo.Nodes;    use Sinfo.Nodes;
 with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils;    use Einfo.Utils;
 with Types;          use Types;
 with Seinfo;         use Seinfo;
 with System;         use System;
@@ -616,6 +617,20 @@ package Atree is
    --  always the same; for example we change from E_Void, to E_Variable, to
    --  E_Void, to E_Constant.
 
+   function Node_To_Fetch_From
+     (N : Node_Or_Entity_Id; Field : Node_Or_Entity_Field)
+     return Node_Or_Entity_Id is
+      (case Field_Descriptors (Field).Type_Only is
+         when No_Type_Only => N,
+         when Base_Type_Only => Base_Type (N),
+         when Impl_Base_Type_Only => Implementation_Base_Type (N),
+         when Root_Type_Only => Root_Type (N));
+   --  This is analogous to the same-named function in Gen_IL.Gen. Normally,
+   --  Type_Only is No_Type_Only, and we fetch the field from the node N. But
+   --  if Type_Only = Base_Type_Only, we need to go to the Base_Type, and
+   --  similarly for the other two cases. This can return something other
+   --  than N only if N is an Entity.
+
    -----------------------------
    -- Private Part Subpackage --
    -----------------------------
diff --git a/gcc/ada/gen_il-gen.adb b/gcc/ada/gen_il-gen.adb
index eed98ee..f058c5a 100644
--- a/gcc/ada/gen_il-gen.adb
+++ b/gcc/ada/gen_il-gen.adb
@@ -2157,7 +2157,8 @@ package body Gen_IL.Gen is
 
                   Put (S, F_Image (F) & " => (" &
                        Image (Field_Table (F).Field_Type) & "_Field, " &
-                       Image (Offset) & ")");
+                       Image (Offset) & ", " &
+                       Image (Field_Table (F).Type_Only) & ")");
 
                   FS := Field_Size (F);
                   FB := First_Bit (F, Offset);
@@ -2252,10 +2253,32 @@ package body Gen_IL.Gen is
          Decrease_Indent (S, 2);
          Put (S, ");" & LF & LF);
 
+         Put (S, "type Type_Only_Enum is" & LF);
+         Increase_Indent (S, 2);
+         Put (S, "(");
+
+         declare
+            First_Time : Boolean := True;
+         begin
+            for TO in Type_Only_Enum loop
+               if First_Time then
+                  First_Time := False;
+               else
+                  Put (S, ", ");
+               end if;
+
+               Put (S, Image (TO));
+            end loop;
+         end;
+
+         Decrease_Indent (S, 2);
+         Put (S, ");" & LF & LF);
+
          Put (S, "type Field_Descriptor is record" & LF);
          Increase_Indent (S, 3);
          Put (S, "Kind : Field_Kind;" & LF);
          Put (S, "Offset : Field_Offset;" & LF);
+         Put (S, "Type_Only : Type_Only_Enum;" & LF);
          Decrease_Indent (S, 3);
          Put (S, "end record;" & LF & LF);
 
diff --git a/gcc/ada/gen_il-internals.ads b/gcc/ada/gen_il-internals.ads
index 7b095c0..3febf7f 100644
--- a/gcc/ada/gen_il-internals.ads
+++ b/gcc/ada/gen_il-internals.ads
@@ -147,6 +147,9 @@ package Gen_IL.Internals is
    --  The default is No_Type_Only, indicating the field is not one of
    --  these special "[... only]" ones.
 
+   function Image (Type_Only : Type_Only_Enum) return String is
+     (Capitalize (Type_Only'Img));
+
    Unknown_Offset : constant := -1;
    --  Initial value of Offset, so we can tell whether it has been set
 
diff --git a/gcc/ada/sinfo-utils.adb b/gcc/ada/sinfo-utils.adb
index 79269a5..33247e2 100644
--- a/gcc/ada/sinfo-utils.adb
+++ b/gcc/ada/sinfo-utils.adb
@@ -279,6 +279,8 @@ package body Sinfo.Utils is
             declare
                Desc : Field_Descriptor renames
                  Field_Descriptors (Fields (J));
+               pragma Assert (Desc.Type_Only = No_Type_Only);
+               --  Type_Only is for entities
             begin
                if Is_In_Union_Id (Desc.Kind) then
                   Action (Get_Node_Field_Union (N, Desc.Offset));
@@ -304,6 +306,8 @@ package body Sinfo.Utils is
             declare
                Desc : Field_Descriptor renames
                  Field_Descriptors (Fields (J));
+               pragma Assert (Desc.Type_Only = No_Type_Only);
+               --  Type_Only is for entities
             begin
                if Is_In_Union_Id (Desc.Kind) then
                   Set_Node_Field_Union
diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb
index d36042c..aa06506 100644
--- a/gcc/ada/treepr.adb
+++ b/gcc/ada/treepr.adb
@@ -1024,6 +1024,8 @@ package body Treepr is
       FD     : Field_Descriptor;
       Format : UI_Format := Auto)
    is
+      pragma Assert (FD.Type_Only = No_Type_Only);
+      --  Type_Only is for entities
    begin
       if not Field_Is_Initial_Zero (N, Field) then
          Print_Field (Prefix, Image (Field), N, FD, Format);
@@ -1041,9 +1043,10 @@ package body Treepr is
       FD     : Field_Descriptor;
       Format : UI_Format := Auto)
    is
+      NN : constant Node_Id := Node_To_Fetch_From (N, Field);
    begin
       if not Field_Is_Initial_Zero (N, Field) then
-         Print_Field (Prefix, Image (Field), N, FD, Format);
+         Print_Field (Prefix, Image (Field), NN, FD, Format);
       end if;
    end Print_Entity_Field;