[multiple changes]

2009-06-20  Ed Schonberg  <schonberg@adacore.com>

	* sem.adb (Walk_Library_Units): Check instantiations first.

	* sem_ch6.adb (Analyze_Subprogram_Declaration): Mark a subprogram as a
	private primitive if it is a function with a controlling result that is
	a type extension with progenitors.

	* exp_ch9.adb (Build_Wrapper_Spec, Build_Wrapper_Body): Handle properly
	a primitive operation of a synchronized tagged type that has a
	controlling result.

2009-06-20  Thomas Quinot  <quinot@adacore.com>

	* einfo.ads: Fix typo.

2009-06-20  Ed Falis  <falis@adacore.com>

	* s-vxwext.ads, s-vxwext-kernel.adb: Complete previous change.

From-SVN: r148743

gcc/ada/ChangeLog

+2009-06-20  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem.adb (Walk_Library_Units): Check instantiations first.
+
+	* sem_ch6.adb (Analyze_Subprogram_Declaration): Mark a subprogram as a
+	private primitive if it is a function with a controlling result that is
+	a type extension with progenitors.
+
+	* exp_ch9.adb (Build_Wrapper_Spec, Build_Wrapper_Body): Handle properly
+	a primitive operation of a synchronized tagged type that has a
+	controlling result.
+
+2009-06-20  Thomas Quinot  <quinot@adacore.com>
+
+	* einfo.ads: Fix typo.
+
+2009-06-20  Ed Falis  <falis@adacore.com>
+
+	* s-vxwext.ads, s-vxwext-kernel.adb: Complete previous change.
+
 2009-06-19  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gcc-interface/trans.c (emit_check): Do not wrap up the result

gcc/ada/einfo.ads

@@ -3647,7 +3647,7 @@ package Einfo is
 
 --    Wrapped_Entity (Node27)
 --       Present in functions and procedures which have been classified as
---       Is_Primitive_Wrapper. Set to the entity being wrapper.
+--       Is_Primitive_Wrapper. Set to the entity being wrapped.
 
    ------------------
    -- Access Kinds --

gcc/ada/exp_ch9.adb

@@ -1611,7 +1611,7 @@ package body Exp_Ch9 is
          declare
             Actuals      : List_Id := No_List;
             Conv_Id      : Node_Id;
-            First_Formal : Node_Id;
+            First_Form   : Node_Id;
             Formal       : Node_Id;
             Nam          : Node_Id;
 
@@ -1619,9 +1619,9 @@ package body Exp_Ch9 is
             --  Map formals to actuals. Use the list built for the wrapper
             --  spec, skipping the object notation parameter.
 
-            First_Formal := First (Parameter_Specifications (Body_Spec));
+            First_Form := First (Parameter_Specifications (Body_Spec));
 
-            Formal := First_Formal;
+            Formal := First_Form;
             Next (Formal);
 
             if Present (Formal) then
@@ -1637,20 +1637,29 @@ package body Exp_Ch9 is
             end if;
 
             --  Special processing for primitives declared between a private
-            --  type and its completion.
+            --  type and its completion: the wrapper needs a properly typed
+            --  parameter if the wrapped operation has a controlling first
+            --  parameter. Note that this might not be the case for a function
+            --  with a controlling result.
 
             if Is_Private_Primitive_Subprogram (Subp_Id) then
                if No (Actuals) then
                   Actuals := New_List;
                end if;
 
+               if Is_Controlling_Formal (First_Formal (Subp_Id)) then
                   Prepend_To (Actuals,
                     Unchecked_Convert_To (
                       Corresponding_Concurrent_Type (Obj_Typ),
                       Make_Identifier (Loc, Name_uO)));
 
-               Nam := New_Reference_To (Subp_Id, Loc);
+               else
+                  Prepend_To (Actuals,
+                    Make_Identifier (Loc, Chars =>
+                      Chars (Defining_Identifier (First_Form))));
+               end if;
 
+               Nam := New_Reference_To (Subp_Id, Loc);
             else
                --  An access-to-variable object parameter requires an explicit
                --  dereference in the unchecked conversion. This case occurs
@@ -1659,7 +1668,7 @@ package body Exp_Ch9 is
 
                --     O.all.Subp_Id (Formal_1, ..., Formal_N)
 
-               if Nkind (Parameter_Type (First_Formal)) =
+               if Nkind (Parameter_Type (First_Form)) =
                     N_Access_Definition
                then
                   Conv_Id :=
@@ -1679,9 +1688,26 @@ package body Exp_Ch9 is
                      New_Reference_To (Subp_Id, Loc));
             end if;
 
-            --  Create the subprogram body
+            --  Create the subprogram body. For a function, the call to the
+            --  actual subprogram has to be converted to the corresponding
+            --  record if it is a controlling result.
 
             if Ekind (Subp_Id) = E_Function then
+               declare
+                  Res : Node_Id;
+
+               begin
+                  Res :=
+                     Make_Function_Call (Loc,
+                       Name                   => Nam,
+                       Parameter_Associations => Actuals);
+
+                  if Has_Controlling_Result (Subp_Id) then
+                     Res :=
+                       Unchecked_Convert_To
+                         (Corresponding_Record_Type (Etype (Subp_Id)), Res);
+                  end if;
+
                   return
                     Make_Subprogram_Body (Loc,
                       Specification              => Body_Spec,
@@ -1689,10 +1715,8 @@ package body Exp_Ch9 is
                       Handled_Statement_Sequence =>
                         Make_Handled_Sequence_Of_Statements (Loc,
                           Statements => New_List (
-                         Make_Simple_Return_Statement (Loc,
-                           Make_Function_Call (Loc,
-                             Name                   => Nam,
-                             Parameter_Associations => Actuals)))));
+                            Make_Simple_Return_Statement (Loc, Res))));
+               end;
 
             else
                return
@@ -1819,7 +1843,8 @@ package body Exp_Ch9 is
          --  Determine whether the parameters of the generated entry wrapper
          --  and those of a primitive operation are type conformant. During
          --  this check, the first parameter of the primitive operation is
-         --  always skipped.
+         --  skipped if it is a controlling argument: protected functions
+         --  may have a controlling result.
 
          --------------------------------
          -- Type_Conformant_Parameters --
@@ -1835,9 +1860,16 @@ package body Exp_Ch9 is
             Wrapper_Typ    : Entity_Id;
 
          begin
-            --  Skip the first parameter of the primitive operation
+            --  Skip the first (controlling) parameter of primitive operation
+
+            Iface_Op_Param := First (Iface_Op_Params);
+
+            if Present (First_Formal (Iface_Op))
+              and then Is_Controlling_Formal (First_Formal (Iface_Op))
+            then
+               Iface_Op_Param := Next (Iface_Op_Param);
+            end if;
 
-            Iface_Op_Param := Next (First (Iface_Op_Params));
             Wrapper_Param  := First (Wrapper_Params);
             while Present (Iface_Op_Param)
               and then Present (Wrapper_Param)
@@ -1917,7 +1949,9 @@ package body Exp_Ch9 is
          --  Skip the object parameter when dealing with primitives declared
          --  between two views.
 
-         if Is_Private_Primitive_Subprogram (Subp_Id) then
+         if Is_Private_Primitive_Subprogram (Subp_Id)
+           and then not Has_Controlling_Result (Subp_Id)
+         then
             Formal := Next (Formal);
          end if;
 
@@ -2046,11 +2080,21 @@ package body Exp_Ch9 is
 
          New_Formals := Replicate_Formals (Loc, Formals);
 
+         --  A function with a controlling result and no first controlling
+         --  formal needs no additional parameter.
+
+         if Has_Controlling_Result (Subp_Id)
+           and then
+             (No (First_Formal (Subp_Id))
+               or else not Is_Controlling_Formal (First_Formal (Subp_Id)))
+         then
+            null;
+
          --  Routine Subp_Id has been found to override an interface primitive.
          --  If the interface operation has an access parameter, create a copy
          --  of it, with the same null exclusion indicator if present.
 
-         if Present (First_Param) then
+         elsif Present (First_Param) then
             if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then
                Obj_Param_Typ :=
                  Make_Access_Definition (Loc,
@@ -2072,11 +2116,15 @@ package body Exp_Ch9 is
                 Out_Present         => Out_Present (First_Param),
                 Parameter_Type      => Obj_Param_Typ);
 
+            Prepend_To (New_Formals, Obj_Param);
+
          --  If we are dealing with a primitive declared between two views,
-         --  create a default parameter. The mode of the parameter must
-         --  match that of the primitive operation.
+         --  implemented by a synchronized operation, we need to create
+         --  a default parameter. The mode of the parameter must match that
+         --  of the primitive operation.
 
-         else pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id));
+         else
+            pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id));
             Obj_Param :=
               Make_Parameter_Specification (Loc,
                 Defining_Identifier =>
@@ -2084,19 +2132,33 @@ package body Exp_Ch9 is
                 In_Present  => In_Present (Parent (First_Entity (Subp_Id))),
                 Out_Present => Ekind (Subp_Id) /= E_Function,
                   Parameter_Type => New_Reference_To (Obj_Typ, Loc));
-         end if;
-
             Prepend_To (New_Formals, Obj_Param);
+         end if;
 
-         --  Build the final spec
+         --  Build the final spec. If it is a function with a controlling
+         --  result, it is a primitive operation of the corresponding
+         --  record type, so mark the spec accordingly.
 
          if Ekind (Subp_Id) = E_Function then
+
+            declare
+               Res_Def : Node_Id;
+
+            begin
+               if Has_Controlling_Result (Subp_Id) then
+                  Res_Def :=
+                    New_Occurrence_Of
+                      (Corresponding_Record_Type (Etype (Subp_Id)), Loc);
+               else
+                  Res_Def := New_Copy (Result_Definition (Parent (Subp_Id)));
+               end if;
+
                return
                  Make_Function_Specification (Loc,
                    Defining_Unit_Name       => Wrapper_Id,
                    Parameter_Specifications => New_Formals,
-                Result_Definition        =>
-                  New_Copy (Result_Definition (Parent (Subp_Id))));
+                   Result_Definition        => Res_Def);
+            end;
          else
             return
               Make_Procedure_Specification (Loc,

gcc/ada/s-vxwext-kernel.adb

@@ -56,7 +56,11 @@ package body System.VxWorks.Ext is
    -- semDelete --
    ---------------
 
-   function semDelete (Sem : SEM_ID) return int;
-   pragma Import (C, semDelete, "semDelete");
+   function semDelete (Sem : SEM_ID) return int is
+      function Os_Sem_Delete (Sem : SEM_ID) return int;
+      pragma Import (C, Os_Sem_Delete, "semDelete");
+   begin
+      return Os_Sem_Delete (Sem);
+   end semDelete;
 
 end System.VxWorks.Ext;

gcc/ada/s-vxwext.ads

@@ -36,7 +36,7 @@ with Interfaces.C;
 package System.VxWorks.Ext is
    pragma Preelaborate;
 
-   type SEM_ID is new Long_Integer;
+   subtype SEM_ID is Long_Integer;
    --  typedef struct semaphore *SEM_ID;
 
    type t_id is new Long_Integer;

gcc/ada/sem.adb

@@ -1766,6 +1766,10 @@ package body Sem is
 
       Do_Action (Empty, Standard_Package_Node);
 
+      --  First place the context of all instance bodies on the corresponding
+      --  spec, because it may be needed to analyze the code at the place of
+      --  the instantiation.
+
       Cur := First_Elmt (Comp_Unit_List);
       while Present (Cur) loop
          declare
@@ -1773,43 +1777,36 @@ package body Sem is
             N  : constant Node_Id := Unit (CU);
 
          begin
-            pragma Assert (Nkind (CU) = N_Compilation_Unit);
+            if Nkind (N) = N_Package_Body
+              and then Is_Generic_Instance (Defining_Entity (N))
+            then
+               Append_List
+                 (Context_Items (CU), Context_Items (Library_Unit (CU)));
+            end if;
 
-            case Nkind (N) is
+            Next_Elmt (Cur);
+         end;
+      end loop;
 
-               --  If it's a body, then ignore it, unless it's an instance (in
-               --  which case we do the spec), or it's the main unit (in which
-               --  case we do it). Note that it could be both, in which case we
-               --  do the with_clauses of spec and body first,
+      --  Now traverse compilation units in order.
 
-               when N_Package_Body | N_Subprogram_Body =>
+      Cur := First_Elmt (Comp_Unit_List);
+      while Present (Cur) loop
          declare
-                     Entity : Node_Id := N;
+            CU : constant Node_Id := Node (Cur);
+            N  : constant Node_Id := Unit (CU);
 
          begin
-                     if Nkind (Entity) = N_Subprogram_Body then
-                        Entity := Specification (Entity);
-                     end if;
+            pragma Assert (Nkind (CU) = N_Compilation_Unit);
 
-                     Entity := Defining_Entity (Entity);
+            case Nkind (N) is
 
-                     if Is_Generic_Instance (Entity) then
-                        declare
-                           Spec_Unit : constant Node_Id := Library_Unit (CU);
+               --  If it's a body, then ignore it, unless it's the main unit
+               --  Otherwise bodies appear in the list because of inlining or
+               --  instantiations, and they are processed immediately after
+               --  the corresponding specs.
 
-                        begin
-                           --  Move context of body to that of spec, so it
-                           --  appears before the spec itself, in case it
-                           --  contains nested instances that generate late
-                           --  with_clauses that got attached to the body.
-
-                           Append_List
-                             (Context_Items (CU), Context_Items (Spec_Unit));
-                           Do_Unit_And_Dependents
-                             (Spec_Unit, Unit (Spec_Unit));
-                        end;
-                     end if;
-                  end;
+               when N_Package_Body | N_Subprogram_Body =>
 
                   if CU = Cunit (Main_Unit) then
                      Do_Unit_And_Dependents (CU, N);

gcc/ada/sem_ch6.adb

@@ -2685,11 +2685,18 @@ package body Sem_Ch6 is
       New_Overloaded_Entity (Designator);
       Check_Delayed_Subprogram (Designator);
 
-      --  If the type of the first formal of the current subprogram is a non
-      --  generic tagged private type , mark the subprogram as being a private
-      --  primitive.
+      --  If the type of the first formal of the current subprogram is a
+      --  nongeneric tagged private type, mark the subprogram as being a
+      --  private primitive. Ditto if this is a function with controlling
+      --  result, and the return type is currently private.
 
-      if Present (First_Formal (Designator)) then
+      if Has_Controlling_Result (Designator)
+        and then Is_Private_Type (Etype (Designator))
+        and then not Is_Generic_Actual_Type (Etype (Designator))
+      then
+         Set_Is_Private_Primitive (Designator);
+
+      elsif Present (First_Formal (Designator)) then
          declare
             Formal_Typ : constant Entity_Id :=
                            Etype (First_Formal (Designator));