einfo.adb: Flag245 is now used.

2008-07-30  Hristian Kirtchev  <kirtchev@adacore.com>

	* einfo.adb: Flag245 is now used.
	(Is_Primitive_Wrapper, Set_Is_Primitive_Wrapper): Relax the assertion
	check to include functions.
	(Is_Private_Primitive, Set_Is_Private_Primitive): New subprograms.
	(Wrapped_Entity, Set_Wrapped_Entity): Relax the assertion check to
	include functions.
	(Write_Entity_Flags): Move flag Is_Primitive, add Is_Private_Primitive
	to the list of displayed flags.

	* einfo.ads: Update comment on the usage of Is_Primitive_Wrapper and
	Wrapped_Entity. These two flags are now present in functions.
	New flag Is_Private_Primitive.
	(Is_Private_Primitive, Set_Is_Private_Primitive): New subprograms.

	* exp_ch9.adb:
	(Build_Wrapper_Bodies): New subprogram.
	(Build_Wrapper_Body): The spec and body have been moved to in
	Build_Wrapper_ Bodies. Code cleanup.
	(Build_Wrapper_Spec): Moved to the spec of Exp_Ch9. Code cleanup.
	Wrappers are now generated for primitives declared between the private
	and full view of a concurrent type that implements an interface.
	(Build_Wrapper_Specs): New subprogram.
	(Expand_N_Protected_Body): Code reformatting. Replace the wrapper body
	creation mechanism with a call to Build_Wrapper_Bodies.
	(Expand_N_Protected_Type_Declaration): Code reformatting. Replace the
	wrapper spec creation mechanism with a call to Build_Wrapper_Specs.
	(Expand_N_Task_Body): Replace the wrapper body creation
	mechanism with a call to Build_Wrapper_Bodies.
	(Expand_N_Task_Type_Declaration): Replace the wrapper spec
	creation mechanism with a call to Build_Wrapper_Specs.
	(Is_Private_Primitive_Subprogram): New subprogram.
	(Overriding_Possible): Code cleanup.
	(Replicate_Entry_Formals): Renamed to Replicate_Formals, code cleanup.

	* exp_ch9.ads (Build_Wrapper_Spec): Moved from the body of Exp_Ch9.

	* sem_ch3.adb: Add with and use clause for Exp_Ch9.
	(Process_Full_View): Build wrapper specs for all primitives
	that belong to a private view completed by a concurrent type
	implementing an interface.
	
	* sem_ch6.adb (Analyze_Subprogram_Body): When the current subprogram
	is a primitive of a
	concurrent type with a private view that implements an interface, try to
	find the proper spec.
	(Analyze_Subprogram_Declaration): Mark a subprogram as a private
	primitive if the type of its first parameter is a non-generic tagged
	private type.
	(Analyze_Subprogram_Specification): Code reformatting.
	(Disambiguate_Spec): New routine.
	(Find_Corresponding_Spec): Add a flag to controll the output of errors.
	(Is_Private_Concurrent_Primitive): New routine.

	* sem_ch6.ads:
	(Find_Corresponding_Spec): Add a formal to control the output of errors.

From-SVN: r138324

gcc/ada/einfo.adb

@@ -504,9 +504,8 @@ package body Einfo is
    --    Optimize_Alignment_Time         Flag242
    --    Overlays_Constant               Flag243
    --    Is_RACW_Stub_Type               Flag244
+   --    Is_Private_Primitive            Flag245
 
-   --    (unused)                        Flag169
-   --    (unused)                        Flag245
    --    (unused)                        Flag246
    --    (unused)                        Flag247
 
@@ -1929,7 +1928,8 @@ package body Einfo is
 
    function Is_Primitive_Wrapper (Id : E) return B is
    begin
-      pragma Assert (Ekind (Id) = E_Procedure);
+      pragma Assert (Ekind (Id) = E_Function
+        or else Ekind (Id) = E_Procedure);
       return Flag195 (Id);
    end Is_Primitive_Wrapper;
 
@@ -1944,6 +1944,13 @@ package body Einfo is
       return Flag53 (Id);
    end Is_Private_Descendant;
 
+   function Is_Private_Primitive (Id : E) return B is
+   begin
+      pragma Assert (Ekind (Id) = E_Function
+        or else Ekind (Id) = E_Procedure);
+      return Flag245 (Id);
+   end Is_Private_Primitive;
+
    function Is_Protected_Interface (Id : E) return B is
    begin
       pragma Assert (Is_Interface (Id));
@@ -2702,8 +2709,9 @@ package body Einfo is
 
    function Wrapped_Entity (Id : E) return E is
    begin
-      pragma Assert (Ekind (Id) = E_Procedure
-                       and then Is_Primitive_Wrapper (Id));
+      pragma Assert ((Ekind (Id) = E_Function
+          or else Ekind (Id) = E_Procedure)
+        and then Is_Primitive_Wrapper (Id));
       return Node27 (Id);
    end Wrapped_Entity;
 
@@ -4372,7 +4380,8 @@ package body Einfo is
 
    procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True) is
    begin
-      pragma Assert (Ekind (Id) = E_Procedure);
+      pragma Assert (Ekind (Id) = E_Function
+        or else Ekind (Id) = E_Procedure);
       Set_Flag195 (Id, V);
    end Set_Is_Primitive_Wrapper;
 
@@ -4387,6 +4396,13 @@ package body Einfo is
       Set_Flag53 (Id, V);
    end Set_Is_Private_Descendant;
 
+   procedure Set_Is_Private_Primitive (Id : E; V : B := True) is
+   begin
+      pragma Assert (Ekind (Id) = E_Function
+        or else Ekind (Id) = E_Procedure);
+      Set_Flag245 (Id, V);
+   end Set_Is_Private_Primitive;
+
    procedure Set_Is_Protected_Interface (Id : E; V : B := True) is
    begin
       pragma Assert (Is_Interface (Id));
@@ -5168,8 +5184,9 @@ package body Einfo is
 
    procedure Set_Wrapped_Entity (Id : E; V : E) is
    begin
-      pragma Assert (Ekind (Id) = E_Procedure
-                       and then Is_Primitive_Wrapper (Id));
+      pragma Assert ((Ekind (Id) = E_Function
+          or else Ekind (Id) = E_Procedure)
+        and then Is_Primitive_Wrapper (Id));
       Set_Node27 (Id, V);
    end Set_Wrapped_Entity;
 
@@ -7597,9 +7614,11 @@ package body Einfo is
       W ("Is_Packed_Array_Type",            Flag138 (Id));
       W ("Is_Potentially_Use_Visible",      Flag9   (Id));
       W ("Is_Preelaborated",                Flag59  (Id));
+      W ("Is_Primitive",                    Flag218 (Id));
       W ("Is_Primitive_Wrapper",            Flag195 (Id));
       W ("Is_Private_Composite",            Flag107 (Id));
       W ("Is_Private_Descendant",           Flag53  (Id));
+      W ("Is_Private_Primitive",            Flag245 (Id));
       W ("Is_Protected_Interface",          Flag198 (Id));
       W ("Is_Public",                       Flag10  (Id));
       W ("Is_Pure",                         Flag44  (Id));
@@ -7666,7 +7685,6 @@ package body Einfo is
       W ("Suppress_Init_Proc",              Flag105 (Id));
       W ("Suppress_Style_Checks",           Flag165 (Id));
       W ("Suppress_Value_Tracking_On_Call", Flag217 (Id));
-      W ("Is_Primitive",                    Flag218 (Id));
       W ("Treat_As_Volatile",               Flag41  (Id));
       W ("Universal_Aliasing",              Flag216 (Id));
       W ("Used_As_Generic_Actual",          Flag222 (Id));

gcc/ada/einfo.ads

@@ -2513,9 +2513,9 @@ package Einfo is
 --       indicators in bodies.
 
 --    Is_Primitive_Wrapper (Flag195)
---       Present in all entities. Set for procedure entries that are used as
---       primitive wrappers. which are generated by the expander to wrap
---       entries of protected or task types implementing a limited interface.
+--       Present in functions and procedures created by the expander to serve
+--       as an indirection mechanism to overriding primitives of concurrent
+--       types, entries and protected procedures.
 
 --    Is_Prival (synthesized)
 --       Applies to all entities, true for renamings of private protected
@@ -2533,6 +2533,10 @@ package Einfo is
 --       functions, procedures). Set if the library unit is itself a private
 --       child unit, or if it is the descendent of a private child unit.
 
+--    Is_Private_Primitive (Flag245)
+--       Present in subprograms. Set if the first parameter of the subprogram
+--       is of concurrent tagged type with a private view.
+
 --    Is_Private_Type (synthesized)
 --       Applies to all entities, true for private types and subtypes,
 --       as well as for record with private types as subtypes
@@ -3723,8 +3727,8 @@ package Einfo is
 --       attribute when the limited-view is installed (Ada 2005: AI-217).
 
 --    Wrapped_Entity (Node27)
---       Present in an E_Procedure classified as an Is_Primitive_Wrapper. Set
---       to the entity that is being wrapped.
+--       Present in functions and procedures which have been classified as
+--       Is_Primitive_Wrapper. Set to the entity being wrapper.
 
    ------------------
    -- Access Kinds --
@@ -5013,6 +5017,7 @@ package Einfo is
    --    Protection_Object                   (Node23)   (for concurrent kind)
    --    Interface_Alias                     (Node25)
    --    Overridden_Operation                (Node26)
+   --    Wrapped_Entity                      (Node27)   (non-generic case only)
    --    Extra_Formals                       (Node28)
    --    Body_Needed_For_SAL                 (Flag40)
    --    Elaboration_Entity_Required         (Flag174)
@@ -5039,7 +5044,9 @@ package Einfo is
    --    Is_Machine_Code_Subprogram          (Flag137)  (non-generic case only)
    --    Is_Overriding_Operation             (Flag39)   (non-generic case only)
    --    Is_Primitive                        (Flag218)
+   --    Is_Primitive_Wrapper                (Flag195)  (non-generic case only)
    --    Is_Private_Descendant               (Flag53)
+   --    Is_Private_Primitive                (Flag245)  (non-generic case only)
    --    Is_Pure                             (Flag44)
    --    Is_Thunk                            (Flag225)
    --    Is_Visible_Child_Unit               (Flag116)
@@ -5305,6 +5312,7 @@ package Einfo is
    --    Is_Primitive                        (Flag218)
    --    Is_Primitive_Wrapper                (Flag195)  (non-generic case only)
    --    Is_Private_Descendant               (Flag53)
+   --    Is_Private_Primitive                (Flag245)  (non-generic case only)
    --    Is_Pure                             (Flag44)
    --    Is_Thunk                            (Flag225)
    --    Is_Valued_Procedure                 (Flag127)
@@ -5974,6 +5982,7 @@ package Einfo is
    function Is_Primitive_Wrapper                (Id : E) return B;
    function Is_Private_Composite                (Id : E) return B;
    function Is_Private_Descendant               (Id : E) return B;
+   function Is_Private_Primitive                (Id : E) return B;
    function Is_Protected_Interface              (Id : E) return B;
    function Is_Public                           (Id : E) return B;
    function Is_Pure                             (Id : E) return B;
@@ -6538,6 +6547,7 @@ package Einfo is
    procedure Set_Is_Primitive_Wrapper            (Id : E; V : B := True);
    procedure Set_Is_Private_Composite            (Id : E; V : B := True);
    procedure Set_Is_Private_Descendant           (Id : E; V : B := True);
+   procedure Set_Is_Private_Primitive            (Id : E; V : B := True);
    procedure Set_Is_Protected_Interface          (Id : E; V : B := True);
    procedure Set_Is_Public                       (Id : E; V : B := True);
    procedure Set_Is_Pure                         (Id : E; V : B := True);
@@ -7216,6 +7226,7 @@ package Einfo is
    pragma Inline (Is_Primitive_Wrapper);
    pragma Inline (Is_Private_Composite);
    pragma Inline (Is_Private_Descendant);
+   pragma Inline (Is_Private_Primitive);
    pragma Inline (Is_Private_Type);
    pragma Inline (Is_Protected_Interface);
    pragma Inline (Is_Protected_Type);
@@ -7609,6 +7620,7 @@ package Einfo is
    pragma Inline (Set_Is_Primitive_Wrapper);
    pragma Inline (Set_Is_Private_Composite);
    pragma Inline (Set_Is_Private_Descendant);
+   pragma Inline (Set_Is_Private_Primitive);
    pragma Inline (Set_Is_Protected_Interface);
    pragma Inline (Set_Is_Public);
    pragma Inline (Set_Is_Pure);

gcc/ada/exp_ch9.ads

@@ -153,6 +153,18 @@ package Exp_Ch9 is
    --  aggregate. It replaces the call to Init (Args) done by
    --  Build_Task_Allocate_Block.
 
+   function Build_Wrapper_Spec
+     (Loc     : Source_Ptr;
+      Subp_Id : Entity_Id;
+      Obj_Typ : Entity_Id;
+      Formals : List_Id) return Node_Id;
+   --  Ada 2005 (AI-345): Build the specification of a primitive operation
+   --  associated with a protected or task type. This is required to implement
+   --  dispatching calls through interfaces. Subp_Id is the primitive to be
+   --  wrapped, Obj_Typ is the type of the newly added formal parameter to
+   --  handle object notation, Formals are the original entry formals that
+   --  will be explicitly replicated.
+
    function Concurrent_Ref (N : Node_Id) return Node_Id;
    --  Given the name of a concurrent object (task or protected object), or
    --  the name of an access to a concurrent object, this function returns an

gcc/ada/sem_ch3.adb

@@ -31,6 +31,7 @@ with Einfo;    use Einfo;
 with Errout;   use Errout;
 with Eval_Fat; use Eval_Fat;
 with Exp_Ch3;  use Exp_Ch3;
+with Exp_Ch9;  use Exp_Ch9;
 with Exp_Disp; use Exp_Disp;
 with Exp_Dist; use Exp_Dist;
 with Exp_Tss;  use Exp_Tss;
@@ -15811,48 +15812,117 @@ package body Sem_Ch3 is
       --  If the private view was tagged, copy the new primitive operations
       --  from the private view to the full view.
 
-      --  Note: Subprograms covering interface primitives were previously
-      --  propagated to the full view by Derive_Progenitor_Primitives
-
-      if Is_Tagged_Type (Full_T)
-        and then not Is_Concurrent_Type (Full_T)
-      then
+      if Is_Tagged_Type (Full_T) then
          declare
-            Priv_List : Elist_Id;
-            Full_List : constant Elist_Id := Primitive_Operations (Full_T);
-            P1, P2    : Elmt_Id;
+            Disp_Typ  : Entity_Id;
+            Full_List : Elist_Id;
             Prim      : Entity_Id;
-            D_Type    : Entity_Id;
+            Prim_Elmt : Elmt_Id;
+            Priv_List : Elist_Id;
+
+            function Contains
+              (E : Entity_Id;
+               L : Elist_Id) return Boolean;
+            --  Determine whether list L contains element E
+
+            --------------
+            -- Contains --
+            --------------
+
+            function Contains
+              (E : Entity_Id;
+               L : Elist_Id) return Boolean
+            is
+               List_Elmt : Elmt_Id;
+
+            begin
+               List_Elmt := First_Elmt (L);
+               while Present (List_Elmt) loop
+                  if Node (List_Elmt) = E then
+                     return True;
+                  end if;
+
+                  Next_Elmt (List_Elmt);
+               end loop;
+
+               return False;
+            end Contains;
+
+         --  Start of processing
 
          begin
             if Is_Tagged_Type (Priv_T) then
                Priv_List := Primitive_Operations (Priv_T);
+               Prim_Elmt := First_Elmt (Priv_List);
+
+               --  In the case of a concurrent type completing a private tagged
+               --  type, primivies may have been declared in between the two
+               --  views. These subprograms need to be wrapped the same way
+               --  entries and protected procedures are handled because they
+               --  cannot be directly shared by the two views.
+
+               if Is_Concurrent_Type (Full_T) then
+                  declare
+                     Conc_Typ  : constant Entity_Id :=
+                                   Corresponding_Record_Type (Full_T);
+                     Loc       : constant Source_Ptr := Sloc (Conc_Typ);
+                     Curr_Nod  : Node_Id := Parent (Conc_Typ);
+                     Wrap_Spec : Node_Id;
 
-               P1 := First_Elmt (Priv_List);
-               while Present (P1) loop
-                  Prim := Node (P1);
+                  begin
+                     while Present (Prim_Elmt) loop
+                        Prim := Node (Prim_Elmt);
 
-                  --  Transfer explicit primitives, not those inherited from
-                  --  parent of partial view, which will be re-inherited on
-                  --  the full view.
+                        if Comes_From_Source (Prim)
+                          and then not Is_Abstract_Subprogram (Prim)
+                        then
+                           Wrap_Spec :=
+                             Make_Subprogram_Declaration (Loc,
+                               Specification =>
+                                 Build_Wrapper_Spec (Loc,
+                                   Subp_Id => Prim,
+                                   Obj_Typ => Conc_Typ,
+                                   Formals =>
+                                     Parameter_Specifications (
+                                       Parent (Prim))));
+
+                           Insert_After (Curr_Nod, Wrap_Spec);
+                           Curr_Nod := Wrap_Spec;
+
+                           Analyze (Wrap_Spec);
+                        end if;
 
-                  if Comes_From_Source (Prim) then
-                     P2 := First_Elmt (Full_List);
-                     while Present (P2) and then Node (P2) /= Prim loop
-                        Next_Elmt (P2);
+                        Next_Elmt (Prim_Elmt);
                      end loop;
 
-                     --  If not found, that is a new one
+                     return;
+                  end;
+
+               --  For non-concurrent types, transfer explicit primitives, but
+               --  omit those inherited from the parent of the private view
+               --  since they will be re-inherited later on.
+
+               else
+                  Full_List := Primitive_Operations (Full_T);
+
+                  while Present (Prim_Elmt) loop
+                     Prim := Node (Prim_Elmt);
 
-                     if No (P2) then
+                     if Comes_From_Source (Prim)
+                       and then not Contains (Prim, Full_List)
+                     then
                         Append_Elmt (Prim, Full_List);
                      end if;
-                  end if;
 
-                  Next_Elmt (P1);
-               end loop;
+                     Next_Elmt (Prim_Elmt);
+                  end loop;
+               end if;
+
+            --  Untagged private view
 
             else
+               Full_List := Primitive_Operations (Full_T);
+
                --  In this case the partial view is untagged, so here we locate
                --  all of the earlier primitives that need to be treated as
                --  dispatching (those that appear between the two views). Note
@@ -15871,10 +15941,9 @@ package body Sem_Ch3 is
                        or else
                      Ekind (Prim) = E_Function
                   then
+                     Disp_Typ := Find_Dispatching_Type (Prim);
 
-                     D_Type := Find_Dispatching_Type (Prim);
-
-                     if D_Type = Full_T
+                     if Disp_Typ = Full_T
                        and then (Chars (Prim) /= Name_Op_Ne
                                   or else Comes_From_Source (Prim))
                      then
@@ -15887,13 +15956,13 @@ package body Sem_Ch3 is
                         end if;
 
                      elsif Is_Dispatching_Operation (Prim)
-                       and then D_Type  /= Full_T
+                       and then Disp_Typ  /= Full_T
                      then
 
                         --  Verify that it is not otherwise controlled by a
                         --  formal or a return value of type T.
 
-                        Check_Controlling_Formals (D_Type, Prim);
+                        Check_Controlling_Formals (Disp_Typ, Prim);
                      end if;
                   end if;
 

gcc/ada/sem_ch6.ads

@@ -136,8 +136,8 @@ package Sem_Ch6 is
       Get_Inst : Boolean := False) return Boolean;
    --  Check that the types of two formal parameters are conforming. In most
    --  cases this is just a name comparison, but within an instance it involves
-   --  generic actual types, and in the presence of anonymous access types
-   --  it must examine the designated types.
+   --  generic actual types, and in the presence of anonymous access types it
+   --  must examine the designated types.
 
    procedure Create_Extra_Formals (E : Entity_Id);
    --  For each parameter of a subprogram or entry that requires an additional
@@ -147,7 +147,9 @@ package Sem_Ch6 is
    --  the end of Subp's parameter list (with each subsequent extra formal
    --  being attached to the preceding extra formal).
 
-   function Find_Corresponding_Spec (N : Node_Id) return Entity_Id;
+   function Find_Corresponding_Spec
+     (N          : Node_Id;
+      Post_Error : Boolean := True) return Entity_Id;
    --  Use the subprogram specification in the body to retrieve the previous
    --  subprogram declaration, if any.