[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

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.

From-SVN: r260467

13 files changed, 148 insertions, 122 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 5cbb973..5f56158 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,29 @@
+2018-04-04  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* 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.
+
 2018-04-04  Ed Schonberg  <schonberg@adacore.com>
 
 	* sem_res.adb (Valid_Conversion): Improve error message on an illegal
diff --git a/gcc/ada/exp_cg.adb b/gcc/ada/exp_cg.adb
index 883b7a0..00f029b 100644
--- a/gcc/ada/exp_cg.adb
+++ b/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;
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 9c2a165..981c0ee 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/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;
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index bcf566a..c9181e5 100644
--- a/gcc/ada/exp_disp.adb
+++ b/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 --
    ----------------------------------------
diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads
index c519be9..4a22d20 100644
--- a/gcc/ada/exp_disp.ads
+++ b/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
diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb
index c354641..546b56f 100644
--- a/gcc/ada/exp_dist.adb
+++ b/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;
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 958f3e0..0df747b 100644
--- a/gcc/ada/freeze.adb
+++ b/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;
diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb
index 7485729..70ea9cf 100644
--- a/gcc/ada/sem_cat.adb
+++ b/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;
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 4af6694..8f7ba5c 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/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;
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index c88721f..dd0af49 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/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;
diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb
index 69d46f4..4987f93 100644
--- a/gcc/ada/sem_elab.adb
+++ b/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
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 5555441..52fd14f 100644
--- a/gcc/ada/sem_util.adb
+++ b/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 --
    --------------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index a990851..5007bb6 100644
--- a/gcc/ada/sem_util.ads
+++ b/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).