[multiple changes]

2011-08-29  Robert Dewar  <dewar@adacore.com>

	* a-cbhama.adb, a-cbhama.ads: Minor reformatting.

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

	* sem_ch8.adb (Analyze_Subprogram_Renaming): Complete support for
	renamings of formal subprograms when the actual for a formal type is
	class-wide.

From-SVN: r178244

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index ca82e7b1b8522aae47f4e933a45c367f46d434cd..508eb8774610cc6b79c0d1bdcd6d54530bf97033 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,13 @@
+2011-08-29  Robert Dewar  <dewar@adacore.com>
+
+       * a-cbhama.adb, a-cbhama.ads: Minor reformatting.
+
+2011-08-29  Javier Miranda  <miranda@adacore.com>
+
+       * sem_ch8.adb (Analyze_Subprogram_Renaming): Complete support for
+       renamings of formal subprograms when the actual for a formal type is
+       class-wide.
+
 2011-08-29  Matthew Heaney  <heaney@adacore.com>
 
        * a-cbhama.ads, a-cbhase.ads (Move): Clear Source following assignment

diff --git a/gcc/ada/a-cbhama.adb b/gcc/ada/a-cbhama.adb
index f71a9a552b0085650d89749b2bdf881ae1f65c03..629c1041ed95f85d2a7d2b5f7a408e1046316b38 100644 (file)
--- a/gcc/ada/a-cbhama.adb
+++ b/gcc/ada/a-cbhama.adb
@@ -424,15 +424,14 @@ package body Ada.Containers.Bounded_Hashed_Maps is
    end First;
 
    function First (Object : Iterator) return Cursor is
-      M : constant Map_Access  := Object.Container;
-      N : constant Count_Type  := HT_Ops.First (M.all);
-
+      M : constant Map_Access := Object.Container;
+      N : constant Count_Type := HT_Ops.First (M.all);
    begin
       if N = 0 then
          return No_Element;
+      else
+         return Cursor'(Object.Container.all'Unchecked_Access, N);
       end if;
-
-      return Cursor'(Object.Container.all'Unchecked_Access, N);
    end First;
 
    -----------------

diff --git a/gcc/ada/a-cbhama.ads b/gcc/ada/a-cbhama.ads
index 94860f99cc0f872078ffc5d65aa3c291fa8cf3e6..003a919a6e3c54b2a672297ce74c1ceb62cc20ec 100644 (file)
--- a/gcc/ada/a-cbhama.ads
+++ b/gcc/ada/a-cbhama.ads
@@ -32,7 +32,8 @@
 ------------------------------------------------------------------------------
 
 private with Ada.Containers.Hash_Tables;
-with Ada.Streams; use Ada.Streams;
+
+with Ada.Streams;             use Ada.Streams;
 with Ada.Iterator_Interfaces;
 
 generic
@@ -47,8 +48,7 @@ package Ada.Containers.Bounded_Hashed_Maps is
    pragma Pure;
    pragma Remote_Types;
 
-   type Map (Capacity : Count_Type; Modulus : Hash_Type) is tagged private
-   with
+   type Map (Capacity : Count_Type; Modulus : Hash_Type) is tagged private with
       Constant_Indexing => Constant_Reference,
       Variable_Indexing => Reference,
       Default_Iterator  => Iterate,
@@ -328,7 +328,6 @@ package Ada.Containers.Bounded_Hashed_Maps is
    return Reference_Type;
 
 private
-   --  pragma Inline ("=");
    pragma Inline (Length);
    pragma Inline (Is_Empty);
    pragma Inline (Clear);
@@ -339,7 +338,6 @@ private
    pragma Inline (Capacity);
    pragma Inline (Reserve_Capacity);
    pragma Inline (Has_Element);
-   --  pragma Inline (Equivalent_Keys);
    pragma Inline (Next);
 
    type Node_Type is record

diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 5a782f3c20cc07db36803754fb452931cc885af0..77f948f4f6a4622611a0f913955cdda525d85351 100644 (file)
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -1634,11 +1634,6 @@ package body Sem_Ch8 is
    procedure Analyze_Subprogram_Renaming (N : Node_Id) is
       Formal_Spec : constant Node_Id := Corresponding_Formal_Spec (N);
       Is_Actual   : constant Boolean := Present (Formal_Spec);
-
-      CW_Actual : Boolean := False;
-      --  True if the renaming is for a defaulted formal subprogram when the
-      --  actual for a related formal type is class-wide. For AI05-0071.
-
       Inst_Node   : Node_Id                   := Empty;
       Nam         : constant Node_Id          := Name (N);
       New_S       : Entity_Id;
@@ -1691,6 +1686,11 @@ package body Sem_Ch8 is
       --  This rule only applies if there is no explicit visible class-wide
       --  operation at the point of the instantiation.
 
+      function Has_Class_Wide_Actual return Boolean;
+      --  Ada 2012 (AI05-071, AI05-0131): True if N is the renaming for a
+      --  defaulted formal subprogram when the actual for the controlling
+      --  formal type is class-wide.
+
       -----------------------------
       -- Check_Class_Wide_Actual --
       -----------------------------
@@ -1729,7 +1729,7 @@ package body Sem_Ch8 is
                Next (F);
             end loop;
 
-            if Ekind (Prim_Op) = E_Function then
+            if Ekind_In (Prim_Op, E_Function, E_Operator) then
                return Make_Simple_Return_Statement (Loc,
                   Expression =>
                     Make_Function_Call (Loc,
@@ -1780,6 +1780,7 @@ package body Sem_Ch8 is
          F := First_Formal (Formal_Spec);
          while Present (F) loop
             if Has_Unknown_Discriminants (Etype (F))
+              and then not Is_Class_Wide_Type (Etype (F))
               and then Is_Class_Wide_Type (Get_Instance_Of (Etype (F)))
             then
                Formal_Type := Etype (F);
@@ -1791,7 +1792,6 @@ package body Sem_Ch8 is
          end loop;
 
          if Present (Formal_Type) then
-            CW_Actual := True;
 
             --  Create declaration and body for class-wide operation
 
@@ -1893,6 +1893,41 @@ package body Sem_Ch8 is
          end if;
       end Check_Null_Exclusion;
 
+      ---------------------------
+      -- Has_Class_Wide_Actual --
+      ---------------------------
+
+      function Has_Class_Wide_Actual return Boolean is
+         F_Nam  : Entity_Id;
+         F_Spec : Entity_Id;
+
+      begin
+         if Is_Actual
+           and then Nkind (Nam) in N_Has_Entity
+           and then Present (Entity (Nam))
+           and then Is_Dispatching_Operation (Entity (Nam))
+         then
+            F_Nam  := First_Entity (Entity (Nam));
+            F_Spec := First_Formal (Formal_Spec);
+            while Present (F_Nam)
+              and then Present (F_Spec)
+            loop
+               if Is_Controlling_Formal (F_Nam)
+                 and then Has_Unknown_Discriminants (Etype (F_Spec))
+                 and then not Is_Class_Wide_Type (Etype (F_Spec))
+                 and then Is_Class_Wide_Type (Get_Instance_Of (Etype (F_Spec)))
+               then
+                  return True;
+               end if;
+
+               Next_Entity (F_Nam);
+               Next_Formal (F_Spec);
+            end loop;
+         end if;
+
+         return False;
+      end Has_Class_Wide_Actual;
+
       -------------------------
       -- Original_Subprogram --
       -------------------------
@@ -1938,6 +1973,11 @@ package body Sem_Ch8 is
          end if;
       end Original_Subprogram;
 
+      CW_Actual : constant Boolean := Has_Class_Wide_Actual;
+      --  Ada 2012 (AI05-071, AI05-0131): True if the renaming is for a
+      --  defaulted formal subprogram when the actual for a related formal
+      --  type is class-wide.
+
    --  Start of processing for Analyze_Subprogram_Renaming
 
    begin
@@ -2058,7 +2098,14 @@ package body Sem_Ch8 is
       if Is_Actual then
          Inst_Node := Unit_Declaration_Node (Formal_Spec);
 
-         if Is_Entity_Name (Nam)
+         --  Check whether the renaming is for a defaulted actual subprogram
+         --  with a class-wide actual.
+
+         if CW_Actual then
+            New_S := Analyze_Subprogram_Specification (Spec);
+            Old_S := Check_Class_Wide_Actual;
+
+         elsif Is_Entity_Name (Nam)
            and then Present (Entity (Nam))
            and then not Comes_From_Source (Nam)
            and then not Is_Overloaded (Nam)
@@ -2419,16 +2466,6 @@ 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) then