Patchwork [Ada] Ada 2012: Class-wide operations for formal subprograms

login
register
mail settings
Submitter Arnaud Charlet
Date Aug. 29, 2011, 2:23 p.m.
Message ID <20110829142332.GA4453@adacore.com>
Download mbox | patch
Permalink /patch/112067/
State New
Headers show

Comments

Arnaud Charlet - Aug. 29, 2011, 2:23 p.m.
The equivalence defined in AI05-0071-1 for formal subprogram matching
is extended such that it applies to explicit as well as default actual
subprograms. The following test now compiles without errors.

package Pack1 is
    type Root is tagged record
        F1 : Integer;
    end record;
    procedure Oper_1 (X : in out Root);
end Pack1;

package Pack2 is
    generic
        type T(<>) is private;
        with procedure Oper_1 (X : in out T) is <>;
    package Gen_Pack is
    end Gen_Pack;
end Pack2;

with Pack1;
with Pack2;
package Pack3 is
    package Inst3 is new Pack2.Gen_Pack (Pack1.Root, Pack1.Oper_1);
    package Inst4 is new Pack2.Gen_Pack (Pack1.Root'Class, Pack1.Oper_1);

    use Pack1;

    package Inst5 is new Pack2.Gen_Pack (Pack1.Root);
    package Inst6 is new Pack2.Gen_Pack (Pack1.Root'Class);
end Pack3;

Command: gcc -c -gnat12 pack3.ads

Tested on x86_64-pc-linux-gnu, committed on trunk

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.

Patch

Index: sem_ch8.adb
===================================================================
--- sem_ch8.adb	(revision 178236)
+++ sem_ch8.adb	(working copy)
@@ -1634,11 +1634,6 @@ 
    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 @@ 
       --  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 @@ 
                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 @@ 
          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 @@ 
          end loop;
 
          if Present (Formal_Type) then
-            CW_Actual := True;
 
             --  Create declaration and body for class-wide operation
 
@@ -1893,6 +1893,41 @@ 
          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 @@ 
          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 @@ 
       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 @@ 
          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