From: Bob Duff <d...@adacore.com>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/atree.ads | 14 ++++
gcc/ada/einfo-utils.adb | 167 +++++++++++++++++++++++++++-------------
gcc/ada/einfo-utils.ads | 11 ++-
gcc/ada/treepr.adb | 6 +-
4 files changed, 141 insertions(+), 57 deletions(-)
diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads
index 802db8709338..f14491c2d75b 100644
--- 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 417da6e828bc..d84e562853cc 100644
--- 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);
+ return Result : E := Base_Type (Id) do
+ if Is_Incomplete_Or_Private_Type (Result) then
+ Imptyp := Underlying_Type (Result);
- if Is_Incomplete_Or_Private_Type (Bastyp) then
- Imptyp := Underlying_Type (Bastyp);
+ -- If we have an implementation type, return its Base_Type.
- -- 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 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,52 +2575,76 @@ 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;
-
- -- Following test catches some error cases resulting from
- -- previous errors.
-
- elsif No (Etyp) then
- Check_Error_Detected;
- return T;
-
- elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
- return T;
-
- elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
- return T;
- end if;
-
- 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.
-
- if T = Base_Type (Id) then
- return T;
- end if;
- end loop;
- end if;
+ -- pragma Assert (T = Root_Type_If_Set (Id));
+ -- Disabled; too slow
+ end return;
end Root_Type;
+ function Root_Type_If_Set (Id : E) return Opt_N_Entity_Id is
+ Etyp : Entity_Id;
+
+ 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);
+
+ 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
+ (Is_Private_Type (Etyp) and then Full_View (Etyp) = T);
+
+ T := Etyp;
+
+ -- 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_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 78b49891f609..27cf9e670f0e 100644
--- 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 857b9263f012..fbad71a3765a 100644
--- 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;
--
2.43.0
