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.

diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
index 327bc2d7093677de8b188b741c9a5c5e7776b80a..a13438a2132eddbb50305b5393923d784eaf2187 100644 (file)
--- 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 b0acb25b40bc88250084bc875fade126e700b73c..6d10a7fc4a89cfa76a4d6881e211972bc4b0b5a1 100644 (file)
--- 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));