* [Ada] Crash building VSS with compiler built with assertions
@ 2022-05-18 8:43 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2022-05-18 8:43 UTC (permalink / raw)
To: gcc-patches; +Cc: Javier Miranda
[-- Attachment #1: Type: text/plain, Size: 968 bytes --]
When a tagged type T has aspect String_Literal, a derived type defines a
null extension T2, and the context to resolve the use of an object of
type T2 where the string literal is applicable is a class-wide type the
frontend crashes trying to evaluate if the object is a null extension.
This problem does not reproduce when the compiler is built with
assertions disabled.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* sem_ch6.adb (Find_Corresponding_Spec): Avoid calling
Is_Null_Extension with a class-wide type entity.
(Overrides_Visible_Function): Handle alias entities.
* sem_res.adb (Has_Applicable_User_Defined_Literal): Conversion
not needed if the result type of the call is class-wide or if
the result type matches the context type.
* sem_util.ads (Is_Null_Extension): Adding documentation.
(Is_Null_Extension_Of): Adding documentation.
* sem_util.adb (Is_Null_Extension): Adding assertion.
(Is_Null_Extension_Of): Adding assertions.
[-- Attachment #2: patch.diff --]
[-- Type: text/x-diff, Size: 3672 bytes --]
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -9867,7 +9867,8 @@ package body Sem_Ch6 is
and then Ada_Version >= Ada_2005
and then not Comes_From_Source (E)
and then Has_Controlling_Result (E)
- and then Is_Null_Extension (Etype (E))
+ and then (not Is_Class_Wide_Type (Etype (E))
+ and then Is_Null_Extension (Etype (E)))
and then Comes_From_Source (Spec)
then
Set_Has_Completion (E, False);
@@ -11265,7 +11266,8 @@ package body Sem_Ch6 is
function Overrides_Private_Part_Op return Boolean is
Over_Decl : constant Node_Id :=
- Unit_Declaration_Node (Overridden_Operation (S));
+ Unit_Declaration_Node
+ (Ultimate_Alias (Overridden_Operation (S)));
Subp_Decl : constant Node_Id := Unit_Declaration_Node (S);
begin
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -559,7 +559,12 @@ package body Sem_Res is
Set_Etype (Call, Etype (Callee));
- if Base_Type (Etype (Call)) /= Base_Type (Typ) then
+ -- Conversion not needed if the result type of the call is class-wide
+ -- or if the result type matches the context type.
+
+ if not Is_Class_Wide_Type (Typ)
+ and then Base_Type (Etype (Call)) /= Base_Type (Typ)
+ then
-- Conversion may be needed in case of an inherited
-- aspect of a derived type. For a null extension, we
-- use a null extension aggregate instead because the
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -19279,6 +19279,8 @@ package body Sem_Util is
Type_Decl : Node_Id;
Type_Def : Node_Id;
begin
+ pragma Assert (not Is_Class_Wide_Type (T));
+
if Ignore_Privacy then
Type_Decl := Parent (Underlying_Type (Base_Type (T)));
else
@@ -19311,7 +19313,10 @@ package body Sem_Util is
:= Underlying_Type (Base_Type (Ancestor));
Descendant_Type : Entity_Id := Underlying_Type (Base_Type (Descendant));
begin
+ pragma Assert (not Is_Class_Wide_Type (Descendant));
+ pragma Assert (not Is_Class_Wide_Type (Ancestor));
pragma Assert (Descendant_Type /= Ancestor_Type);
+
while Descendant_Type /= Ancestor_Type loop
if not Is_Null_Extension
(Descendant_Type, Ignore_Privacy => True)
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -2209,12 +2209,14 @@ package Sem_Util is
-- Given a tagged type, returns True if argument is a type extension
-- that introduces no new components (discriminant or nondiscriminant).
-- Ignore_Privacy should be True for use in implementing dynamic semantics.
+ -- Cannot be called with class-wide types.
function Is_Null_Extension_Of
(Descendant, Ancestor : Entity_Id) return Boolean;
-- Given two tagged types, the first a descendant of the second,
-- returns True if every component of Descendant is inherited
-- (directly or indirectly) from Ancestor. Privacy is ignored.
+ -- Cannot be called with class-wide types.
function Is_Null_Record_Definition (Record_Def : Node_Id) return Boolean;
-- Returns True for an N_Record_Definition node that has no user-defined
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-05-18 8:43 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-05-18 8:43 [Ada] Crash building VSS with compiler built with assertions Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).