-- an alias of a predefined dispatching primitive (i.e. through a renaming)
function New_Value (From : Node_Id) return Node_Id;
- -- From is the original Expression. New_Value is equivalent to a call
- -- to Duplicate_Subexpr with an explicit dereference when From is an
- -- access parameter.
+ -- From is the original Expression. New_Value is equivalent to a call to
+ -- Duplicate_Subexpr with an explicit dereference when From is an access
+ -- parameter.
function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
- -- Check if the type has a private view or if the public view appears
- -- in the visible part of a package spec.
+ -- Check if the type has a private view or if the public view appears in
+ -- the visible part of a package spec.
function Prim_Op_Kind
(Prim : Entity_Id;
return;
end if;
- -- Apply_Tag_Checks is called directly from the semantics, so we need
- -- a check to see whether expansion is active before proceeding. In
- -- addition, there is no need to expand the call when compiling under
- -- restriction No_Dispatching_Calls; the semantic analyzer has
+ -- Apply_Tag_Checks is called directly from the semantics, so we
+ -- need a check to see whether expansion is active before proceeding.
+ -- In addition, there is no need to expand the call when compiling
+ -- under restriction No_Dispatching_Calls; the semantic analyzer has
-- previously notified the violation of this restriction.
if not Expander_Active
elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
null;
- -- "=" is the only dispatching operation allowed to get
- -- operands with incompatible tags (it just returns false).
- -- We use Duplicate_Subexpr_Move_Checks instead of calling
- -- Relocate_Node because the value will be duplicated to
- -- check the tags.
+ -- "=" is the only dispatching operation allowed to get operands
+ -- with incompatible tags (it just returns false). We use
+ -- Duplicate_Subexpr_Move_Checks instead of calling Relocate_Node
+ -- because the value will be duplicated to check the tags.
elsif Subp = Eq_Prim_Op then
null;
else
-- Generate code for tag equality check
+
-- Perhaps should have Checks.Apply_Tag_Equality_Check???
Insert_Action (Ctrl_Arg,
Build_Dispatch_Tables
(Declarations (Proper_Body (Unit (Library_Unit (D)))));
- -- Handle full type declarations and derivations of library
- -- level tagged types
+ -- Handle full type declarations and derivations of library level
+ -- tagged types
elsif Nkind_In (D, N_Full_Type_Declaration,
N_Derived_Type_Definition)
Set_Can_Never_Be_Null (Anon_Type);
-- Decorate the size and alignment attributes of the anonymous access
- -- type, as required by gigi.
+ -- type, as required by the back end.
Layout_Type (Anon_Type);
CPP_Typ := Enclosing_CPP_Parent (Typ);
Tag_Comp := First_Tag_Component (CPP_Typ);
- -- If the number of primitives is already set in the tag component
- -- then use it
+ -- If number of primitives already set in the tag component, use it
if Present (Tag_Comp)
and then DT_Entry_Count (Tag_Comp) /= No_Uint
return;
end if;
- -- Expand_Dispatching_Call is called directly from the semantics,
- -- so we only proceed if the expander is active.
+ -- Expand_Dispatching_Call is called directly from the semantics, so we
+ -- only proceed if the expander is active.
if not Expander_Active
Set_SCIL_Node (SCIL_Related_Node, SCIL_Node);
end if;
- -- Suppress all checks during the analysis of the expanded code
- -- to avoid the generation of spurious warnings under ZFP run-time.
+ -- Suppress all checks during the analysis of the expanded code to avoid
+ -- the generation of spurious warnings under ZFP run-time.
Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks);
end Expand_Dispatching_Call;
Analyze (N);
- -- If the target is a class-wide interface we change the type of the
- -- data returned by IW_Convert to indicate that this is a dispatching
- -- call.
+ -- If target is a class-wide interface, change the type of the data
+ -- returned by IW_Convert to indicate this is a dispatching call.
declare
New_Itype : Entity_Id;
if not Is_Access_Type (Etype (N)) then
- -- Statically displace the pointer to the object to reference
- -- the component containing the secondary dispatch table.
+ -- Statically displace the pointer to the object to reference the
+ -- component containing the secondary dispatch table.
Rewrite (N,
Convert_Tag_To_Interface (Class_Wide_Type (Iface_Typ),
Make_Simple_Return_Statement (Loc,
Unchecked_Convert_To (Etype (N),
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
- Prefix =>
+ Prefix =>
Unchecked_Convert_To
(Defining_Identifier (New_Typ_Decl),
Make_Identifier (Loc, Name_uO)),
(RTE (RE_Null_Address), Loc)),
Then_Statements => New_List (
- Make_Simple_Return_Statement (Loc,
- Make_Null (Loc))),
+ Make_Simple_Return_Statement (Loc, Make_Null (Loc))),
Else_Statements => Stats));
end if;
if Actual_Typ = Formal_Typ then
null;
- -- No need to displace the pointer if the interface type is
- -- a parent of the type of the actual because in this case the
+ -- No need to displace the pointer if the interface type is a
+ -- parent of the type of the actual because in this case the
-- interface primitives are located in the primary dispatch table.
elsif Is_Ancestor (Formal_Typ, Actual_Typ,
then
null;
- -- Implicit conversion to the class-wide formal type to force
- -- the displacement of the pointer.
+ -- Implicit conversion to the class-wide formal type to force the
+ -- displacement of the pointer.
else
-- Normally, expansion of actuals for calls to build-in-place
if From_Limited_With (Actual_Typ) then
- -- If the type of the actual parameter comes from a limited
- -- with-clause and the non-limited view is already available
- -- we replace the anonymous access type by a duplicate
- -- declaration whose designated type is the non-limited view
+ -- If the type of the actual parameter comes from a
+ -- limited with-clause and the non-limited view is already
+ -- available, we replace the anonymous access type by
+ -- a duplicate declaration whose designated type is the
+ -- non-limited view.
if Ekind (Actual_DDT) = E_Incomplete_Type
and then Present (Non_Limited_View (Actual_DDT))
Thunk_Code :=
Make_Subprogram_Body (Loc,
- Specification =>
+ Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Thunk_Id,
Parameter_Specifications => Formals,
Result_Definition => Result_Def),
- Declarations => Decl,
+ Declarations => Decl,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
E := Next_Entity (Typ);
while Present (E) loop
- if Ekind (E) = E_Function
- and then Is_Constructor (E)
- then
+ if Ekind (E) = E_Function and then Is_Constructor (E) then
return True;
end if;
function Has_DT (Typ : Entity_Id) return Boolean is
begin
return not Is_Interface (Typ)
- and then not Restriction_Active (No_Dispatching_Calls);
+ and then not Restriction_Active (No_Dispatching_Calls);
end Has_DT;
----------------------------------
begin
-- In VM targets we don't restrict the functionality of this test to
-- compiling in Ada 2005 mode since in VM targets any tagged type has
- -- these primitives
+ -- these primitives.
return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion)
- and then (Chars (E) = Name_uDisp_Asynchronous_Select or else
- Chars (E) = Name_uDisp_Conditional_Select or else
- Chars (E) = Name_uDisp_Get_Prim_Op_Kind or else
- Chars (E) = Name_uDisp_Get_Task_Id or else
- Chars (E) = Name_uDisp_Requeue or else
- Chars (E) = Name_uDisp_Timed_Select);
+ and then Nam_In (Chars (E), Name_uDisp_Asynchronous_Select,
+ Name_uDisp_Conditional_Select,
+ Name_uDisp_Get_Prim_Op_Kind,
+ Name_uDisp_Get_Task_Id,
+ Name_uDisp_Requeue,
+ Name_uDisp_Timed_Select);
end Is_Predefined_Interface_Primitive;
----------------------------------------
if Is_Interface (Typ) then
return
Make_Subprogram_Body (Loc,
- Specification => Make_Disp_Asynchronous_Select_Spec (Typ),
- Declarations => New_List,
+ Specification =>
+ Make_Disp_Asynchronous_Select_Spec (Typ),
+ Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- New_List (Make_Assignment_Statement (Loc,
- Name => Make_Identifier (Loc, Name_uF),
- Expression => New_Occurrence_Of (Standard_False, Loc)))));
+ New_List (
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Occurrence_Of (Standard_False, Loc)))));
end if;
if Is_Concurrent_Record_Type (Typ) then
else
Tag_Node :=
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
+ Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Tag);
end if;
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uI),
- Object_Definition =>
+ Object_Definition =>
New_Occurrence_Of (Standard_Integer, Loc),
- Expression =>
+ Expression =>
Make_Function_Call (Loc,
- Name =>
+ Name =>
New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
Parameter_Associations =>
- New_List (
- Tag_Node,
- Make_Identifier (Loc, Name_uS)))));
+ New_List (Tag_Node, Make_Identifier (Loc, Name_uS)))));
if Ekind (Conc_Typ) = E_Protected_Type then
Com_Block := Make_Temporary (Loc, 'B');
Append_To (Decls,
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Com_Block,
- Object_Definition =>
+ Defining_Identifier => Com_Block,
+ Object_Definition =>
New_Occurrence_Of (RTE (RE_Communication_Block), Loc)));
-- Build T._object'Access for calls below
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc),
Parameter_Associations =>
New_List (
Expression =>
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark =>
- New_Occurrence_Of (
- RTE (RE_Dummy_Communication_Block), Loc),
- Expression =>
- New_Occurrence_Of (Com_Block, Loc))));
+ New_Occurrence_Of
+ (RTE (RE_Dummy_Communication_Block), Loc),
+ Expression => New_Occurrence_Of (Com_Block, Loc))));
-- Generate:
-- F := False;
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc),
Parameter_Associations =>
New_List (
Make_Unchecked_Type_Conversion (Loc, -- entry index
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
- Expression => Make_Identifier (Loc, Name_uI)),
+ Expression => Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
New_Occurrence_Of -- Asynchronous_Call
Append_List_To (Params, New_List (
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uT),
- Parameter_Type =>
- New_Occurrence_Of (Typ, Loc),
- In_Present => True,
- Out_Present => True),
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
+ Parameter_Type => New_Occurrence_Of (Typ, Loc),
+ In_Present => True,
+ Out_Present => True),
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uS),
- Parameter_Type =>
- New_Occurrence_Of (Standard_Integer, Loc)),
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
+ Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uP),
- Parameter_Type =>
- New_Occurrence_Of (RTE (RE_Address), Loc)),
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
+ Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uB),
- Parameter_Type =>
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uB),
+ Parameter_Type =>
New_Occurrence_Of (RTE (RE_Dummy_Communication_Block), Loc),
- Out_Present => True),
+ Out_Present => True),
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uF),
- Parameter_Type =>
- New_Occurrence_Of (Standard_Boolean, Loc),
- Out_Present => True)));
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF),
+ Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
+ Out_Present => True)));
return
Make_Procedure_Specification (Loc,
if Is_Interface (Typ) then
return
Make_Subprogram_Body (Loc,
- Specification =>
+ Specification =>
Make_Disp_Conditional_Select_Spec (Typ),
- Declarations =>
- No_List,
+ Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
New_List (Make_Assignment_Statement (Loc,
Append_To (Decls,
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uI),
- Object_Definition =>
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI),
+ Object_Definition =>
New_Occurrence_Of (Standard_Integer, Loc)));
-- Generate:
Blk_Nam := Make_Temporary (Loc, 'B');
Append_To (Decls,
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Blk_Nam,
- Object_Definition =>
+ Defining_Identifier => Blk_Nam,
+ Object_Definition =>
New_Occurrence_Of (RTE (RE_Communication_Block), Loc)));
-- Generate:
else
Tag_Node :=
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
+ Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Tag);
end if;
Append_To (Stmts,
Make_Assignment_Statement (Loc,
- Name => Make_Identifier (Loc, Name_uI),
+ Name => Make_Identifier (Loc, Name_uI),
Expression =>
Make_Function_Call (Loc,
- Name =>
+ Name =>
New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
- Parameter_Associations =>
- New_List (
- Tag_Node,
- Make_Identifier (Loc, Name_uS)))));
+ Parameter_Associations => New_List (
+ Tag_Node,
+ Make_Identifier (Loc, Name_uS)))));
if Ekind (Conc_Typ) = E_Protected_Type then
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
+ Parameter_Associations => New_List (
Obj_Ref,
Make_Unchecked_Type_Conversion (Loc, -- entry index
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Occurrence_Of
(RTE (RE_Protected_Single_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
+ Parameter_Associations => New_List (
Obj_Ref,
Make_Attribute_Reference (Loc,
Make_Op_Not (Loc,
Right_Opnd =>
Make_Function_Call (Loc,
- Name =>
+ Name =>
New_Occurrence_Of (RTE (RE_Cancelled), Loc),
- Parameter_Associations =>
- New_List (
+ Parameter_Associations => New_List (
New_Occurrence_Of (Blk_Nam, Loc))))));
else
pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
+ Parameter_Associations => New_List (
Make_Selected_Component (Loc, -- T._task_id
Prefix => Make_Identifier (Loc, Name_uT),
Append_List_To (Params, New_List (
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uT),
- Parameter_Type =>
- New_Occurrence_Of (Typ, Loc),
- In_Present => True,
- Out_Present => True),
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
+ Parameter_Type => New_Occurrence_Of (Typ, Loc),
+ In_Present => True,
+ Out_Present => True),
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uS),
- Parameter_Type =>
- New_Occurrence_Of (Standard_Integer, Loc)),
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
+ Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uP),
- Parameter_Type =>
- New_Occurrence_Of (RTE (RE_Address), Loc)),
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
+ Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uC),
- Parameter_Type =>
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC),
+ Parameter_Type =>
New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc),
- Out_Present => True),
+ Out_Present => True),
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uF),
- Parameter_Type =>
- New_Occurrence_Of (Standard_Boolean, Loc),
- Out_Present => True)));
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF),
+ Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
+ Out_Present => True)));
return
Make_Procedure_Specification (Loc,
-- Make_Disp_Get_Prim_Op_Kind_Body --
-------------------------------------
- function Make_Disp_Get_Prim_Op_Kind_Body
- (Typ : Entity_Id) return Node_Id
- is
+ function Make_Disp_Get_Prim_Op_Kind_Body (Typ : Entity_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Tag_Node : Node_Id;
if Is_Interface (Typ) then
return
Make_Subprogram_Body (Loc,
- Specification =>
+ Specification =>
Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
- Declarations =>
- New_List,
+ Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
New_List (Make_Null_Statement (Loc))));
else
Tag_Node :=
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
+ Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Tag);
end if;
return
Make_Subprogram_Body (Loc,
- Specification =>
+ Specification =>
Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
- Declarations =>
- New_List,
+ Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
New_List (
Make_Assignment_Statement (Loc,
- Name =>
- Make_Identifier (Loc, Name_uC),
+ Name => Make_Identifier (Loc, Name_uC),
Expression =>
Make_Function_Call (Loc,
Name =>
is
Loc : constant Source_Ptr := Sloc (Typ);
Def_Id : constant Node_Id :=
- Make_Defining_Identifier (Loc,
- Name_uDisp_Get_Prim_Op_Kind);
+ Make_Defining_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind);
Params : constant List_Id := New_List;
begin
Append_List_To (Params, New_List (
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uT),
- Parameter_Type =>
- New_Occurrence_Of (Typ, Loc),
- In_Present => True,
- Out_Present => True),
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
+ Parameter_Type => New_Occurrence_Of (Typ, Loc),
+ In_Present => True,
+ Out_Present => True),
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uS),
- Parameter_Type =>
- New_Occurrence_Of (Standard_Integer, Loc)),
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
+ Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uC),
- Parameter_Type =>
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC),
+ Parameter_Type =>
New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc),
- Out_Present => True)));
+ Out_Present => True)));
return
Make_Procedure_Specification (Loc,
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Address), Loc),
- Expression =>
+ Subtype_Mark => New_Occurrence_Of (RTE (RE_Address), Loc),
+ Expression =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uT),
Selector_Name => Make_Identifier (Loc, Name_uTask_Id))));
Ret :=
Make_Simple_Return_Statement (Loc,
- Expression =>
- New_Occurrence_Of (RTE (RE_Null_Address), Loc));
+ Expression => New_Occurrence_Of (RTE (RE_Null_Address), Loc));
end if;
return
Make_Subprogram_Body (Loc,
- Specification =>
- Make_Disp_Get_Task_Id_Spec (Typ),
- Declarations =>
- New_List,
+ Specification => Make_Disp_Get_Task_Id_Spec (Typ),
+ Declarations => New_List,
Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- New_List (Ret)));
+ Make_Handled_Sequence_Of_Statements (Loc, New_List (Ret)));
end Make_Disp_Get_Task_Id_Body;
--------------------------------
return
Make_Function_Specification (Loc,
- Defining_Unit_Name =>
+ Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id),
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uT),
- Parameter_Type =>
- New_Occurrence_Of (Typ, Loc))),
- Result_Definition =>
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
+ Parameter_Type => New_Occurrence_Of (Typ, Loc))),
+ Result_Definition =>
New_Occurrence_Of (RTE (RE_Address), Loc));
end Make_Disp_Get_Task_Id_Spec;
then
return
Make_Subprogram_Body (Loc,
- Specification =>
- Make_Disp_Requeue_Spec (Typ),
- Declarations =>
- No_List,
+ Specification => Make_Disp_Requeue_Spec (Typ),
+ Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
New_List (Make_Null_Statement (Loc))));
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Occurrence_Of (
- RTE (RE_Requeue_Protected_Entry), Loc),
+ New_Occurrence_Of
+ (RTE (RE_Requeue_Protected_Entry), Loc),
Parameter_Associations =>
New_List (
Make_Attribute_Reference (Loc, -- O._object'Acc
Attribute_Name =>
Name_Unchecked_Access,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uO),
Make_Unchecked_Type_Conversion (Loc, -- entry index
Subtype_Mark =>
- New_Occurrence_Of (
- RTE (RE_Protected_Entry_Index), Loc),
+ New_Occurrence_Of
+ (RTE (RE_Protected_Entry_Index), Loc),
Expression => Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uA)))), -- abort status
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Occurrence_Of (
- RTE (RE_Requeue_Task_To_Protected_Entry), Loc),
+ New_Occurrence_Of
+ (RTE (RE_Requeue_Task_To_Protected_Entry), Loc),
Parameter_Associations =>
New_List (
Make_Attribute_Reference (Loc, -- O._object'Acc
- Attribute_Name =>
- Name_Unchecked_Access,
- Prefix =>
+ Attribute_Name => Name_Unchecked_Access,
+ Prefix =>
Make_Selected_Component (Loc,
- Prefix =>
+ Prefix =>
Make_Identifier (Loc, Name_uO),
Selector_Name =>
Make_Identifier (Loc, Name_uObject))),
Make_Unchecked_Type_Conversion (Loc, -- entry index
Subtype_Mark =>
- New_Occurrence_Of (
- RTE (RE_Protected_Entry_Index), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uI)),
+ New_Occurrence_Of
+ (RTE (RE_Protected_Entry_Index), Loc),
+ Expression => Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uA)))))); -- abort status
end if;
+
else
pragma Assert (Is_Task_Type (Conc_Typ));
-- Call to Requeue_Task_Entry
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc),
+ Name =>
+ New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc),
Parameter_Associations => New_List (
return
Make_Subprogram_Body (Loc,
- Specification =>
- Make_Disp_Requeue_Spec (Typ),
- Declarations =>
- New_List,
+ Specification => Make_Disp_Requeue_Spec (Typ),
+ Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts));
end Make_Disp_Requeue_Body;
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Name_uDisp_Requeue),
- Parameter_Specifications =>
- New_List (
+ Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc, -- O
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uO),
- Parameter_Type =>
+ Parameter_Type =>
New_Occurrence_Of (Typ, Loc),
- In_Present => True,
- Out_Present => True),
+ In_Present => True,
+ Out_Present => True),
Make_Parameter_Specification (Loc, -- F
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uF),
- Parameter_Type =>
+ Parameter_Type =>
New_Occurrence_Of (Standard_Boolean, Loc)),
Make_Parameter_Specification (Loc, -- P
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uP),
- Parameter_Type =>
+ Parameter_Type =>
New_Occurrence_Of (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc, -- I
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uI),
- Parameter_Type =>
+ Parameter_Type =>
New_Occurrence_Of (Standard_Integer, Loc)),
Make_Parameter_Specification (Loc, -- A
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uA),
- Parameter_Type =>
+ Parameter_Type =>
New_Occurrence_Of (Standard_Boolean, Loc))));
end Make_Disp_Requeue_Spec;
if Is_Interface (Typ) then
return
Make_Subprogram_Body (Loc,
- Specification =>
- Make_Disp_Timed_Select_Spec (Typ),
- Declarations =>
- New_List,
+ Specification => Make_Disp_Timed_Select_Spec (Typ),
+ Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
New_List (
Expression =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
- Parameter_Associations =>
- New_List (
- Tag_Node,
- Make_Identifier (Loc, Name_uS)))));
+ Parameter_Associations => New_List (
+ Tag_Node,
+ Make_Identifier (Loc, Name_uS)))));
-- Protected case
Name =>
New_Occurrence_Of
(RTE (RE_Timed_Protected_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
- Obj_Ref,
+ Parameter_Associations => New_List (
+ Obj_Ref,
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Occurrence_Of
- (RTE (RE_Protected_Entry_Index), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uI)),
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Occurrence_Of
+ (RTE (RE_Protected_Entry_Index), Loc),
+ Expression => Make_Identifier (Loc, Name_uI)),
- Make_Identifier (Loc, Name_uP), -- parameter block
- Make_Identifier (Loc, Name_uD), -- delay
- Make_Identifier (Loc, Name_uM), -- delay mode
- Make_Identifier (Loc, Name_uF)))); -- status flag
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ Make_Identifier (Loc, Name_uD), -- delay
+ Make_Identifier (Loc, Name_uM), -- delay mode
+ Make_Identifier (Loc, Name_uF)))); -- status flag
when others =>
raise Program_Error;
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
- Make_Selected_Component (Loc, -- T._task_id
- Prefix => Make_Identifier (Loc, Name_uT),
- Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
+ Parameter_Associations => New_List (
+ Make_Selected_Component (Loc, -- T._task_id
+ Prefix => Make_Identifier (Loc, Name_uT),
+ Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
- Expression => Make_Identifier (Loc, Name_uI)),
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
+ Expression => Make_Identifier (Loc, Name_uI)),
- Make_Identifier (Loc, Name_uP), -- parameter block
- Make_Identifier (Loc, Name_uD), -- delay
- Make_Identifier (Loc, Name_uM), -- delay mode
- Make_Identifier (Loc, Name_uF)))); -- status flag
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ Make_Identifier (Loc, Name_uD), -- delay
+ Make_Identifier (Loc, Name_uM), -- delay mode
+ Make_Identifier (Loc, Name_uF)))); -- status flag
end if;
else
Append_List_To (Params, New_List (
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uT),
- Parameter_Type =>
- New_Occurrence_Of (Typ, Loc),
- In_Present => True,
- Out_Present => True),
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
+ Parameter_Type => New_Occurrence_Of (Typ, Loc),
+ In_Present => True,
+ Out_Present => True),
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uS),
- Parameter_Type =>
- New_Occurrence_Of (Standard_Integer, Loc)),
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
+ Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uP),
- Parameter_Type =>
- New_Occurrence_Of (RTE (RE_Address), Loc)),
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
+ Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uD),
- Parameter_Type =>
- New_Occurrence_Of (Standard_Duration, Loc)),
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uD),
+ Parameter_Type => New_Occurrence_Of (Standard_Duration, Loc)),
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uM),
- Parameter_Type =>
- New_Occurrence_Of (Standard_Integer, Loc)),
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uM),
+ Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uC),
- Parameter_Type =>
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC),
+ Parameter_Type =>
New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc),
- Out_Present => True)));
+ Out_Present => True)));
Append_To (Params,
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uF),
- Parameter_Type =>
- New_Occurrence_Of (Standard_Boolean, Loc),
- Out_Present => True));
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF),
+ Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
+ Out_Present => True));
return
Make_Procedure_Specification (Loc,
-------------
-- The frontend supports two models for expanding dispatch tables
- -- associated with library-level defined tagged types: statically
- -- and non-statically allocated dispatch tables. In the former case
- -- the object containing the dispatch table is constant and it is
- -- initialized by means of a positional aggregate. In the latter case,
- -- the object containing the dispatch table is a variable which is
- -- initialized by means of assignments.
+ -- associated with library-level defined tagged types: statically and
+ -- non-statically allocated dispatch tables. In the former case the object
+ -- containing the dispatch table is constant and it is initialized by means
+ -- of a positional aggregate. In the latter case, the object containing
+ -- the dispatch table is a variable which is initialized by means of
+ -- assignments.
-- In case of locally defined tagged types, the object containing the
- -- object containing the dispatch table is always a variable (instead
- -- of a constant). This is currently required to give support to late
- -- overriding of primitives. For example:
+ -- object containing the dispatch table is always a variable (instead of a
+ -- constant). This is currently required to give support to late overriding
+ -- of primitives. For example:
-- procedure Example is
-- package Pkg is
or else not Used_As_Generic_Actual (T)
then
return False;
-
else
Gen_Par := Generic_Parent (Parent (Current_Scope));
end if;
F :=
First
(Generic_Formal_Declarations
- (Unit_Declaration_Node (Gen_Par)));
+ (Unit_Declaration_Node (Gen_Par)));
while Present (F) loop
if Ekind (Defining_Identifier (F)) = E_Incomplete_Type then
return True;
Error_Msg_NE
("declaration must appear after completion of type &", N, Typ);
Error_Msg_NE
- ("\which is an untagged type in the profile of"
- & " primitive operation & declared#", N, Subp);
+ ("\which is an untagged type in the profile of "
+ & "primitive operation & declared#", N, Subp);
else
Comp := Private_Component (Typ);
if not Is_Tagged_Type (Typ)
and then Present (Comp)
and then not Is_Frozen (Comp)
- and then
- not Is_Actual_For_Formal_Incomplete_Type (Comp)
+ and then not Is_Actual_For_Formal_Incomplete_Type (Comp)
then
Error_Msg_Sloc := Sloc (Subp);
Error_Msg_Node_2 := Subp;
Error_Msg_Name_1 := Chars (Tagged_Type);
Error_Msg_NE
("declaration must appear after completion of type &",
- N, Comp);
+ N, Comp);
Error_Msg_NE
- ("\which is a component of untagged type& in the profile of"
- & " primitive & of type % that is frozen by the declaration ",
- N, Typ);
+ ("\which is a component of untagged type& in the profile "
+ & "of primitive & of type % that is frozen by the "
+ & "declaration ", N, Typ);
end if;
end if;
end Check_Premature_Freezing;
end loop;
New_Node :=
- Make_Aggregate (Loc,
- Expressions => Prim_Ops_Aggr_List);
+ Make_Aggregate (Loc, Expressions => Prim_Ops_Aggr_List);
-- Remember aggregates initializing dispatch tables
Append_To (DT_Aggr_List,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Predef_Prims, Loc),
+ Prefix => New_Occurrence_Of (Predef_Prims, Loc),
Attribute_Name => Name_Address));
-- Note: The correct value of Offset_To_Top will be set by the init
Append_To (OSD_Aggr_List,
Make_Component_Association (Loc,
- Choices => New_List (
+ Choices => New_List (
Make_Integer_Literal (Loc,
DT_Position (Prim_Alias))),
Expression =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Object_Specific_Data), Loc),
- Constraint =>
+ Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Integer_Literal (Loc, Nb_Prim)))),
Make_Aggregate (Loc,
Component_Associations => New_List (
Make_Component_Association (Loc,
- Choices => New_List (
+ Choices => New_List (
New_Occurrence_Of
(RTE_Record_Component (RE_OSD_Num_Prims), Loc)),
Expression =>
Make_Integer_Literal (Loc, Nb_Prim)),
Make_Component_Association (Loc,
- Choices => New_List (
+ Choices => New_List (
New_Occurrence_Of
(RTE_Record_Component (RE_OSD_Table), Loc)),
Expression => Make_Aggregate (Loc,
Chars => Name_Alignment,
Expression =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
Append_To (DT_Aggr_List,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (OSD, Loc),
+ Prefix => New_Occurrence_Of (OSD, Loc),
Attribute_Name => Name_Address));
end if;
-- Build the secondary table containing pointers to thunks
Make_Secondary_DT
- (Typ => Typ,
- Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))),
- Suffix_Index => Suffix_Index,
- Num_Iface_Prims => UI_To_Int
- (DT_Entry_Count (Node (AI_Tag_Comp))),
- Iface_DT_Ptr => Node (AI_Tag_Elmt),
+ (Typ => Typ,
+ Iface => Base_Type
+ (Related_Type (Node (AI_Tag_Comp))),
+ Suffix_Index => Suffix_Index,
+ Num_Iface_Prims => UI_To_Int
+ (DT_Entry_Count (Node (AI_Tag_Comp))),
+ Iface_DT_Ptr => Node (AI_Tag_Elmt),
Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
- Build_Thunks => True,
- Result => Result);
+ Build_Thunks => True,
+ Result => Result);
-- Skip secondary dispatch table referencing thunks to predefined
-- primitives.
Chars => Name_Alignment,
Expression =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
+ Prefix => New_Occurrence_Of (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
Attribute_Name => Name_Address))));
Set_Is_Statically_Allocated (DT_Ptr,
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Dispatch_Table_Wrapper), Loc),
- Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => DT_Constr_List))));
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => DT_Constr_List))));
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Chars => Name_Alignment,
Expression =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+ Prefix => New_Occurrence_Of (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Prims_Ptr), Loc)),
Attribute_Name => Name_Address))));
Set_Is_Statically_Allocated (DT_Ptr,
Defining_Identifier =>
Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))),
Constant_Present => True,
- Object_Definition => New_Occurrence_Of
- (RTE (RE_Address), Loc),
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Address), Loc),
Expression =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Predef_Prims), Loc)),
+ Prefix => New_Occurrence_Of (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Predef_Prims), Loc)),
Attribute_Name => Name_Address)));
end if;
end if;
Object_Definition => New_Occurrence_Of (Standard_String, Loc),
Expression =>
Make_String_Literal (Loc,
- Fully_Qualified_Name_String (First_Subtype (Typ)))));
-
+ Strval => Fully_Qualified_Name_String (First_Subtype (Typ)))));
Set_Is_Statically_Allocated (Exname);
Set_Is_True_Constant (Exname);
else
Append_To (TSD_Aggr_List,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
+ Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Alignment));
end if;
and then not Has_External_Tag_Rep_Clause (Typ)
then
declare
- Exname : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_External_Name (Tname, 'A'));
-
- Full_Name : constant String_Id :=
+ Exname : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Tname, 'A'));
+ Full_Name : constant String_Id :=
Fully_Qualified_Name_String (First_Subtype (Typ));
- Str1_Id : String_Id;
- Str2_Id : String_Id;
+ Str1_Id : String_Id;
+ Str2_Id : String_Id;
begin
-- Generate:
(Standard_String, Loc),
Expression =>
Make_Op_Concat (Loc,
- Left_Opnd =>
- Make_String_Literal (Loc, Str1_Id),
+ Left_Opnd => Make_String_Literal (Loc, Str1_Id),
Right_Opnd =>
Make_Op_Concat (Loc,
- Left_Opnd =>
+ Left_Opnd =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of
Make_Object_Declaration (Loc,
Defining_Identifier => Exname,
Constant_Present => True,
- Object_Definition => New_Occurrence_Of
- (Standard_String, Loc),
- Expression =>
+ Object_Definition =>
+ New_Occurrence_Of (Standard_String, Loc),
+ Expression =>
Make_Op_Concat (Loc,
- Left_Opnd =>
- Make_String_Literal (Loc, Str1_Id),
- Right_Opnd =>
- Make_String_Literal (Loc, Str2_Id))));
+ Left_Opnd => Make_String_Literal (Loc, Str1_Id),
+ Right_Opnd => Make_String_Literal (Loc, Str2_Id))));
end if;
New_Node :=
Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Exname, Loc),
+ Prefix => New_Occurrence_Of (Exname, Loc),
Attribute_Name => Name_Address));
end;
New_Node :=
Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (E, Loc),
+ Prefix => New_Occurrence_Of (E, Loc),
Attribute_Name => Name_Address));
end if;
end;
Append_To (TSD_Aggr_List,
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (HT_Link, Loc),
+ Prefix => New_Occurrence_Of (HT_Link, Loc),
Attribute_Name => Name_Address)));
else
Append_To (TSD_Aggr_List,
or else Is_Shared_Passive (Typ)
or else
((Is_Remote_Types (Typ)
- or else Is_Remote_Call_Interface (Typ))
+ or else Is_Remote_Call_Interface (Typ))
and then Original_View_In_Visible_Part (Typ))
or else not Comes_From_Source (Typ));
if RTE_Record_Component_Available (RE_Type_Is_Abstract) then
declare
Type_Is_Abstract : Entity_Id;
-
begin
- Type_Is_Abstract :=
- Boolean_Literals (Is_Abstract_Type (Typ));
-
+ Type_Is_Abstract := Boolean_Literals (Is_Abstract_Type (Typ));
Append_To (TSD_Aggr_List,
- New_Occurrence_Of (Type_Is_Abstract, Loc));
+ New_Occurrence_Of (Type_Is_Abstract, Loc));
end;
end if;
declare
Needs_Fin : Entity_Id;
-
begin
Needs_Fin := Boolean_Literals (Needs_Finalization (Typ));
Append_To (TSD_Aggr_List, New_Occurrence_Of (Needs_Fin, Loc));
Size_Comp :=
Unchecked_Convert_To (RTE (RE_Size_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Prim, Loc),
+ Prefix => New_Occurrence_Of (Prim, Loc),
Attribute_Name => Name_Unrestricted_Access));
end if;
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Interface_Data), Loc),
- Constraint => Make_Index_Or_Discriminant_Constraint
- (Loc,
- Constraints => New_List (
- Make_Integer_Literal (Loc, Num_Ifaces)))),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Integer_Literal (Loc, Num_Ifaces)))),
- Expression => Make_Aggregate (Loc,
+ Expression => Make_Aggregate (Loc,
Expressions => New_List (
Make_Integer_Literal (Loc, Num_Ifaces),
- Make_Aggregate (Loc,
- Expressions => TSD_Ifaces_List)))));
+ Make_Aggregate (Loc, TSD_Ifaces_List)))));
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Chars => Name_Alignment,
Expression =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
Chars => Name_Alignment,
Expression =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
Append_To (TSD_Aggr_List,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (SSD, Loc),
+ Prefix => New_Occurrence_Of (SSD, Loc),
Attribute_Name => Name_Unchecked_Access));
else
Append_To (TSD_Aggr_List, Make_Null (Loc));
Chars => Name_Alignment,
Expression =>
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
+ Prefix =>
+ New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
-- Initialize or declare the dispatch table object
New_Node :=
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (TSD, Loc),
+ Prefix => New_Occurrence_Of (TSD, Loc),
Attribute_Name => Name_Address);
Append_To (DT_Constr_List, New_Node);
if not Building_Static_DT (Typ) then
Append_To (Result,
Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (DT, Loc),
- Expression => Make_Aggregate (Loc,
- Expressions => DT_Aggr_List)));
+ Name => New_Occurrence_Of (DT, Loc),
+ Expression => Make_Aggregate (Loc, DT_Aggr_List)));
-- In case of library level tagged types we declare and export now
-- the constant object containing the dummy dispatch table. There
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_No_Dispatch_Table_Wrapper), Loc),
- Expression => Make_Aggregate (Loc,
- Expressions => DT_Aggr_List)));
+ Expression => Make_Aggregate (Loc, DT_Aggr_List)));
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Chars => Name_Alignment,
Expression =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
New_Node :=
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Prim_Table (J), Loc),
+ Prefix =>
+ New_Occurrence_Of (Prim_Table (J), Loc),
Attribute_Name => Name_Unrestricted_Access));
else
New_Node := Make_Null (Loc);
Defining_Identifier => Predef_Prims,
Aliased_Present => True,
Constant_Present => Building_Static_DT (Typ),
- Object_Definition => New_Occurrence_Of
- (Defining_Identifier (Decl), Loc),
+ Object_Definition =>
+ New_Occurrence_Of (Defining_Identifier (Decl), Loc),
Expression => New_Node));
-- Remember aggregates initializing dispatch tables
Chars => Name_Alignment,
Expression =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
end;
Append_To (DT_Aggr_List,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Predef_Prims, Loc),
+ Prefix => New_Occurrence_Of (Predef_Prims, Loc),
Attribute_Name => Name_Address));
-- Offset_To_Top
Append_To (DT_Aggr_List,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (TSD, Loc),
+ Prefix => New_Occurrence_Of (TSD, Loc),
Attribute_Name => Name_Address));
-- Stage 2: Initialize the table of user-defined primitive operations
New_Node :=
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Prim_Table (J), Loc),
+ Prefix =>
+ New_Occurrence_Of (Prim_Table (J), Loc),
Attribute_Name => Name_Unrestricted_Access));
else
New_Node := Make_Null (Loc);
if not Building_Static_DT (Typ) then
Append_To (Result,
Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (DT, Loc),
- Expression => Make_Aggregate (Loc,
- Expressions => DT_Aggr_List)));
+ Name => New_Occurrence_Of (DT, Loc),
+ Expression => Make_Aggregate (Loc, DT_Aggr_List)));
-- In case of library level tagged types we declare now and export
-- the constant object containing the dispatch table.
(RTE (RE_Dispatch_Table_Wrapper), Loc),
Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => DT_Constr_List)),
- Expression => Make_Aggregate (Loc,
- Expressions => DT_Aggr_List)));
+ Expression => Make_Aggregate (Loc, DT_Aggr_List)));
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Chars => Name_Alignment,
Expression =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
then
Append_To (Result,
Make_Assignment_Statement (Loc,
- Name =>
+ Name =>
Make_Indexed_Component (Loc,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (TSD, Loc),
+ Prefix => New_Occurrence_Of (TSD, Loc),
Selector_Name =>
New_Occurrence_Of
(RTE_Record_Component (RE_Tags_Table), Loc)),
Old_Tag_Node =>
New_Occurrence_Of
(Node
- (Next_Elmt
- (First_Elmt
- (Access_Disp_Table (Parent_Typ)))), Loc),
+ (Next_Elmt
+ (First_Elmt
+ (Access_Disp_Table (Parent_Typ)))), Loc),
New_Tag_Node =>
New_Occurrence_Of
(Node
- (Next_Elmt
- (First_Elmt
- (Access_Disp_Table (Typ)))), Loc)));
+ (Next_Elmt
+ (First_Elmt
+ (Access_Disp_Table (Typ)))), Loc)));
if Nb_Prims /= 0 then
Append_To (Elab_Code,
Old_Tag_Node =>
New_Occurrence_Of
(Node
- (First_Elmt
- (Access_Disp_Table (Parent_Typ))), Loc),
+ (First_Elmt
+ (Access_Disp_Table (Parent_Typ))), Loc),
New_Tag_Node => New_Occurrence_Of (DT_Ptr, Loc),
Num_Prims => Nb_Prims));
end if;
declare
Sec_DT_Ancestor : Elmt_Id :=
Next_Elmt
- (Next_Elmt
- (First_Elmt
- (Access_Disp_Table (Parent_Typ))));
+ (Next_Elmt
+ (First_Elmt
+ (Access_Disp_Table
+ (Parent_Typ))));
Sec_DT_Typ : Elmt_Id :=
Next_Elmt
- (Next_Elmt
- (First_Elmt
- (Access_Disp_Table (Typ))));
+ (Next_Elmt
+ (First_Elmt
+ (Access_Disp_Table (Typ))));
procedure Copy_Secondary_DTs (Typ : Entity_Id);
-- Local procedure required to climb through the ancestors
then
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Register_Tag), Loc),
+ Name =>
+ New_Occurrence_Of (RTE (RE_Register_Tag), Loc),
Parameter_Associations =>
New_List (New_Occurrence_Of (DT_Ptr, Loc))));
end if;
Append_To (OSD_Aggr_List,
Make_Component_Association (Loc,
- Choices => New_List (
+ Choices => New_List (
Make_Integer_Literal (Loc,
DT_Position (Prim_Alias))),
Expression =>
Next_Elmt (Prim_Elmt);
end loop;
+
pragma Assert (Count = Nb_Prim);
end;
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Object_Specific_Data), Loc),
- Constraint =>
+ Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Integer_Literal (Loc, Nb_Prim)))),
Make_Aggregate (Loc,
Component_Associations => New_List (
Make_Component_Association (Loc,
- Choices => New_List (
+ Choices => New_List (
New_Occurrence_Of
(RTE_Record_Component (RE_OSD_Num_Prims), Loc)),
Expression =>
Make_Integer_Literal (Loc, Nb_Prim)),
Make_Component_Association (Loc,
- Choices => New_List (
+ Choices => New_List (
New_Occurrence_Of
(RTE_Record_Component (RE_OSD_Table), Loc)),
Expression => Make_Aggregate (Loc,
Set_Ekind (DT_Ptr, E_Variable);
Set_Related_Type (DT_Ptr, Typ);
- -- Notify the back end that the types are associated with a dispatch
- -- table
+ -- Notify back end that the types are associated with a dispatch table
Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr));
Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr));
Suffix_Index := 1;
- -- Note: The value of Suffix_Index must be in sync with the
- -- Suffix_Index values of secondary dispatch tables generated
- -- by Make_DT.
+ -- Note: The value of Suffix_Index must be in sync with the values of
+ -- Suffix_Index in secondary dispatch tables generated by Make_DT.
if Is_CPP_Class (Typ) then
AI_Tag_Comp := First_Elmt (Typ_Comps);
(Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
Typ_Name := Name_Find;
- -- Declare variables that will store the copy of the C++
- -- secondary tags.
+ -- Declare variables to store copy of the C++ secondary tags
Iface_DT_Ptr :=
Make_Defining_Identifier (Loc,
-- Add the freezing nodes of these declarations; required to avoid
-- generating these freezing nodes in wrong scopes (for example in
-- the IC routine of a derivation of Typ).
+
-- What is an "IC routine"? Is "init_proc" meant here???
Append_List_To (Result, Freeze_Entity (DT_Prims, Typ));
Res : constant Node_Id := Duplicate_Subexpr (From);
begin
if Is_Access_Type (Etype (From)) then
- return
- Make_Explicit_Dereference (Sloc (From),
- Prefix => Res);
+ return Make_Explicit_Dereference (Sloc (From), Prefix => Res);
else
return Res;
end if;
end if;
-- Ada 2005 (AI-251): Primitive associated with an interface type
+
-- Generate the code of the thunk only if the interface type is not an
-- immediate ancestor of Typ; otherwise the dispatch table associated
-- with the interface is the primary dispatch table and we have nothing
-- predefined primitives
procedure Validate_Position (Prim : Entity_Id);
- -- Check that the position assigned to Prim is completely safe
- -- (it has not been assigned to a previously defined primitive
- -- operation of Typ)
+ -- Check that position assigned to Prim is completely safe (it has not
+ -- been assigned to a previously defined primitive operation of Typ).
------------------------
-- In_Predef_Prims_DT --
and then not Is_Predefined_Dispatching_Alias (Op)
and then not Is_Predefined_Dispatching_Alias (Prim)
then
-
-- Handle aliased subprograms
declare
-- Set the DT_Position for each primitive operation. Perform some sanity
-- checks to avoid building inconsistent dispatch tables.
- -- First stage: Set the DTC entity of all the primitive operations. This
- -- is required to properly read the DT_Position attribute in the latter
- -- stages.
+ -- First stage: Set DTC entity of all the primitive operations. This is
+ -- required to properly read the DT_Position attribute in latter stages.
Prim_Elmt := First_Prim;
Count_Prim := 0;
Next_Elmt (Prim_Elmt);
end loop;
- -- Third stage: Fix the position of all the new primitives.
- -- Entries associated with primitives covering interfaces
- -- are handled in a latter round.
+ -- Third stage: Fix the position of all the new primitives. Entries
+ -- associated with primitives covering interfaces are handled in a
+ -- latter round.
Prim_Elmt := First_Prim;
while Present (Prim_Elmt) loop
end;
-- Fourth stage: Complete the decoration of primitives covering
- -- interfaces (that is, propagate the DT_Position attribute
- -- from the aliased primitive)
+ -- interfaces (that is, propagate the DT_Position attribute from
+ -- the aliased primitive)
Prim_Elmt := First_Prim;
while Present (Prim_Elmt) loop
Next_Elmt (Prim_Elmt);
end loop;
- -- Generate listing showing the contents of the dispatch tables.
- -- This action is done before some further static checks because
- -- in case of critical errors caused by a wrong dispatch table
- -- we need to see the contents of such table.
+ -- Generate listing showing the contents of the dispatch tables. This
+ -- action is done before some further static checks because in case of
+ -- critical errors caused by a wrong dispatch table we need to see the
+ -- contents of such table.
if Debug_Flag_ZZ then
Write_DT (Typ);
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
- -- At this point all the primitives MUST have a position
- -- in the dispatch table.
+ -- At this point all the primitives MUST have a position in the
+ -- dispatch table.
if DT_Position (Prim) = No_Uint then
raise Program_Error;
DT_Length := UI_To_Int (DT_Position (Prim));
end if;
- -- Ensure that the assigned position to non-predefined
- -- dispatching operations in the dispatch table is correct.
+ -- Ensure that the assigned position to non-predefined dispatching
+ -- operations in the dispatch table is correct.
if not Is_Predefined_Dispatching_Operation (Prim)
and then not Is_Predefined_Dispatching_Alias (Prim)
-- excluded from this check because interfaces must be visible in
-- the public and private part (RM 7.3 (7.3/2))
- -- We disable this check in Relaxed_RM_Semantics mode, to
- -- accommodate legacy Ada code.
+ -- We disable this check in Relaxed_RM_Semantics mode, to accommodate
+ -- legacy Ada code.
if not Relaxed_RM_Semantics
and then Is_Abstract_Type (Typ)
and then Original_View_In_Visible_Part (Typ)
then
-- We exclude Input and Output stream operations because
- -- Limited_Controlled inherits useless Input and Output
- -- stream operations from Root_Controlled, which can
- -- never be overridden.
+ -- Limited_Controlled inherits useless Input and Output stream
+ -- operations from Root_Controlled, which can never be overridden.
if not Is_TSS (Prim, TSS_Stream_Input)
and then
-- Duplicate the parameters profile of the imported C++ constructor
-- adding an access to the object as an additional parameter.
+ ----------------------------
+ -- Gen_Parameters_Profile --
+ ----------------------------
+
function Gen_Parameters_Profile (E : Entity_Id) return List_Id is
Loc : constant Source_Ptr := Sloc (E);
Parms : List_Id;
end;
end if;
- -- If this constructor has parameters and all its parameters
- -- have defaults then it covers the default constructor. The
- -- semantic analyzer ensures that only one constructor with
- -- defaults covers the default constructor.
+ -- If this constructor has parameters and all its parameters have
+ -- defaults then it covers the default constructor. The semantic
+ -- analyzer ensures that only one constructor with defaults covers
+ -- the default constructor.
if Present (Parameter_Specifications (Parent (E)))
and then Needs_No_Actuals (E)
end if;
-- Display the final position of this primitive in its associated
- -- (primary or secondary) dispatch table
+ -- (primary or secondary) dispatch table.
if Present (DTC_Entity (Prim))
and then DT_Position (Prim) /= No_Uint
projects / platform / upstream / gcc.git / commitdiff