if Chars (E) = Name_uSize then
return Uint_1;
- elsif Chars (E) = Name_uAlignment then
- return Uint_2;
-
elsif TSS_Name = TSS_Stream_Read then
- return Uint_3;
+ return Uint_2;
elsif TSS_Name = TSS_Stream_Write then
- return Uint_4;
+ return Uint_3;
elsif TSS_Name = TSS_Stream_Input then
- return Uint_5;
+ return Uint_4;
elsif TSS_Name = TSS_Stream_Output then
- return Uint_6;
+ return Uint_5;
elsif Chars (E) = Name_Op_Eq then
- return Uint_7;
+ return Uint_6;
elsif Chars (E) = Name_uAssign then
- return Uint_8;
+ return Uint_7;
elsif TSS_Name = TSS_Deep_Adjust then
- return Uint_9;
+ return Uint_8;
elsif TSS_Name = TSS_Deep_Finalize then
- return Uint_10;
+ return Uint_9;
-- In VM targets unconditionally allow obtaining the position associated
-- with predefined interface primitives since in these platforms any
elsif Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion then
if Chars (E) = Name_uDisp_Asynchronous_Select then
- return Uint_11;
+ return Uint_10;
elsif Chars (E) = Name_uDisp_Conditional_Select then
- return Uint_12;
+ return Uint_11;
elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
- return Uint_13;
+ return Uint_12;
elsif Chars (E) = Name_uDisp_Get_Task_Id then
- return Uint_14;
+ return Uint_13;
elsif Chars (E) = Name_uDisp_Requeue then
- return Uint_15;
+ return Uint_14;
elsif Chars (E) = Name_uDisp_Timed_Select then
- return Uint_16;
+ return Uint_15;
end if;
end if;
end if;
-- Expand_Dispatching_Call 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
- -- if we are compiling under restriction No_Dispatching_Calls;
- -- the semantic analyzer has previously notified the violation
- -- of this restriction.
+ -- so we only proceed if the expander is active.
+
+ if not Full_Expander_Active
+
+ -- And there is no need to expand the call if we are compiling under
+ -- restriction No_Dispatching_Calls; the semantic analyzer has
+ -- previously notified the violation of this restriction.
- if not Expander_Active
or else Restriction_Active (No_Dispatching_Calls)
then
return;
TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
.. Name_Len));
if Chars (E) = Name_uSize
- or else Chars (E) = Name_uAlignment
or else TSS_Name = TSS_Stream_Read
or else TSS_Name = TSS_Stream_Write
or else TSS_Name = TSS_Stream_Input
(Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
if Chars (E) = Name_uSize
- or else Chars (E) = Name_uAlignment
or else
(Chars (E) = Name_Op_Eq
and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
-- F : out Boolean)
-- is
-- begin
- -- null;
+ -- F := False;
+ -- C := Ada.Tags.POK_Function;
-- end _Disp_Asynchronous_Select;
-- For protected types, generate:
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_Null_Statement (Loc))));
+ New_List (Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)))));
end if;
if Is_Concurrent_Record_Type (Typ) then
Expression =>
New_Reference_To (Com_Block, Loc))));
+ -- Generate:
+ -- F := False;
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)));
+
else
pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
else
-- Ensure that the statements list is non-empty
- Append_To (Stmts, Make_Null_Statement (Loc));
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)));
end if;
return
Make_Subprogram_Body (Loc,
- Specification =>
+ Specification =>
Make_Disp_Asynchronous_Select_Spec (Typ),
- Declarations =>
- Decls,
+ Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts));
end Make_Disp_Asynchronous_Select_Body;
-- F : out Boolean)
-- is
-- begin
- -- null;
+ -- F := False;
+ -- C := Ada.Tags.POK_Function;
-- end _Disp_Conditional_Select;
-- For protected types, generate:
No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- New_List (Make_Null_Statement (Loc))));
+ New_List (Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)))));
end if;
if Is_Concurrent_Record_Type (Typ) then
end if;
else
- -- Ensure that the statements list is non-empty
+ -- Initialize out parameters
- Append_To (Stmts, Make_Null_Statement (Loc));
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)));
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uC),
+ Expression => New_Reference_To (RTE (RE_POK_Function), Loc)));
end if;
return
Make_Subprogram_Body (Loc,
- Specification =>
+ Specification =>
Make_Disp_Conditional_Select_Spec (Typ),
- Declarations =>
- Decls,
+ Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts));
end Make_Disp_Conditional_Select_Body;
-- F : out Boolean)
-- is
-- begin
- -- null;
+ -- F := False;
+ -- C := Ada.Tags.POK_Function;
-- end _Disp_Timed_Select;
-- For protected types, generate:
-- P,
-- D,
-- M,
- -- D);
+ -- F);
-- end _Disp_Time_Select;
function Make_Disp_Timed_Select_Body
New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- New_List (Make_Null_Statement (Loc))));
+ New_List (
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)))));
end if;
if Is_Concurrent_Record_Type (Typ) then
Append_To (Decls,
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uI),
- Object_Definition =>
- New_Reference_To (Standard_Integer, Loc)));
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI),
+ Object_Definition => New_Reference_To (Standard_Integer, Loc)));
-- Generate:
-- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
else
Tag_Node :=
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Typ, Loc),
+ Prefix => New_Reference_To (Typ, Loc),
Attribute_Name => Name_Tag);
end if;
Name => Make_Identifier (Loc, Name_uI),
Expression =>
Make_Function_Call (Loc,
- Name =>
- New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
+ Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
Parameter_Associations =>
New_List (
Tag_Node,
end if;
else
- -- Ensure that the statements list is non-empty
+ -- Initialize out parameters
- Append_To (Stmts, Make_Null_Statement (Loc));
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_False, Loc)));
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uC),
+ Expression => New_Reference_To (RTE (RE_POK_Function), Loc)));
end if;
return
Make_Subprogram_Body (Loc,
- Specification =>
- Make_Disp_Timed_Select_Spec (Typ),
- Declarations =>
- Decls,
+ Specification => Make_Disp_Timed_Select_Spec (Typ),
+ Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts));
end Make_Disp_Timed_Select_Body;
is
Comp : Entity_Id;
+ function Is_Actual_For_Formal_Incomplete_Type
+ (T : Entity_Id) return Boolean;
+ -- In Ada 2012, if a nested generic has an incomplete formal type,
+ -- the actual may be (and usually is) a private type whose completion
+ -- appears later. It is safe to build the dispatch table in this
+ -- case, gigi will have full views available.
+
+ ------------------------------------------
+ -- Is_Actual_For_Formal_Incomplete_Type --
+ ------------------------------------------
+
+ function Is_Actual_For_Formal_Incomplete_Type
+ (T : Entity_Id) return Boolean
+ is
+ Gen_Par : Entity_Id;
+ F : Node_Id;
+
+ begin
+ if not Is_Generic_Instance (Current_Scope)
+ 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)));
+ while Present (F) loop
+ if Ekind (Defining_Identifier (F)) = E_Incomplete_Type then
+ return True;
+ end if;
+
+ Next (F);
+ end loop;
+
+ return False;
+ end Is_Actual_For_Formal_Incomplete_Type;
+
+ -- Start of processing for Check_Premature_Freezing
+
begin
+ -- Note that if the type is a (subtype of) a generic actual, the
+ -- actual will have been frozen by the instantiation.
+
if Present (N)
and then Is_Private_Type (Typ)
and then No (Full_View (Typ))
and then not Is_Generic_Type (Typ)
and then not Is_Tagged_Type (Typ)
and then not Is_Frozen (Typ)
+ and then not Is_Generic_Actual_Type (Typ)
then
Error_Msg_Sloc := Sloc (Subp);
Error_Msg_NE
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)
then
Error_Msg_Sloc := Sloc (Subp);
Error_Msg_Node_2 := Subp;
end if;
-- Ensure that the value of Max_Predef_Prims defined in a-tags is
- -- correct. Valid values are 10 under configurable runtime or 16
+ -- correct. Valid values are 9 under configurable runtime or 15
-- with full runtime.
if RTE_Available (RE_Interface_Data) then
- if Max_Predef_Prims /= 16 then
+ if Max_Predef_Prims /= 15 then
Error_Msg_N ("run-time library configuration error", Typ);
return Result;
end if;
else
- if Max_Predef_Prims /= 10 then
+ if Max_Predef_Prims /= 9 then
Error_Msg_N ("run-time library configuration error", Typ);
Error_Msg_CRT ("tagged types", Typ);
return Result;
-- TSD : Type_Specific_Data (I_Depth) :=
-- (Idepth => I_Depth,
-- Access_Level => Type_Access_Level (Typ),
+ -- Alignment => Typ'Alignment,
-- Expanded_Name => Cstring_Ptr!(Exname'Address))
-- External_Tag => Cstring_Ptr!(Exname'Address))
-- HT_Link => HT_Link'Address,
-- Transportable => <<boolean-value>>,
-- Type_Is_Abstract => <<boolean-value>>,
-- Needs_Finalization => <<boolean-value>>,
- -- [ Size_Func => Size_Prim'Access ]
- -- [ Interfaces_Table => <<access-value>> ]
+ -- [ Size_Func => Size_Prim'Access, ]
+ -- [ Interfaces_Table => <<access-value>>, ]
-- [ SSD => SSD_Table'Address ]
-- Tags_Table => (0 => null,
-- 1 => Parent'Tag
Append_To (TSD_Aggr_List,
Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
+ -- Alignment
+
+ -- For CPP types we cannot rely on the value of 'Alignment provided
+ -- by the backend to initialize this TSD field.
+
+ if Convention (Typ) = Convention_CPP
+ or else Is_CPP_Class (Root_Type (Typ))
+ then
+ Append_To (TSD_Aggr_List,
+ Make_Integer_Literal (Loc, 0));
+ else
+ Append_To (TSD_Aggr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Alignment));
+ end if;
+
-- Expanded_Name
Append_To (TSD_Aggr_List,
Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Exname, Loc),
+ Prefix => New_Reference_To (Exname, Loc),
Attribute_Name => Name_Address)));
-- External_Tag of a local tagged type
-- (Idepth => I_Depth,
-- Tag_Kind => <tag_kind-value>,
-- Access_Level => Type_Access_Level (Typ),
+ -- Alignment => Typ'Alignment,
-- HT_Link => null,
-- Type_Is_Abstract => <<boolean-value>>,
-- Type_Is_Library_Level => <<boolean-value>>,
Append_To (TSD_Aggr_List,
Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
+ -- Alignment
+
+ Append_To (TSD_Aggr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Alignment));
+
-- HT_Link
Append_To (TSD_Aggr_List,
First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
The_Tag : constant Entity_Id := First_Tag_Component (Typ);
- Adjusted : Boolean := False;
- Finalized : Boolean := False;
+ Adjusted : Boolean := False;
+ Finalized : Boolean := False;
Count_Prim : Nat;
DT_Length : Nat;
OSDN Git Service
