[multiple changes]

2009-04-15  Robert Dewar  <dewar@adacore.com>

	* sem_prag.adb: Minor reformatting.

	* sem_type.adb: Minor reformatting

2009-04-15  Javier Miranda  <miranda@adacore.com>

	* sem_ch6.adb (Analyze_Abstract_Subprogram_Declaration): Add missing
	support to check eliminated subprograms.

	* sem_elim.ads (Eliminate_Error_Msg): Update documentation.

	* sem_elim.adb (Set_Eliminated): Add support for elimination of
	dispatching subprograms.

	* exp_disp.adb (Make_DT): Minor code cleanup when freezing primitive
	operations. Initialize with "null" the slots of eliminated dispaching
	primitives.
	(Write_DT): Add output for eliminated primitives.

	* sem_disp.adb (Check_Dispatching_Call): Check eliminated primitives.

From-SVN: r146093

8 files changed, 71 insertions, 25 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4400d98..0d4a01e 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,26 @@
+2009-04-15  Robert Dewar  <dewar@adacore.com>
+
+	* sem_prag.adb: Minor reformatting.
+
+	* sem_type.adb: Minor reformatting
+
+2009-04-15  Javier Miranda  <miranda@adacore.com>
+
+	* sem_ch6.adb (Analyze_Abstract_Subprogram_Declaration): Add missing
+	support to check eliminated subprograms.
+
+	* sem_elim.ads (Eliminate_Error_Msg): Update documentation.
+
+	* sem_elim.adb (Set_Eliminated): Add support for elimination of
+	dispatching subprograms.
+
+	* exp_disp.adb (Make_DT): Minor code cleanup when freezing primitive
+	operations. Initialize with "null" the slots of eliminated dispaching
+	primitives.
+	(Write_DT): Add output for eliminated primitives.
+
+	* sem_disp.adb (Check_Dispatching_Call): Check eliminated primitives.
+
 2009-04-15  Ed Schonberg  <schonberg@adacore.com>
 
 	* sem_ch8.adb (Use_One_Type): If both clauses appear on the same unit,
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index f514973..72131c4 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -3941,27 +3941,29 @@ package body Exp_Disp is
       then
          declare
             Save      : constant Boolean := Freezing_Library_Level_Tagged_Type;
+            Prim      : Entity_Id;
             Prim_Elmt : Elmt_Id;
             Frnodes   : List_Id;
 
          begin
             Freezing_Library_Level_Tagged_Type := True;
+
             Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
             while Present (Prim_Elmt) loop
-               Frnodes := Freeze_Entity (Node (Prim_Elmt), Loc);
+               Prim    := Node (Prim_Elmt);
+               Frnodes := Freeze_Entity (Prim, Loc);
 
                declare
-                  Subp : constant Entity_Id := Node (Prim_Elmt);
                   F : Entity_Id;
 
                begin
-                  F := First_Formal (Subp);
+                  F := First_Formal (Prim);
                   while Present (F) loop
-                     Check_Premature_Freezing (Subp, Etype (F));
+                     Check_Premature_Freezing (Prim, Etype (F));
                      Next_Formal (F);
                   end loop;
 
-                  Check_Premature_Freezing (Subp, Etype (Subp));
+                  Check_Premature_Freezing (Prim, Etype (Prim));
                end;
 
                if Present (Frnodes) then
@@ -3970,6 +3972,7 @@ package body Exp_Disp is
 
                Next_Elmt (Prim_Elmt);
             end loop;
+
             Freezing_Library_Level_Tagged_Type := Save;
          end;
       end if;
@@ -5145,6 +5148,7 @@ package body Exp_Disp is
                   if Is_Imported (Prim)
                     or else Present (Interface_Alias (Prim))
                     or else Is_Predefined_Dispatching_Operation (Prim)
+                    or else Is_Eliminated (Prim)
                   then
                      null;
 
@@ -7180,6 +7184,10 @@ package body Exp_Disp is
             Write_Str (" is null;");
          end if;
 
+         if Is_Eliminated (Ultimate_Alias (Prim)) then
+            Write_Str (" (eliminated)");
+         end if;
+
          Write_Eol;
 
          Next_Elmt (Elmt);
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 2663fab..c206c4b 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -367,6 +367,7 @@ package body Sem_Ch6 is
       end if;
 
       Generate_Reference_To_Formals (Designator);
+      Check_Eliminated (Designator);
    end Analyze_Abstract_Subprogram_Declaration;
 
    ----------------------------------------
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index a1faa3f..96e6bc1 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -42,6 +42,7 @@ with Rident;   use Rident;
 with Sem;      use Sem;
 with Sem_Aux;  use Sem_Aux;
 with Sem_Ch6;  use Sem_Ch6;
+with Sem_Elim; use Sem_Elim;
 with Sem_Eval; use Sem_Eval;
 with Sem_Type; use Sem_Type;
 with Sem_Util; use Sem_Util;
@@ -483,6 +484,10 @@ package body Sem_Disp is
             Set_Controlling_Argument (N, Control);
             Check_Restriction (No_Dispatching_Calls, N);
 
+            if Is_Eliminated (Ultimate_Alias (Subp_Entity)) then
+               Eliminate_Error_Msg (N, Ultimate_Alias (Subp_Entity));
+            end if;
+
          --  If there is a statically tagged actual and a tag-indeterminate
          --  call to a function of the ancestor (such as that provided by a
          --  default), then treat this as a dispatching call and propagate
diff --git a/gcc/ada/sem_elim.adb b/gcc/ada/sem_elim.adb
index 10449dd..bdf6d57 100644
--- a/gcc/ada/sem_elim.adb
+++ b/gcc/ada/sem_elim.adb
@@ -269,7 +269,7 @@ package body Sem_Elim is
 
       Elmt := Elim_Hash_Table.Get (Chars (E));
       while Elmt /= null loop
-         declare
+         Check_Homonyms : declare
             procedure Set_Eliminated;
             --  Set current subprogram entity as eliminated
 
@@ -279,16 +279,26 @@ package body Sem_Elim is
 
             procedure Set_Eliminated is
             begin
-               --  Never try to eliminate dispatching operation, since we
-               --  can't properly process the eliminated result. This could
-               --  be fixed, but is not worth it.
+               if Is_Dispatching_Operation (E) then
 
-               if not Is_Dispatching_Operation (E) then
-                  Set_Is_Eliminated (E);
-                  Elim_Entities.Append ((Prag => Elmt.Prag, Subp => E));
+                  --  If an overriding dispatching primitive is eliminated then
+                  --  its parent must have been eliminated
+
+                  if Is_Overriding_Operation (E)
+                    and then not Is_Eliminated (Overridden_Operation (E))
+                  then
+                     Error_Msg_Name_1 := Chars (E);
+                     Error_Msg_N ("cannot eliminate subprogram %", E);
+                     return;
+                  end if;
                end if;
+
+               Set_Is_Eliminated (E);
+               Elim_Entities.Append ((Prag => Elmt.Prag, Subp => E));
             end Set_Eliminated;
 
+         --  Start of processing for Check_Homonyms
+
          begin
             --  First we check that the name of the entity matches
 
@@ -643,7 +653,7 @@ package body Sem_Elim is
                Set_Eliminated;
                return;
             end if;
-         end;
+         end Check_Homonyms;
 
       <<Continue>>
          Elmt := Elmt.Homonym;
diff --git a/gcc/ada/sem_elim.ads b/gcc/ada/sem_elim.ads
index ee9f8a1..53f0de0 100644
--- a/gcc/ada/sem_elim.ads
+++ b/gcc/ada/sem_elim.ads
@@ -53,8 +53,8 @@ package Sem_Elim is
    --  flag on the given entity.
 
    procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id);
-   --  Called by the back end on encountering a call to an eliminated
-   --  subprogram. N is the node for the call, and E is the entity of
-   --  the subprogram being eliminated.
+   --  Called by the front-end and back-end on encountering a call to an
+   --  eliminated subprogram. N is the node for the call, and E is the
+   --  entity of the subprogram being eliminated.
 
 end Sem_Elim;
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 37b6727..e8cd0a0 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -9226,7 +9226,7 @@ package body Sem_Prag is
             --  Cases where we must follow a declaration
 
             else
-               if Nkind (Decl) not in N_Declaration
+               if         Nkind (Decl) not in N_Declaration
                  and then Nkind (Decl) not in N_Later_Decl_Item
                  and then Nkind (Decl) not in N_Generic_Declaration
                  and then Nkind (Decl) not in N_Renaming_Declaration
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
index 1e909a2..bc9dbdb 100644
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -1425,30 +1425,29 @@ package body Sem_Type is
                elsif Is_Numeric_Type (Etype (F1))
                  and then Has_Abstract_Interpretation (Act1)
                then
-
-                  --  Current interpretation is not the right one because
-                  --  it expects a numeric operand. Examine all the other
-                  --  ones.
+                  --  Current interpretation is not the right one because it
+                  --  expects a numeric operand. Examine all the other ones.
 
                   declare
-                     I : Interp_Index;
+                     I  : Interp_Index;
                      It : Interp;
 
                   begin
                      Get_First_Interp (N, I, It);
-
                      while Present (It.Typ) loop
                         if
                           not Is_Numeric_Type (Etype (First_Formal (It.Nam)))
                         then
                            if No (Act2)
                              or else not Has_Abstract_Interpretation (Act2)
-                             or else not Is_Numeric_Type
-                               (Etype (Next_Formal (First_Formal (It.Nam))))
+                             or else not
+                               Is_Numeric_Type
+                                 (Etype (Next_Formal (First_Formal (It.Nam))))
                            then
                               return It;
                            end if;
                         end if;
+
                         Get_Next_Interp (I, It);
                      end loop;