[multiple changes]

2011-08-02  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch8.adb (Analyze_Subprogram_Renaming): new procedure
	Check_Class_Wide_Actual, to implement AI05-0071, on defaulted
	primitive operations of class-wide actuals.

2011-08-02  Javier Miranda  <miranda@adacore.com>

	* exp_atag.ads, exp_atag.adb
	(Build_Common_Dispatching_Select_Statements): Remove argument Loc
	since its value is implicitly passed in argument Typ.
	* exp_disp.adb (Make_Disp_Conditional_Select_Body,
	Make_Disp_Timed_Select_Body): Remove Loc in calls to routine
	Build_Common_Dispatching_Select_Statements.

From-SVN: r177171

5 files changed, 225 insertions, 12 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 152af3e..ac403b0 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,18 @@
+2011-08-02  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch8.adb (Analyze_Subprogram_Renaming): new procedure
+	Check_Class_Wide_Actual, to implement AI05-0071, on defaulted
+	primitive operations of class-wide actuals.
+
+2011-08-02  Javier Miranda  <miranda@adacore.com>
+
+	* exp_atag.ads, exp_atag.adb
+	(Build_Common_Dispatching_Select_Statements): Remove argument Loc
+	since its value is implicitly passed in argument Typ.
+	* exp_disp.adb (Make_Disp_Conditional_Select_Body,
+	Make_Disp_Timed_Select_Body): Remove Loc in calls to routine
+	Build_Common_Dispatching_Select_Statements.
+
 2011-08-02  Robert Dewar  <dewar@adacore.com>
 
 	* sem_ch3.adb, exp_atag.ads, get_scos.adb, get_scos.ads,
diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb
index f89263c..6e86dbc 100644
--- a/gcc/ada/exp_atag.adb
+++ b/gcc/ada/exp_atag.adb
@@ -71,10 +71,10 @@ package body Exp_Atag is
    ------------------------------------------------
 
    procedure Build_Common_Dispatching_Select_Statements
-     (Loc    : Source_Ptr;
-      Typ    : Entity_Id;
+     (Typ    : Entity_Id;
       Stmts  : List_Id)
    is
+      Loc      : constant Source_Ptr := Sloc (Typ);
       Tag_Node : Node_Id;
 
    begin
diff --git a/gcc/ada/exp_atag.ads b/gcc/ada/exp_atag.ads
index 657e53f..36382ea 100644
--- a/gcc/ada/exp_atag.ads
+++ b/gcc/ada/exp_atag.ads
@@ -35,12 +35,11 @@ package Exp_Atag is
    --  location used in constructing the corresponding nodes.
 
    procedure Build_Common_Dispatching_Select_Statements
-     (Loc   : Source_Ptr;
-      Typ   : Entity_Id;
+     (Typ   : Entity_Id;
       Stmts : List_Id);
-   --  Ada 2005 (AI-345): Generate statements that are common between timed,
-   --  asynchronous, and conditional select expansion.
-   --  Comments required saying what parameters mean ???
+   --  Ada 2005 (AI-345): Build statements that are common to the expansion of
+   --  timed, asynchronous, and conditional select and append them to Stmts.
+   --  Typ is the tagged type used for dispatching calls.
 
    procedure Build_CW_Membership
      (Loc          : Source_Ptr;
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 6c8642b..553bb4d 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -2623,7 +2623,7 @@ package body Exp_Disp is
          --       return;
          --    end if;
 
-         Build_Common_Dispatching_Select_Statements (Loc, Typ, Stmts);
+         Build_Common_Dispatching_Select_Statements (Typ, Stmts);
 
          --  Generate:
          --    Bnn : Communication_Block;
@@ -3470,7 +3470,7 @@ package body Exp_Disp is
          --       return;
          --    end if;
 
-         Build_Common_Dispatching_Select_Statements (Loc, Typ, Stmts);
+         Build_Common_Dispatching_Select_Statements (Typ, Stmts);
 
          --  Generate:
          --    I := Get_Entry_Index (tag! (<type>VP), S);
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 90da2a6..a274109 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -1614,6 +1614,179 @@ package body Sem_Ch8 is
       --  before the subprogram it completes is frozen, and renaming indirectly
       --  renames the subprogram itself.(Defect Report 8652/0027).
 
+      function Check_Class_Wide_Actual return Entity_Id;
+      --  AI05-0071: In an instance, if the actual for a formal type FT with
+      --  unknown discriminants is a class-wide type CT, and the generic has
+      --  a formal subprogram with a box for a primitive operation of FT,
+      --  then the corresponding actual subprogram denoted by the default is a
+      --  class-wide operation whose body is a dispatching call. We replace the
+      --  generated renaming declaration:
+      --
+      --  procedure P (X : CT) renames P;
+      --
+      --  by a different renaming and a class-wide operation:
+      --
+      --  procedure Pr (X : T) renames P;   --  renames primitive operation
+      --  procedure P (X : CT);             --  class-wide operation
+      --  ...
+      --  procedure P (X : CT) is begin Pr (X); end;  -- dispatching call
+
+      --  This rule only applies if there is no explicit visible class-wide
+      --  operation at the point of the instantiation.
+
+      -----------------------------
+      -- Check_Class_Wide_Actual --
+      -----------------------------
+
+      function Check_Class_Wide_Actual return Entity_Id is
+         Loc : constant Source_Ptr := Sloc (N);
+
+         F           : Entity_Id;
+         Formal_Type : Entity_Id;
+         Actual_Type : Entity_Id;
+         New_Body    : Node_Id;
+         New_Decl    : Node_Id;
+         Result      : Entity_Id;
+
+         function Make_Call (Prim_Op : Entity_Id) return Node_Id;
+         --  Build dispatching call for body of class-wide operation
+
+         function Make_Spec return Node_Id;
+         --  Create subprogram specification for declaration and body of
+         --  class-wide operation, using signature of renaming declaration.
+
+         ---------------
+         -- Make_Call --
+         ---------------
+
+         function Make_Call (Prim_Op : Entity_Id) return Node_Id is
+            Actuals : List_Id;
+            F       : Node_Id;
+
+         begin
+            Actuals := New_List;
+            F := First (Parameter_Specifications (Specification (New_Decl)));
+            while Present (F) loop
+               Append_To (Actuals,
+                 Make_Identifier (Loc, Chars (Defining_Identifier (F))));
+               Next (F);
+            end loop;
+
+            if Ekind (Prim_Op) = E_Function then
+               return Make_Simple_Return_Statement (Loc,
+                  Expression =>
+                    Make_Function_Call (Loc,
+                      Name => New_Occurrence_Of (Prim_Op, Loc),
+                      Parameter_Associations => Actuals));
+            else
+               return
+                 Make_Procedure_Call_Statement (Loc,
+                      Name => New_Occurrence_Of (Prim_Op, Loc),
+                      Parameter_Associations => Actuals);
+            end if;
+         end Make_Call;
+
+         ---------------
+         -- Make_Spec --
+         ---------------
+
+         function Make_Spec return Node_Id is
+            Param_Specs : constant List_Id := Copy_Parameter_List (New_S);
+
+         begin
+            if Ekind (New_S) = E_Procedure then
+               return
+                 Make_Procedure_Specification (Loc,
+                   Defining_Unit_Name =>
+                     Make_Defining_Identifier (Loc,
+                       Chars (Defining_Unit_Name (Spec))),
+                   Parameter_Specifications => Param_Specs);
+            else
+               return
+                  Make_Function_Specification (Loc,
+                    Defining_Unit_Name =>
+                      Make_Defining_Identifier (Loc,
+                        Chars (Defining_Unit_Name (Spec))),
+                    Parameter_Specifications => Param_Specs,
+                    Result_Definition =>
+                      New_Copy_Tree (Result_Definition (Spec)));
+            end if;
+         end Make_Spec;
+
+      --  Start of processing for Check_Class_Wide_Actual
+
+      begin
+         Result := Any_Id;
+         Formal_Type := Empty;
+         Actual_Type := Empty;
+
+         F := First_Formal (Formal_Spec);
+         while Present (F) loop
+            if Has_Unknown_Discriminants (Etype (F))
+              and then Is_Class_Wide_Type (Get_Instance_Of (Etype (F)))
+            then
+               Formal_Type := Etype (F);
+               Actual_Type := Etype (Get_Instance_Of (Formal_Type));
+               exit;
+            end if;
+
+            Next_Formal (F);
+         end loop;
+
+         if Present (Formal_Type) then
+
+            --  Create declaration and body for class-wide operation
+
+            New_Decl :=
+              Make_Subprogram_Declaration (Loc, Specification => Make_Spec);
+
+            New_Body :=
+              Make_Subprogram_Body (Loc,
+                Specification => Make_Spec,
+                Declarations => No_List,
+                Handled_Statement_Sequence =>
+                  Make_Handled_Sequence_Of_Statements (Loc, New_List));
+
+            --  Modify Spec and create internal name for renaming of primitive
+            --  operation.
+
+            Set_Defining_Unit_Name (Spec, Make_Temporary (Loc, 'R'));
+            F := First (Parameter_Specifications (Spec));
+            while Present (F) loop
+               if Nkind (Parameter_Type (F)) = N_Identifier
+                 and then Is_Class_Wide_Type (Entity (Parameter_Type (F)))
+               then
+                  Set_Parameter_Type (F, New_Occurrence_Of (Actual_Type, Loc));
+               end if;
+               Next (F);
+            end loop;
+
+            New_S := Analyze_Subprogram_Specification (Spec);
+            Result :=  Find_Renamed_Entity (N, Name (N), New_S, Is_Actual);
+         end if;
+
+         if Result /= Any_Id then
+            Insert_Before (N, New_Decl);
+            Analyze (New_Decl);
+
+            --  Add dispatching call to body of class-wide operation
+
+            Append (Make_Call (Result),
+              Statements (Handled_Statement_Sequence (New_Body)));
+
+            --  The generated body does not freeze. It is analyzed when the
+            --  generated operation is frozen.
+
+            Append_Freeze_Action (Defining_Entity (New_Decl), New_Body);
+
+            Result := Defining_Entity (New_Decl);
+         end if;
+
+         --  Return the class-wide operation if one was created.
+
+         return Result;
+      end Check_Class_Wide_Actual;
+
       --------------------------
       -- Check_Null_Exclusion --
       --------------------------
@@ -2190,6 +2363,16 @@ package body Sem_Ch8 is
          end if;
       end if;
 
+      --  If no renamed entity was found, check whether the renaming is for
+      --  a defaulted actual subprogram with a class-wide actual.
+
+      if Old_S = Any_Id
+        and then Is_Actual
+        and then From_Default (N)
+      then
+         Old_S := Check_Class_Wide_Actual;
+      end if;
+
       if Old_S /= Any_Id then
          if Is_Actual
            and then From_Default (N)
@@ -2246,7 +2429,20 @@ package body Sem_Ch8 is
             end if;
 
          elsif Ekind (Old_S) /= E_Operator then
-            Check_Mode_Conformant (New_S, Old_S);
+
+            --  If this is a default subprogram, it may be for a class-wide
+            --  actual, in which case there is no check for mode conformance,
+            --  given that the signatures do not match (the source mentions T,
+            --  but the actual mentions T'Class).
+
+            if  Is_Actual
+              and then From_Default (N)
+            then
+               null;
+
+            else
+               Check_Mode_Conformant (New_S, Old_S);
+            end if;
 
             if Is_Actual
               and then Error_Posted (New_S)
@@ -5319,7 +5515,10 @@ package body Sem_Ch8 is
          end loop;
 
          Set_Entity (Nam, Old_S);
-         Set_Is_Overloaded (Nam, False);
+
+         if Old_S /= Any_Id then
+            Set_Is_Overloaded (Nam, False);
+         end if;
       end if;
 
       return Old_S;