From 966d132b0a59d2285e5546243907f4eec81e2dce Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Tue, 7 Oct 2025 10:45:20 -0400 Subject: [PATCH] ada: Remove exception handler in Check_Vanishing_Fields Check_Vanishing_Fields calls Same_Node_To_Fetch_From, which was calling Node_To_Fetch_From, which will raise an exception (as it should) on ..._Type_Only fields if called early (when the Base_Type, Implementation_Base_Type, or Root_Type has not yet been set). Other exceptions can also be raised when Check_Vanishing_Fields is called early. An exception handler was used to ignore any such exceptions. That was correct, but it is annoying in gdb with "catch exception". (Note that efficiency doesn't matter much, because Check_Vanishing_Fields is not done in production mode.) We now call Node_To_Fetch_From_If_Set, remove other potential raises, and remove the now-unnecessary exception handler. Note that other calls to Node_To_Fetch_From will still raise an exception (as they should) for such "early" calls. gcc/ada/ChangeLog: * atree.adb (Same_Node_To_Fetch_From): Use Node_To_Fetch_From_If_Set, and remove handler. * einfo-utils.adb (Root_Type_If_Set): Return Empty if Base_Type_If_Set returns Empty. Return Empty if we find Etype (T) = Empty. (Underlying_Type): Use "Has_Non_Limited_View..." instead of "Present (Non_Limited_View...)", because the latter raises an exception when given the wrong Ekind. --- gcc/ada/atree.adb | 82 ++++++++++++++++++----------------------- gcc/ada/einfo-utils.adb | 15 ++++++-- 2 files changed, 46 insertions(+), 51 deletions(-) diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 327bc2d7093..a13438a2132 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -1005,61 +1005,49 @@ package body Atree is Old_Kind : constant Entity_Kind := Ekind (Old_N); - function Same_Node_To_Fetch_From - (N : Node_Or_Entity_Id; Field : Node_Or_Entity_Field) - return Boolean; - -- True if the field should be fetched from N. For most fields, this is - -- true. However, if the field is a "root type only" field, then this is - -- true only if N is the root type. If this is false, then we should not - -- do Reinit_Field_To_Zero, and we should not fail below, because the - -- field is not vanishing from the root type. Similar comments apply to - -- "base type only" and "implementation base type only" fields. - -- - -- We need to ignore exceptions here, because in some cases, - -- Node_To_Fetch_From is being called before the relevant (root, base) - -- type has been set, so we fail some assertions. - - function Same_Node_To_Fetch_From - (N : Node_Or_Entity_Id; Field : Node_Or_Entity_Field) - return Boolean is - begin - return N = Node_To_Fetch_From (N, Field); - exception - when others => return False; -- ignore the exception - end Same_Node_To_Fetch_From; - -- Start of processing for Check_Vanishing_Fields begin for J in Entity_Field_Table (Old_Kind)'Range loop declare F : constant Entity_Field := Entity_Field_Table (Old_Kind) (J); - begin - if not Same_Node_To_Fetch_From (Old_N, F) then - null; -- no check in this case - elsif not Field_Checking.Field_Present (New_Kind, F) then - if not Field_Is_Initial_Zero (Old_N, F) then - Write_Str ("# "); - Write_Str (Osint.Get_First_Main_File_Name); - Write_Str (": "); - Write_Str (Old_Kind'Img); - Write_Str (" --> "); - Write_Str (New_Kind'Img); - Write_Str (" Nonzero field "); - Write_Str (F'Img); - Write_Str (" is vanishing "); - - if New_Kind = E_Void or else Old_Kind = E_Void then - Write_Line ("(E_Void case)"); - else - Write_Line ("(non-E_Void case)"); - end if; + Same_Node_To_Fetch_From : constant Boolean := + Old_N = Node_To_Fetch_From_If_Set (Old_N, F); + -- True if the field F should be fetched from Old_N. For most + -- fields, this is True. However, if F is a "root type only" + -- field, then it should be fetched from the root type, so this is + -- true only if Old_N is the root type. If this is False, then we + -- should not have done Reinit_Field_To_Zero, and we should not + -- fail below, because the field is not vanishing from this node. + -- We use the ..._If_Set function to avoid failing when the root + -- type has not yet been set. Similar comments apply to "base type + -- only" and "implementation base type only" fields. - Write_Str (" ...mutating node "); - Write_Int (Nat (Old_N)); - Write_Line (""); - raise Program_Error; + begin + if Same_Node_To_Fetch_From + and then not Field_Checking.Field_Present (New_Kind, F) + and then not Field_Is_Initial_Zero (Old_N, F) + then + Write_Str ("# "); + Write_Str (Osint.Get_First_Main_File_Name); + Write_Str (": "); + Write_Str (Old_Kind'Img); + Write_Str (" --> "); + Write_Str (New_Kind'Img); + Write_Str (" Nonzero field "); + Write_Str (F'Img); + Write_Str (" is vanishing "); + + if New_Kind = E_Void or else Old_Kind = E_Void then + Write_Line ("(E_Void case)"); + else + Write_Line ("(non-E_Void case)"); end if; + + Write_Str (" ...mutating node "); + Write_Int (Nat (Old_N)); + Write_Line (""); + raise Program_Error; end if; end; end loop; diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb index b0acb25b40b..6d10a7fc4a8 100644 --- a/gcc/ada/einfo-utils.adb +++ b/gcc/ada/einfo-utils.adb @@ -2622,13 +2622,20 @@ package body Einfo.Utils is begin return T : Opt_N_Entity_Id := Base_Type_If_Set (Id) do - if Ekind (T) = E_Class_Wide_Type then + if No (T) then + null; + elsif Ekind (T) = E_Class_Wide_Type then T := Etype (T); else loop Etyp := Etype (T); - exit when No (Etyp) or else T = Etyp + if No (Etyp) then + T := Empty; + exit; + end if; + + exit when T = Etyp or else (Is_Private_Type (T) and then Etyp = Full_View (T)) or else @@ -3086,7 +3093,7 @@ package body Einfo.Utils is elsif Ekind (Id) = E_Class_Wide_Type and then From_Limited_With (Id) - and then Present (Non_Limited_View (Id)) + and then Has_Non_Limited_View (Id) then return Underlying_Type (Non_Limited_View (Id)); @@ -3118,7 +3125,7 @@ package body Einfo.Utils is -- then we return the Underlying_Type of its nonlimited view. elsif From_Limited_With (Id) - and then Present (Non_Limited_View (Id)) + and then Has_Non_Limited_View (Id) then return Underlying_Type (Non_Limited_View (Id)); -- 2.47.3