ada: Make pp and friends more robust (base type only)

Prior to this fix, if pp(N) tried to print a "base type only" field, and
Base_Type(N) was not yet set, it would raise an exception, which was
confusing. This patch makes it simply ignore such fields. Similarly
for Impl_Base_Type_Only and Root_Type_Only fields.

We do this by having alternative versions of Base_Type,
Implementation_Base_Type, and Root_Type that return Empty
in error cases, and call these alteratives from Treepr.
We don't want to Base_Type and friends to return Empty;
we want them to blow up when called from anywhere but
Treepr.

gcc/ada/ChangeLog:

	* atree.ads (Node_To_Fetch_From_If_Set): Alternative to
	Node_To_Fetch_From that returns Empty in error cases.
	For use only in Treepr.
	* treepr.adb (Print_Entity_Field): Avoid printing field
	if Node_To_Fetch_From_If_Set returns Empty.
	* einfo-utils.ads (Base_Type_If_Set): Alternative to
	Base_Type that returns Empty in error cases.
	(Implementation_Base_Type_If_Set): Likewise.
	(Root_Type_If_Set): Likewise.
	(Underlying_Type): Use more accurate result subtype.
	* einfo-utils.adb (Base_Type): Add Asserts.
	(Implementation_Base_Type): Add Assert; minor cleanup.
	(Root_Type): Add Assert; minor cleanup. Remove Assert that
	is redundant with predicate.
	(Base_Type_If_Set): Body of new function.
	(Implementation_Base_Type_If_Set): Body of new function.
	(Root_Type_If_Set): Body of new function.

diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads
index 802db870933839ae9643e3e90340b6bce8e9e4ad..f14491c2d75bdb36d540a44ab191629be3015eea 100644 (file)
--- a/gcc/ada/atree.ads
+++ b/gcc/ada/atree.ads
@@ -651,6 +651,20 @@ package Atree is
    --  similarly for the other two cases. This can return something other
    --  than N only if N is an Entity.
 
+   function Node_To_Fetch_From_If_Set
+     (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_If_Set (N),
+         when Impl_Base_Type_Only => Implementation_Base_Type_If_Set (N),
+         when Root_Type_Only => Root_Type_If_Set (N));
+   --  This is a more permissive version of Node_To_Fetch_From, which
+   --  returns the same value, except it returns Empty in cases where
+   --  Node_To_Fetch_From would crash because relevant fields are not yet
+   --  set. This is used in Treepr, to allow it to print half-baked nodes
+   --  without crashing.
+
    -----------------------------
    -- Private Part Subpackage --
    -----------------------------

diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb
index 417da6e828bc6ff326b94468a4103f4a8f1b4d85..d84e562853ccb699baa9d52eb982f011634fbfa8 100644 (file)
--- a/gcc/ada/einfo-utils.adb
+++ b/gcc/ada/einfo-utils.adb
@@ -669,6 +669,8 @@ package body Einfo.Utils is
             Result := Id;
          else
             pragma Assert (Is_Type (Id));
+            --  ...because Is_Base_Type returns True for nontypes
+
             Result := Etype (Id);
             if False then
                pragma Assert (Is_Base_Type (Result));
@@ -679,9 +681,29 @@ package body Einfo.Utils is
                --  expect.
             end if;
          end if;
+
+         --  pragma Assert (Result = Base_Type_If_Set (Id));
+         --  Disabled; too slow
       end return;
    end Base_Type;
 
+   ----------------------
+   -- Base_Type_If_Set --
+   ----------------------
+
+   function Base_Type_If_Set (Id : E) return Opt_N_Entity_Id is
+   begin
+      return Result : Opt_N_Entity_Id do
+         if Is_Base_Type (Id) then
+            Result := Id;
+         elsif Field_Is_Initial_Zero (Id, F_Etype) then
+            Result := Empty;
+         else
+            Result := Etype (Id);
+         end if;
+      end return;
+   end Base_Type_If_Set;
+
    ----------------------
    -- Declaration_Node --
    ----------------------
@@ -1374,30 +1396,43 @@ package body Einfo.Utils is
    ------------------------------
 
    function Implementation_Base_Type (Id : E) return E is
-      Bastyp : Entity_Id;
       Imptyp : Entity_Id;
-
    begin
-      Bastyp := Base_Type (Id);
-
-      if Is_Incomplete_Or_Private_Type (Bastyp) then
-         Imptyp := Underlying_Type (Bastyp);
+      return Result : E := Base_Type (Id) do
+         if Is_Incomplete_Or_Private_Type (Result) then
+            Imptyp := Underlying_Type (Result);
 
-         --  If we have an implementation type, then just return it,
-         --  otherwise we return the Base_Type anyway. This can only
-         --  happen in error situations and should avoid some error bombs.
+            --  If we have an implementation type, return its Base_Type.
 
-         if Present (Imptyp) then
-            return Base_Type (Imptyp);
-         else
-            return Bastyp;
+            if Present (Imptyp) then
+               Result := Base_Type (Imptyp);
+            end if;
          end if;
 
-      else
-         return Bastyp;
-      end if;
+         --  pragma Assert (Result = Implementation_Base_Type_If_Set (Id));
+         --  Disabled; too slow
+      end return;
    end Implementation_Base_Type;
 
+   -------------------------------------
+   -- Implementation_Base_Type_If_Set --
+   -------------------------------------
+
+   function Implementation_Base_Type_If_Set (Id : E) return Opt_N_Entity_Id is
+      Imptyp : Entity_Id;
+   begin
+      return Result : Opt_N_Entity_Id := Base_Type_If_Set (Id) do
+         if Present (Result) and then Is_Incomplete_Or_Private_Type (Result)
+         then
+            Imptyp := Underlying_Type (Result);
+
+            if Present (Imptyp) then
+               Result := Base_Type_If_Set (Imptyp);
+            end if;
+         end if;
+      end return;
+   end Implementation_Base_Type_If_Set;
+
    -------------------------
    -- Invariant_Procedure --
    -------------------------
@@ -2540,51 +2575,75 @@ package body Einfo.Utils is
    ---------------
 
    function Root_Type (Id : E) return E is
-      T, Etyp : Entity_Id;
+      Etyp : Entity_Id;
 
    begin
-      pragma Assert (Nkind (Id) in N_Entity);
+      return T : E := Base_Type (Id) do
+         if Ekind (T) = E_Class_Wide_Type then
+            T := Etype (T);
+         else
+            loop
+               Etyp := Etype (T);
 
-      T := Base_Type (Id);
+               exit when T = Etyp
+                 or else
+                   (Is_Private_Type (T) and then Etyp = Full_View (T))
+                 or else
+                   (Is_Private_Type (Etyp) and then Full_View (Etyp) = T);
 
-      if Ekind (T) = E_Class_Wide_Type then
-         return Etype (T);
+               T := Etyp;
 
-      --  Other cases
+               --  Quit if there is a circularity in the inheritance chain.
+               --  This happens in some error situations and we do not want
+               --  to get stuck in this loop.
 
-      else
-         loop
-            Etyp := Etype (T);
+               if T = Base_Type (Id) then
+                  Check_Error_Detected;
+                  exit;
+               end if;
+            end loop;
+         end if;
 
-            if T = Etyp then
-               return T;
+         --  pragma Assert (T = Root_Type_If_Set (Id));
+         --  Disabled; too slow
+      end return;
+   end Root_Type;
 
-            --  Following test catches some error cases resulting from
-            --  previous errors.
+   function Root_Type_If_Set (Id : E) return Opt_N_Entity_Id is
+      Etyp : Entity_Id;
 
-            elsif No (Etyp) then
-               Check_Error_Detected;
-               return T;
+   begin
+      return T : Opt_N_Entity_Id := Base_Type_If_Set (Id) do
+         if Ekind (T) = E_Class_Wide_Type then
+            T := Etype (T);
+         else
+            loop
+               Etyp := Etype (T);
 
-            elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
-               return T;
+               if No (Etyp) then
+                  T := Empty;
+                  exit;
+               end if;
 
-            elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
-               return T;
-            end if;
+               exit when T = Etyp
+                 or else
+                   (Is_Private_Type (T) and then Etyp = Full_View (T))
+                 or else
+                   (Is_Private_Type (Etyp) and then Full_View (Etyp) = T);
 
-            T := Etyp;
+               T := Etyp;
 
-            --  Return if there is a circularity in the inheritance chain. This
-            --  happens in some error situations and we do not want to get
-            --  stuck in this loop.
+               --  Quit if there is a circularity in the inheritance chain.
+               --  This happens in some error situations and we do not want
+               --  to get stuck in this loop.
 
-            if T = Base_Type (Id) then
-               return T;
-            end if;
-         end loop;
-      end if;
-   end Root_Type;
+               if T = Base_Type_If_Set (Id) then
+                  exit;
+               end if;
+            end loop;
+         end if;
+      end return;
+   end Root_Type_If_Set;
 
    ---------------------
    -- Safe_Emax_Value --
@@ -3010,7 +3069,7 @@ package body Einfo.Utils is
    -- Underlying_Type --
    ---------------------
 
-   function Underlying_Type (Id : E) return Entity_Id is
+   function Underlying_Type (Id : E) return Opt_N_Entity_Id is
    begin
       --  For record_with_private the underlying type is always the direct full
       --  view. Never try to take the full view of the parent it does not make

diff --git a/gcc/ada/einfo-utils.ads b/gcc/ada/einfo-utils.ads
index 78b49891f60955ab01dacb914329d566ddb88d45..27cf9e670f0e3527d77848a0b9c6cbe0caa54c4b 100644 (file)
--- a/gcc/ada/einfo-utils.ads
+++ b/gcc/ada/einfo-utils.ads
@@ -161,6 +161,15 @@ package Einfo.Utils is
    function First_Formal (Id : E) return Entity_Id;
    function First_Formal_With_Extras (Id : E) return Entity_Id;
 
+   function Base_Type_If_Set (Id : E) return Opt_N_Entity_Id;
+   function Implementation_Base_Type_If_Set (Id : E) return Opt_N_Entity_Id;
+   function Root_Type_If_Set (Id : E) return Opt_N_Entity_Id;
+   --  Base_Type_If_Set is a more permissive version of Base_Type, which
+   --  returns the same value, except it returns Empty in cases where Base_Type
+   --  would crash because relevant fields are not yet set. Likewise for the
+   --  other two. These are used in Treepr, to allow it to print half-baked
+   --  nodes without crashing.
+
    function Float_Rep
      (N : Entity_Id) return F with Inline, Pre =>
       N in E_Void_Id
@@ -238,7 +247,7 @@ package Einfo.Utils is
    function Stream_Size_Clause (Id : E) return N with Inline;
    function Type_High_Bound (Id : E) return N with Inline;
    function Type_Low_Bound (Id : E) return N with Inline;
-   function Underlying_Type (Id : E) return Entity_Id;
+   function Underlying_Type (Id : E) return Opt_N_Entity_Id;
 
    function Scope_Depth (Id : Scope_Kind_Id) return U with Inline;
    function Scope_Depth_Set (Id : Scope_Kind_Id) return B with Inline;

diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb
index 857b9263f01245d78cb8297c8c81b69a6fd380fa..fbad71a3765a1b1a2a6880d51b3c543240e75530 100644 (file)
--- a/gcc/ada/treepr.adb
+++ b/gcc/ada/treepr.adb
@@ -1047,9 +1047,11 @@ package body Treepr is
       FD     : Field_Descriptor;
       Format : UI_Format := Auto)
    is
-      NN : constant Node_Id := Node_To_Fetch_From (N, Field);
+      NN : constant Node_Id := Node_To_Fetch_From_If_Set (N, Field);
+      --  If NN is Empty, it means that we cannot compute the
+      --  Node_To_Fetch_From, so we simply skip this field.
    begin
-      if not Field_Is_Initial_Zero (N, Field) then
+      if Present (NN) and then not Field_Is_Initial_Zero (N, Field) then
          Print_Field (Prefix, Image (Field), NN, FD, Format);
       end if;
    end Print_Entity_Field;