Skip to content

R
riscv-gcc-1
Commit 6ca063eb by Arnaud Charlet
Options

[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
parent b14e9388
Showing with 167 additions and 77 deletions
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;
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)));
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,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);
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));
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,
......
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);
case Nkind (N) is
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;
-- 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,
Next_Elmt (Cur);
end;
end loop;
when N_Package_Body | N_Subprogram_Body =>
declare
Entity : Node_Id := N;
-- Now traverse compilation units in order.
begin
if Nkind (Entity) = N_Subprogram_Body then
Entity := Specification (Entity);
end if;
Cur := First_Elmt (Comp_Unit_List);
while Present (Cur) loop
declare
CU : constant Node_Id := Node (Cur);
N : constant Node_Id := Unit (CU);
Entity := Defining_Entity (Entity);
begin
pragma Assert (Nkind (CU) = N_Compilation_Unit);
if Is_Generic_Instance (Entity) then
declare
Spec_Unit : constant Node_Id := Library_Unit (CU);
case Nkind (N) is
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.
-- 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.
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 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);
if Present (First_Formal (Designator)) then
elsif Present (First_Formal (Designator)) then
declare
Formal_Typ : constant Entity_Id :=
Etype (First_Formal (Designator));
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment