From: Bob Duff Date: Wed, 20 Oct 2021 20:55:38 +0000 (-0400) Subject: [Ada] Fix bugs in Base_Type_Only (etc.) fields X-Git-Tag: basepoints/gcc-13~3629 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=034c3117520f33bc108afc930c16b220041e4a97;p=thirdparty%2Fgcc.git [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. --- diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 98614e89e968..88d766a2b29b 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 4861236b669b..c239507c93cf 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 eed98ee97cc8..f058c5a7f7ad 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 7b095c09692b..3febf7fc2227 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 79269a5972d4..33247e21ca74 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 d36042ca5797..aa06506bb19e 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;