declare
Actuals : List_Id := No_List;
Conv_Id : Node_Id;
- First_Formal : Node_Id;
+ First_Form : Node_Id;
Formal : Node_Id;
Nam : Node_Id;
-- 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
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
-- 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 :=
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
-- 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 --
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)
-- 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;
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,
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 =>
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,
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
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);
projects / thirdparty / gcc.git / commitdiff
