This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Ada] Spurious error on early call region of tagged type
- From: Pierre-Marie de Rodat <derodat at adacore dot com>
- To: gcc-patches at gcc dot gnu dot org
- Cc: Hristian Kirtchev <kirtchev at adacore dot com>
- Date: Mon, 21 May 2018 11:04:41 -0400
- Subject: [Ada] Spurious error on early call region of tagged type
This patch corrects the part of the access-before-elaboration mechanism which
ensures that the freeze node of a tagged type is within the early call region
of all its overriding bodies to ignore predefined primitives.
------------
-- Source --
------------
-- pack.ads
package Pack with SPARK_Mode is
type Parent_Typ is tagged null record;
procedure Prim (Obj : Parent_Typ);
type Deriv_Typ is new Parent_Typ with private;
overriding procedure Prim (Obj : Deriv_Typ);
private
type Deriv_Typ is new Parent_Typ with null record;
end Pack;
-----------------
-- Compilation --
-----------------
$ gcc -c pack.ads
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-05-21 Hristian Kirtchev <kirtchev@adacore.com>
gcc/ada/
* exp_cg.adb: Remove with and use clause for Exp_Disp.
* exp_ch9.adb: Remove with and use clause for Exp_Disp.
* exp_disp.adb (Is_Predefined_Dispatching_Operation): Moved to Sem_Util.
(Is_Predefined_Interface_Primitive): Moved to Sem_Util.
(Is_Predefined_Internal_Operation): Moved to Sem_Util.
* exp_disp.ads (Is_Predefined_Dispatching_Operation): Moved to Sem_Util.
(Is_Predefined_Interface_Primitive): Moved to Sem_Util.
(Is_Predefined_Internal_Operation): Moved to Sem_Util.
* exp_dist.adb: Remove with and use clause for Exp_Disp.
* freeze.adb: Remove with and use clause for Exp_Disp.
* sem_cat.adb: Remove with and use clause for Exp_Disp.
* sem_ch6.adb: Remove with and use clause for Exp_Disp.
* sem_ch12.adb: Remove with and use clause for Exp_Disp.
* sem_elab.adb (Check_Overriding_Primitive): Do not process predefined
primitives.
* sem_util.adb: Remove with and use clause for Exp_Disp.
(Is_Predefined_Dispatching_Operation): Moved from Exp_Disp.
(Is_Predefined_Interface_Primitive): Moved from Exp_Disp.
(Is_Predefined_Internal_Operation): Moved from Exp_Disp.
* sem_util.ads (Is_Predefined_Dispatching_Operation): Moved from
Exp_Disp.
(Is_Predefined_Interface_Primitive): Moved from Exp_Disp.
(Is_Predefined_Internal_Operation): Moved from Exp_Disp.
--- gcc/ada/exp_cg.adb
+++ gcc/ada/exp_cg.adb
@@ -26,7 +26,6 @@
with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
-with Exp_Disp; use Exp_Disp;
with Exp_Dbug; use Exp_Dbug;
with Exp_Tss; use Exp_Tss;
with Lib; use Lib;
--- gcc/ada/exp_ch9.adb
+++ gcc/ada/exp_ch9.adb
@@ -31,7 +31,6 @@ with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch11; use Exp_Ch11;
with Exp_Dbug; use Exp_Dbug;
-with Exp_Disp; use Exp_Disp;
with Exp_Sel; use Exp_Sel;
with Exp_Smem; use Exp_Smem;
with Exp_Tss; use Exp_Tss;
--- gcc/ada/exp_disp.adb
+++ gcc/ada/exp_disp.adb
@@ -2177,89 +2177,6 @@ package body Exp_Disp is
and then Is_Dispatch_Table_Entity (Etype (Name (N)));
end Is_Expanded_Dispatching_Call;
- -----------------------------------------
- -- Is_Predefined_Dispatching_Operation --
- -----------------------------------------
-
- function Is_Predefined_Dispatching_Operation
- (E : Entity_Id) return Boolean
- is
- TSS_Name : TSS_Name_Type;
-
- begin
- if not Is_Dispatching_Operation (E) then
- return False;
- end if;
-
- Get_Name_String (Chars (E));
-
- -- Most predefined primitives have internally generated names. Equality
- -- must be treated differently; the predefined operation is recognized
- -- as a homogeneous binary operator that returns Boolean.
-
- if Name_Len > TSS_Name_Type'Last then
- TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
- .. Name_Len));
- if Chars (E) = Name_uSize
- or else TSS_Name = TSS_Stream_Read
- or else TSS_Name = TSS_Stream_Write
- or else TSS_Name = TSS_Stream_Input
- or else TSS_Name = TSS_Stream_Output
- or else
- (Chars (E) = Name_Op_Eq
- and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
- or else Chars (E) = Name_uAssign
- or else TSS_Name = TSS_Deep_Adjust
- or else TSS_Name = TSS_Deep_Finalize
- or else Is_Predefined_Interface_Primitive (E)
- then
- return True;
- end if;
- end if;
-
- return False;
- end Is_Predefined_Dispatching_Operation;
-
- ---------------------------------------
- -- Is_Predefined_Internal_Operation --
- ---------------------------------------
-
- function Is_Predefined_Internal_Operation
- (E : Entity_Id) return Boolean
- is
- TSS_Name : TSS_Name_Type;
-
- begin
- if not Is_Dispatching_Operation (E) then
- return False;
- end if;
-
- Get_Name_String (Chars (E));
-
- -- Most predefined primitives have internally generated names. Equality
- -- must be treated differently; the predefined operation is recognized
- -- as a homogeneous binary operator that returns Boolean.
-
- if Name_Len > TSS_Name_Type'Last then
- TSS_Name :=
- TSS_Name_Type
- (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
-
- if Nam_In (Chars (E), Name_uSize, Name_uAssign)
- or else
- (Chars (E) = Name_Op_Eq
- and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
- or else TSS_Name = TSS_Deep_Adjust
- or else TSS_Name = TSS_Deep_Finalize
- or else Is_Predefined_Interface_Primitive (E)
- then
- return True;
- end if;
- end if;
-
- return False;
- end Is_Predefined_Internal_Operation;
-
-------------------------------------
-- Is_Predefined_Dispatching_Alias --
-------------------------------------
@@ -2272,25 +2189,6 @@ package body Exp_Disp is
and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim));
end Is_Predefined_Dispatching_Alias;
- ---------------------------------------
- -- Is_Predefined_Interface_Primitive --
- ---------------------------------------
-
- function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is
- begin
- -- In VM targets we don't restrict the functionality of this test to
- -- compiling in Ada 2005 mode since in VM targets any tagged type has
- -- these primitives.
-
- return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion)
- and then Nam_In (Chars (E), Name_uDisp_Asynchronous_Select,
- Name_uDisp_Conditional_Select,
- Name_uDisp_Get_Prim_Op_Kind,
- Name_uDisp_Get_Task_Id,
- Name_uDisp_Requeue,
- Name_uDisp_Timed_Select);
- end Is_Predefined_Interface_Primitive;
-
----------------------------------------
-- Make_Disp_Asynchronous_Select_Body --
----------------------------------------
--- gcc/ada/exp_disp.ads
+++ gcc/ada/exp_disp.ads
@@ -258,18 +258,6 @@ package Exp_Disp is
function Is_Expanded_Dispatching_Call (N : Node_Id) return Boolean;
-- Returns true if N is the expanded code of a dispatching call
- function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean;
- -- Ada 2005 (AI-251): Determines if E is a predefined primitive operation
-
- function Is_Predefined_Internal_Operation (E : Entity_Id) return Boolean;
- -- Similar to the previous one, but excludes stream operations, because
- -- these may be overridden, and need extra formals, like user-defined
- -- operations.
-
- function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean;
- -- Ada 2005 (AI-345): Returns True if E is one of the predefined primitives
- -- required to implement interfaces.
-
function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id;
-- Expand the declarations for the Dispatch Table. The node N is the
-- declaration that forces the generation of the table. It is used to place
--- gcc/ada/exp_dist.adb
+++ gcc/ada/exp_dist.adb
@@ -27,7 +27,6 @@ with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Atag; use Exp_Atag;
-with Exp_Disp; use Exp_Disp;
with Exp_Strm; use Exp_Strm;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
--- gcc/ada/freeze.adb
+++ gcc/ada/freeze.adb
@@ -33,7 +33,6 @@ with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch7; use Exp_Ch7;
-with Exp_Disp; use Exp_Disp;
with Exp_Pakd; use Exp_Pakd;
with Exp_Util; use Exp_Util;
with Exp_Tss; use Exp_Tss;
--- gcc/ada/sem_cat.adb
+++ gcc/ada/sem_cat.adb
@@ -28,7 +28,6 @@ with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
-with Exp_Disp; use Exp_Disp;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
--- gcc/ada/sem_ch12.adb
+++ gcc/ada/sem_ch12.adb
@@ -30,7 +30,6 @@ with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
-with Exp_Disp; use Exp_Disp;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
with Freeze; use Freeze;
--- gcc/ada/sem_ch6.adb
+++ gcc/ada/sem_ch6.adb
@@ -36,7 +36,6 @@ with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
with Exp_Dbug; use Exp_Dbug;
-with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
--- gcc/ada/sem_elab.adb
+++ gcc/ada/sem_elab.adb
@@ -2525,6 +2525,13 @@ package body Sem_Elab is
Region : Node_Id;
begin
+ -- Nothing to do for predefined primitives because they are artifacts
+ -- of tagged type expansion and cannot override source primitives.
+
+ if Is_Predefined_Dispatching_Operation (Prim) then
+ return;
+ end if;
+
Body_Id := Corresponding_Body (Prim_Decl);
-- Nothing to do when the primitive does not have a corresponding
--- gcc/ada/sem_util.adb
+++ gcc/ada/sem_util.adb
@@ -34,7 +34,6 @@ with Elists; use Elists;
with Errout; use Errout;
with Erroutc; use Erroutc;
with Exp_Ch11; use Exp_Ch11;
-with Exp_Disp; use Exp_Disp;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
with Freeze; use Freeze;
@@ -16094,6 +16093,109 @@ package body Sem_Util is
end if;
end Is_Potentially_Unevaluated;
+ -----------------------------------------
+ -- Is_Predefined_Dispatching_Operation --
+ -----------------------------------------
+
+ function Is_Predefined_Dispatching_Operation
+ (E : Entity_Id) return Boolean
+ is
+ TSS_Name : TSS_Name_Type;
+
+ begin
+ if not Is_Dispatching_Operation (E) then
+ return False;
+ end if;
+
+ Get_Name_String (Chars (E));
+
+ -- Most predefined primitives have internally generated names. Equality
+ -- must be treated differently; the predefined operation is recognized
+ -- as a homogeneous binary operator that returns Boolean.
+
+ if Name_Len > TSS_Name_Type'Last then
+ TSS_Name :=
+ TSS_Name_Type
+ (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
+
+ if Nam_In (Chars (E), Name_uAssign, Name_uSize)
+ or else
+ (Chars (E) = Name_Op_Eq
+ and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
+ or else TSS_Name = TSS_Deep_Adjust
+ or else TSS_Name = TSS_Deep_Finalize
+ or else TSS_Name = TSS_Stream_Input
+ or else TSS_Name = TSS_Stream_Output
+ or else TSS_Name = TSS_Stream_Read
+ or else TSS_Name = TSS_Stream_Write
+ or else Is_Predefined_Interface_Primitive (E)
+ then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Is_Predefined_Dispatching_Operation;
+
+ ---------------------------------------
+ -- Is_Predefined_Interface_Primitive --
+ ---------------------------------------
+
+ function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is
+ begin
+ -- In VM targets we don't restrict the functionality of this test to
+ -- compiling in Ada 2005 mode since in VM targets any tagged type has
+ -- these primitives.
+
+ return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion)
+ and then Nam_In (Chars (E), Name_uDisp_Asynchronous_Select,
+ Name_uDisp_Conditional_Select,
+ Name_uDisp_Get_Prim_Op_Kind,
+ Name_uDisp_Get_Task_Id,
+ Name_uDisp_Requeue,
+ Name_uDisp_Timed_Select);
+ end Is_Predefined_Interface_Primitive;
+
+ ---------------------------------------
+ -- Is_Predefined_Internal_Operation --
+ ---------------------------------------
+
+ function Is_Predefined_Internal_Operation
+ (E : Entity_Id) return Boolean
+ is
+ TSS_Name : TSS_Name_Type;
+
+ begin
+ if not Is_Dispatching_Operation (E) then
+ return False;
+ end if;
+
+ Get_Name_String (Chars (E));
+
+ -- Most predefined primitives have internally generated names. Equality
+ -- must be treated differently; the predefined operation is recognized
+ -- as a homogeneous binary operator that returns Boolean.
+
+ if Name_Len > TSS_Name_Type'Last then
+ TSS_Name :=
+ TSS_Name_Type
+ (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
+
+ if Nam_In (Chars (E), Name_uSize, Name_uAssign)
+ or else
+ (Chars (E) = Name_Op_Eq
+ and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
+ or else TSS_Name = TSS_Deep_Adjust
+ or else TSS_Name = TSS_Deep_Finalize
+ or else Is_Predefined_Interface_Primitive (E)
+ then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Is_Predefined_Internal_Operation;
+
--------------------------------
-- Is_Preelaborable_Aggregate --
--------------------------------
--- gcc/ada/sem_util.ads
+++ gcc/ada/sem_util.ads
@@ -1842,6 +1842,18 @@ package Sem_Util is
-- persistent. A private type is potentially persistent if the full type
-- is potentially persistent.
+ function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean;
+ -- Ada 2005 (AI-251): Determines if E is a predefined primitive operation
+
+ function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean;
+ -- Ada 2005 (AI-345): Returns True if E is one of the predefined primitives
+ -- required to implement interfaces.
+
+ function Is_Predefined_Internal_Operation (E : Entity_Id) return Boolean;
+ -- Similar to the previous one, but excludes stream operations, because
+ -- these may be overridden, and need extra formals, like user-defined
+ -- operations.
+
function Is_Preelaborable_Aggregate (Aggr : Node_Id) return Boolean;
-- Determine whether aggregate Aggr violates the restrictions of
-- preelaborable constructs as defined in ARM 10.2.1(5-9).