diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b03304f1ce2..a9176b5a228 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,23 @@ +2009-06-20 Ed Schonberg + + * 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 + + * einfo.ads: Fix typo. + +2009-06-20 Ed Falis + + * s-vxwext.ads, s-vxwext-kernel.adb: Complete previous change. + 2009-06-19 Eric Botcazou * gcc-interface/trans.c (emit_check): Do not wrap up the result diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 50c1c7b1bbc..049faab5a2b 100644 --- a/gcc/ada/einfo.ads +++ b/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 -- diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index aa69402723a..cc58d9f4fa4 100644 --- a/gcc/ada/exp_ch9.adb +++ b/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; - Prepend_To (Actuals, - Unchecked_Convert_To ( - Corresponding_Concurrent_Type (Obj_Typ), - Make_Identifier (Loc, Name_uO))); + 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))); + + 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,20 +1688,35 @@ 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 - return - Make_Subprogram_Body (Loc, - Specification => Body_Spec, - Declarations => Empty_List, - 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))))); + 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, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + 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); - -- 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. + Prepend_To (New_Formals, Obj_Param); - else pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id)); + -- If we are dealing with a primitive declared between two views, + -- 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)); 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)); + Prepend_To (New_Formals, Obj_Param); end if; - Prepend_To (New_Formals, Obj_Param); - - -- 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 - return - Make_Function_Specification (Loc, - Defining_Unit_Name => Wrapper_Id, - Parameter_Specifications => New_Formals, - Result_Definition => - New_Copy (Result_Definition (Parent (Subp_Id)))); + + 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 => Res_Def); + end; else return Make_Procedure_Specification (Loc, diff --git a/gcc/ada/s-vxwext-kernel.adb b/gcc/ada/s-vxwext-kernel.adb index 0c5fea59565..ad609f3cf81 100644 --- a/gcc/ada/s-vxwext-kernel.adb +++ b/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; diff --git a/gcc/ada/s-vxwext.ads b/gcc/ada/s-vxwext.ads index 6f17b41f8da..bc458395c8b 100644 --- a/gcc/ada/s-vxwext.ads +++ b/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; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 58521e9c727..dad352b03d4 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -1766,6 +1766,30 @@ 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 + CU : constant Node_Id := Node (Cur); + N : constant Node_Id := Unit (CU); + + begin + 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; + + Next_Elmt (Cur); + end; + end loop; + + -- Now traverse compilation units in order. + Cur := First_Elmt (Comp_Unit_List); while Present (Cur) loop declare @@ -1777,39 +1801,12 @@ package body Sem is case Nkind (N) is - -- 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, + -- 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. when N_Package_Body | N_Subprogram_Body => - declare - Entity : Node_Id := N; - - begin - if Nkind (Entity) = N_Subprogram_Body then - Entity := Specification (Entity); - end if; - - Entity := Defining_Entity (Entity); - - if Is_Generic_Instance (Entity) then - declare - Spec_Unit : constant Node_Id := Library_Unit (CU); - - 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; if CU = Cunit (Main_Unit) then Do_Unit_And_Dependents (CU, N); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index b51128705ae..b1f202c3652 100644 --- a/gcc/ada/sem_ch6.adb +++ b/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));