If a field has Type_Only set to something other than No_Type_Only, then
we need to fetch the field from a possibly different node. For example,
the Modulus field has Type_Only = Base_Type_Only (and is documented as a
"[base type only]" field in Einfo). Therefore if we try to get Modulus
from node N, we must actually get it from Base_Type(N), not from N.
This was working correctly for the normal getters generated by Gen_IL.
However, when using Field_Descriptors to fetch fields (see package
Seinfo), the Type_Only aspect was ignored. This patch fixes that bug.
Treepr is the main place where Field_Descriptors are used to fetch
fields, so the effect of the bug was mainly to cause Treepr to print
wrong information.
Tested on x86_64-pc-linux-gnu, committed on trunk
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.
@@ -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;
@@ -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 --
-----------------------------
@@ -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);
@@ -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
@@ -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
@@ -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;