-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Errout; use Errout;
with Exp_Atag; use Exp_Atag;
with Exp_Ch6; use Exp_Ch6;
-with Exp_Ch7; use Exp_Ch7;
with Exp_CG; use Exp_CG;
with Exp_Dbug; use Exp_Dbug;
with Exp_Tss; use Exp_Tss;
with Stand; use Stand;
with Stringt; use Stringt;
with SCIL_LL; use SCIL_LL;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
-- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
-- of the default primitive operations.
+ function Find_Specific_Type (CW : Entity_Id) return Entity_Id;
+ -- Find specific type of a class-wide type, and handle the case of an
+ -- incomplete type coming either from a limited_with clause or from an
+ -- incomplete type declaration. Shouldn't this be in Sem_Util? It seems
+ -- like a general purpose semantic routine ???
+
function Has_DT (Typ : Entity_Id) return Boolean;
pragma Inline (Has_DT);
-- Returns true if we generate a dispatch table for tagged type Typ
-- Returns true if Prim is not a predefined dispatching primitive but it is
-- an alias of a predefined dispatching primitive (i.e. through a renaming)
- function Make_VM_TSD (Typ : Entity_Id) return List_Id;
- -- Build the Type Specific Data record associated with tagged type Typ.
- -- Invoked only when generating code for VM targets.
-
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
CW_Typ := Class_Wide_Type (Ctrl_Typ);
end if;
- Typ := Root_Type (CW_Typ);
-
- if Ekind (Typ) = E_Incomplete_Type then
- Typ := Non_Limited_View (Typ);
- end if;
+ Typ := Find_Specific_Type (CW_Typ);
if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
return Static_Dispatch_Tables
and then Is_Library_Level_Tagged_Type (Typ)
+ and then VM_Target = No_VM
-- If the type is derived from a CPP class we cannot statically
-- build the dispatch tables because we must inherit primitives
end if;
end Build_Static_Dispatch_Tables;
- -------------------
- -- Build_VM_TSDs --
- -------------------
-
- procedure Build_VM_TSDs (N : Entity_Id) is
- Target_List : List_Id := No_List;
-
- procedure Build_TSDs (List : List_Id);
- -- Build the static dispatch table of tagged types found in the list of
- -- declarations. Add the generated nodes to the end of Target_List.
-
- procedure Build_Package_TSDs (N : Node_Id);
- -- Build static dispatch tables associated with package declaration N
-
- ---------------------------
- -- Build_Dispatch_Tables --
- ---------------------------
-
- procedure Build_TSDs (List : List_Id) is
- D : Node_Id;
-
- begin
- D := First (List);
- while Present (D) loop
-
- -- Handle nested packages and package bodies recursively. The
- -- generated code is placed on the Target_List established for
- -- the enclosing compilation unit.
-
- if Nkind (D) = N_Package_Declaration then
- Build_Package_TSDs (D);
-
- elsif Nkind_In (D, N_Package_Body,
- N_Subprogram_Body)
- then
- Build_TSDs (Declarations (D));
-
- elsif Nkind (D) = N_Package_Body_Stub
- and then Present (Library_Unit (D))
- then
- Build_TSDs
- (Declarations (Proper_Body (Unit (Library_Unit (D)))));
-
- -- Handle full type declarations and derivations of library
- -- level tagged types
-
- elsif Nkind_In (D, N_Full_Type_Declaration,
- N_Derived_Type_Definition)
- and then Ekind (Defining_Entity (D)) /= E_Record_Subtype
- and then Is_Tagged_Type (Defining_Entity (D))
- and then not Is_Private_Type (Defining_Entity (D))
- then
- -- Do not generate TSDs for the internal types created for
- -- a type extension with unknown discriminants. The needed
- -- information is shared with the source type.
- -- See Expand_N_Record_Extension.
-
- if Is_Underlying_Record_View (Defining_Entity (D))
- or else
- (not Comes_From_Source (Defining_Entity (D))
- and then
- Has_Unknown_Discriminants (Etype (Defining_Entity (D)))
- and then
- not Comes_From_Source
- (First_Subtype (Defining_Entity (D))))
- then
- null;
-
- else
- if No (Target_List) then
- Target_List := New_List;
- end if;
-
- Append_List_To (Target_List,
- Make_VM_TSD (Defining_Entity (D)));
- end if;
- end if;
-
- Next (D);
- end loop;
- end Build_TSDs;
-
- ------------------------
- -- Build_Package_TSDs --
- ------------------------
-
- procedure Build_Package_TSDs (N : Node_Id) is
- Spec : constant Node_Id := Specification (N);
- Vis_Decls : constant List_Id := Visible_Declarations (Spec);
- Priv_Decls : constant List_Id := Private_Declarations (Spec);
-
- begin
- if Present (Priv_Decls) then
- Build_TSDs (Vis_Decls);
- Build_TSDs (Priv_Decls);
-
- elsif Present (Vis_Decls) then
- Build_TSDs (Vis_Decls);
- end if;
- end Build_Package_TSDs;
-
- -- Start of processing for Build_VM_TSDs
-
- begin
- if not Expander_Active
- or else No_Run_Time_Mode
- or else Tagged_Type_Expansion
- or else not RTE_Available (RE_Type_Specific_Data)
- then
- return;
- end if;
-
- if Nkind (N) = N_Package_Declaration then
- declare
- Spec : constant Node_Id := Specification (N);
- Vis_Decls : constant List_Id := Visible_Declarations (Spec);
- Priv_Decls : constant List_Id := Private_Declarations (Spec);
-
- begin
- Build_Package_TSDs (N);
-
- if Present (Target_List) then
- Analyze_List (Target_List);
-
- if Present (Priv_Decls)
- and then Is_Non_Empty_List (Priv_Decls)
- then
- Append_List (Target_List, Priv_Decls);
- else
- Append_List (Target_List, Vis_Decls);
- end if;
- end if;
- end;
-
- elsif Nkind_In (N, N_Package_Body, N_Subprogram_Body) then
- if Is_Non_Empty_List (Declarations (N)) then
- Build_TSDs (Declarations (N));
-
- if Nkind (N) = N_Subprogram_Body then
- Build_TSDs (Statements (Handled_Statement_Sequence (N)));
- end if;
-
- if Present (Target_List) then
- Analyze_List (Target_List);
- Append_List (Target_List, Declarations (N));
- end if;
- end if;
- end if;
- end Build_VM_TSDs;
-
------------------------------
-- Convert_Tag_To_Interface --
------------------------------
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;
CW_Typ := Class_Wide_Type (Ctrl_Typ);
end if;
- Typ := Root_Type (CW_Typ);
-
- if Ekind (Typ) = E_Incomplete_Type then
- Typ := Non_Limited_View (Typ);
- end if;
+ Typ := Find_Specific_Type (CW_Typ);
if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
Set_Etype (Subp_Typ, Res_Typ);
Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
+ Set_Convention (Subp_Typ, Convention (Subp));
+
+ -- Notify gigi that the designated type is a dispatching primitive
+
+ Set_Is_Dispatch_Table_Entity (Subp_Typ);
-- Create a new list of parameters which is a copy of the old formal
-- list including the creation of a new set of matching entities.
and then Is_Interface (Iface_Typ)));
if not Tagged_Type_Expansion then
+ if VM_Target /= No_VM then
+ if Is_Access_Type (Operand_Typ) then
+ Operand_Typ := Designated_Type (Operand_Typ);
+ end if;
- -- For VM, just do a conversion ???
+ if Is_Class_Wide_Type (Operand_Typ) then
+ Operand_Typ := Root_Type (Operand_Typ);
+ end if;
+
+ if not Is_Static
+ and then Operand_Typ /= Iface_Typ
+ then
+ Insert_Action (N,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of
+ (RTE (RE_Check_Interface_Conversion), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Expression (N)),
+ Attribute_Name => Name_Tag),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Iface_Typ, Loc),
+ Attribute_Name => Name_Tag))));
+ end if;
+
+ -- Just do a conversion ???
+
+ Rewrite (N, Unchecked_Convert_To (Etype (N), N));
+ Analyze (N);
+ end if;
- Rewrite (N, Unchecked_Convert_To (Etype (N), N));
- Analyze (N);
return;
end if;
Thunk_Id := Make_Temporary (Loc, 'T');
Set_Is_Thunk (Thunk_Id);
+ Set_Convention (Thunk_Id, Convention (Prim));
-- Procedure case
end if;
end Expand_Interface_Thunk;
+ ------------------------
+ -- Find_Specific_Type --
+ ------------------------
+
+ function Find_Specific_Type (CW : Entity_Id) return Entity_Id is
+ Typ : Entity_Id := Root_Type (CW);
+
+ begin
+ if Ekind (Typ) = E_Incomplete_Type then
+ if From_With_Type (Typ) then
+ Typ := Non_Limited_View (Typ);
+ else
+ Typ := Full_View (Typ);
+ end if;
+ end if;
+
+ return Typ;
+ end Find_Specific_Type;
+
--------------------------
-- Has_CPP_Constructors --
--------------------------
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;
DT_Aggr : constant Elist_Id := New_Elmt_List;
-- Entities marked with attribute Is_Dispatch_Table_Entity
- procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id);
+ procedure Check_Premature_Freezing
+ (Subp : Entity_Id;
+ Tagged_Type : Entity_Id;
+ Typ : Entity_Id);
-- Verify that all non-tagged types in the profile of a subprogram
-- are frozen at the point the subprogram is frozen. This enforces
-- the rule on RM 13.14 (14) as modified by AI05-019. At the point a
-- Typical violation of the rule involves an object declaration that
-- freezes a tagged type, when one of its primitive operations has a
-- type in its profile whose full view has not been analyzed yet.
+ -- More complex cases involve composite types that have one private
+ -- unfrozen subcomponent.
procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0);
-- Export the dispatch table DT of tagged type Typ. Required to generate
-- calls through interface types; the latter secondary table is
-- generated when Build_Thunks is False, and provides support for
-- Generic Dispatching Constructors that dispatch calls through
- -- interface types. When constructing this latter table the value
- -- of Suffix_Index is -1 to indicate that there is no need to export
- -- such table when building statically allocated dispatch tables; a
- -- positive value of Suffix_Index must match the Suffix_Index value
- -- assigned to this secondary dispatch table by Make_Tags when its
- -- unique external name was generated.
+ -- interface types. When constructing this latter table the value of
+ -- Suffix_Index is -1 to indicate that there is no need to export such
+ -- table when building statically allocated dispatch tables; a positive
+ -- value of Suffix_Index must match the Suffix_Index value assigned to
+ -- this secondary dispatch table by Make_Tags when its unique external
+ -- name was generated.
------------------------------
-- Check_Premature_Freezing --
------------------------------
- procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id) is
+ procedure Check_Premature_Freezing
+ (Subp : Entity_Id;
+ Tagged_Type : Entity_Id;
+ Typ : Entity_Id)
+ 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 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
("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);
+ & " 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)
+ 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);
+ 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);
+ end if;
end if;
end Check_Premature_Freezing;
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;
begin
F := First_Formal (Prim);
while Present (F) loop
- Check_Premature_Freezing (Prim, Etype (F));
+ Check_Premature_Freezing (Prim, Typ, Etype (F));
Next_Formal (F);
end loop;
- Check_Premature_Freezing (Prim, Etype (Prim));
+ Check_Premature_Freezing (Prim, Typ, Etype (Prim));
end;
if Present (Frnodes) then
-- 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>>,
- -- RC_Offset => <<integer-value>>,
- -- [ Size_Func => Size_Prim'Access ]
- -- [ Interfaces_Table => <<access-value>> ]
+ -- Needs_Finalization => <<boolean-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
end;
end if;
- -- RC_Offset: These are the valid values and their meaning:
-
- -- >0: For simple types with controlled components is
- -- type._record_controller'position
-
- -- 0: For types with no controlled components
-
- -- -1: For complex types with controlled components where the position
- -- of the record controller is not statically computable but there
- -- are controlled components at this level. The _Controller field
- -- is available right after the _parent.
-
- -- -2: There are no controlled components at this level. We need to
- -- get the position from the parent.
+ -- Needs_Finalization: Set if the type is controlled or has controlled
+ -- components.
declare
- RC_Offset_Node : Node_Id;
+ Needs_Fin : Entity_Id;
begin
- if not Has_Controlled_Component (Typ) then
- RC_Offset_Node := Make_Integer_Literal (Loc, 0);
-
- elsif Etype (Typ) /= Typ
- and then Has_Discriminants (Parent_Typ)
- then
- if Has_New_Controlled_Component (Typ) then
- RC_Offset_Node := Make_Integer_Literal (Loc, -1);
- else
- RC_Offset_Node := Make_Integer_Literal (Loc, -2);
- end if;
- else
- RC_Offset_Node :=
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => New_Reference_To (Typ, Loc),
- Selector_Name =>
- New_Reference_To (Controller_Component (Typ), Loc)),
- Attribute_Name => Name_Position);
-
- -- This is not proper Ada code to use the attribute 'Position
- -- on something else than an object but this is supported by
- -- the back end (see comment on the Bit_Component attribute in
- -- sem_attr). So we avoid semantic checking here.
-
- -- Is this documented in sinfo.ads??? it should be!
-
- Set_Analyzed (RC_Offset_Node);
- Set_Etype (Prefix (RC_Offset_Node), RTE (RE_Record_Controller));
- Set_Etype (Prefix (Prefix (RC_Offset_Node)), Typ);
- Set_Etype (Selector_Name (Prefix (RC_Offset_Node)),
- RTE (RE_Record_Controller));
- Set_Etype (RC_Offset_Node, RTE (RE_Storage_Offset));
- end if;
-
- Append_To (TSD_Aggr_List, RC_Offset_Node);
+ Needs_Fin := Boolean_Literals (Needs_Finalization (Typ));
+ Append_To (TSD_Aggr_List, New_Occurrence_Of (Needs_Fin, Loc));
end;
-- Size_Func
end if;
end if;
- -- Generate code to check if the external tag of this type is the same
- -- as the external tag of some other declaration.
+ -- If the type has a representation clause which specifies its external
+ -- tag then generate code to check if the external tag of this type is
+ -- the same as the external tag of some other declaration.
-- Check_TSD (TSD'Unrestricted_Access);
if not No_Run_Time_Mode
and then Ada_Version >= Ada_2005
+ and then Has_External_Tag_Rep_Clause (Typ)
and then RTE_Available (RE_Check_TSD)
+ and then not Debug_Flag_QQ
then
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
-- (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
+
+ -- For CPP types we cannot rely on the value of 'Alignment provided
+ -- by the backend to initialize this TSD field. Why not???
+
+ 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;
+
-- HT_Link
Append_To (TSD_Aggr_List,
Make_Aggregate (Loc,
Expressions => New_List (
- -- Iface_Tag
+ -- Iface_Tag
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Iface, Loc),
Attribute_Name => Name_Tag),
- -- OSD
+ -- OSD
Make_OSD (Iface))));
Append_To (TSD_Aggr_List,
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (SSD, Loc),
+ Prefix => New_Reference_To (SSD, Loc),
Attribute_Name => Name_Unchecked_Access));
else
Append_To (TSD_Aggr_List, Make_Null (Loc));
Append_To (TSD_Tags_List,
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Typ, Loc),
+ Prefix => New_Reference_To (Typ, Loc),
Attribute_Name => Name_Tag));
-- Fill the rest of the table with the tags of the ancestors
Append_To (TSD_Tags_List,
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Parent_Typ, Loc),
+ Prefix => New_Reference_To (Parent_Typ, Loc),
Attribute_Name => Name_Tag));
Pos := Pos + 1;
-- Check_TSD
-- (TSD => TSD'Unrestricted_Access);
- Append_To (Result,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Check_TSD), Loc),
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (TSD, Loc),
- Attribute_Name => Name_Unrestricted_Access))));
+ if Ada_Version >= Ada_2005
+ and then Is_Library_Level_Entity (Typ)
+ and then Has_External_Tag_Rep_Clause (Typ)
+ and then RTE_Available (RE_Check_TSD)
+ and then not Debug_Flag_QQ
+ then
+ Append_To (Result,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Check_TSD), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (TSD, Loc),
+ Attribute_Name => Name_Unrestricted_Access))));
+ end if;
-- Generate:
-- Register_TSD (TSD'Unrestricted_Access);
Name => New_Reference_To (RTE (RE_Register_TSD), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (TSD, Loc),
+ Prefix => New_Reference_To (TSD, Loc),
Attribute_Name => Name_Unrestricted_Access))));
-- Populate the two auxiliary tables used for dispatching asynchronous,
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;
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;
Defining_Identifier => DT_Ptr,
Constant_Present => True,
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
- Expression =>
+ Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
- Prefix => New_Reference_To (DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+ Prefix => New_Reference_To (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Prims_Ptr), Loc)),
Attribute_Name => Name_Address))));
-- Generate the SCIL node for the previous object declaration
Make_Object_Declaration (Loc,
Defining_Identifier => Predef_Prims_Ptr,
Constant_Present => True,
- Object_Definition => New_Reference_To
- (RTE (RE_Address), Loc),
- Expression =>
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Address), Loc),
+ Expression =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
- Prefix => New_Reference_To (DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Predef_Prims), Loc)),
+ Prefix => New_Reference_To (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Predef_Prims), Loc)),
Attribute_Name => Name_Address)));
-- No dispatch table required
Defining_Identifier => DT_Ptr,
Constant_Present => True,
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
- Expression =>
+ Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
Prefix => New_Reference_To (DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_NDT_Prims_Ptr),
+ Loc)),
Attribute_Name => Name_Address))));
end if;
Constant_Present => True,
Object_Definition => New_Reference_To
(RTE (RE_Interface_Tag), Loc),
- Expression =>
+ Expression =>
Unchecked_Convert_To (RTE (RE_Interface_Tag),
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
- Prefix => New_Reference_To (Iface_DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+ Prefix =>
+ New_Reference_To (Iface_DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Prims_Ptr),
+ Loc)),
Attribute_Name => Name_Address))));
end if;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+ pragma Assert (VM_Target = No_VM);
-- Do not register in the dispatch table eliminated primitives
Address_Node =>
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Prim, Loc),
+ Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Unrestricted_Access))));
-- Register copy of the pointer to the 'size primitive in the TSD
Address_Node =>
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Prim, Loc),
+ Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Unrestricted_Access))));
end if;
end if;
Address_Node =>
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Alias (Prim), Loc),
+ Prefix =>
+ New_Reference_To (Alias (Prim), Loc),
Attribute_Name => Name_Unrestricted_Access))));
else
Address_Node =>
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Alias (Prim), Loc),
+ Prefix =>
+ New_Reference_To (Alias (Prim), Loc),
Attribute_Name => Name_Unrestricted_Access))));
end if;
procedure Set_All_DT_Position (Typ : Entity_Id) is
+ function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean;
+ -- Returns True if Prim is located in the dispatch table of
+ -- 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)
+ ------------------------
+ -- In_Predef_Prims_DT --
+ ------------------------
+
+ function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean is
+ E : Entity_Id;
+
+ begin
+ -- Predefined primitives
+
+ if Is_Predefined_Dispatching_Operation (Prim) then
+ return True;
+
+ -- Renamings of predefined primitives
+
+ elsif Present (Alias (Prim))
+ and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim))
+ then
+ if Chars (Ultimate_Alias (Prim)) /= Name_Op_Eq then
+ return True;
+
+ -- User-defined renamings of predefined equality have their own
+ -- slot in the primary dispatch table
+
+ else
+ E := Prim;
+ while Present (Alias (E)) loop
+ if Comes_From_Source (E) then
+ return False;
+ end if;
+
+ E := Alias (E);
+ end loop;
+
+ return not Comes_From_Source (E);
+ end if;
+
+ -- User-defined primitives
+
+ else
+ return False;
+ end if;
+ end In_Predef_Prims_DT;
+
-----------------------
-- Validate_Position --
-----------------------
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;
-- Predefined primitives have a separate dispatch table
- if not (Is_Predefined_Dispatching_Operation (Prim)
- or else
- Is_Predefined_Dispatching_Alias (Prim))
- then
+ if not In_Predef_Prims_DT (Prim) then
Count_Prim := Count_Prim + 1;
end if;
-- Predefined primitives have a separate table and all its
-- entries are at predefined fixed positions.
- if Is_Predefined_Dispatching_Operation (Prim) then
- Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
+ if In_Predef_Prims_DT (Prim) then
+ if Is_Predefined_Dispatching_Operation (Prim) then
+ Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
- elsif Is_Predefined_Dispatching_Alias (Prim) then
- Set_DT_Position (Prim,
- Default_Prim_Op_Position (Ultimate_Alias (Prim)));
+ else pragma Assert (Present (Alias (Prim)));
+ Set_DT_Position (Prim,
+ Default_Prim_Op_Position (Ultimate_Alias (Prim)));
+ end if;
-- Overriding primitives of ancestor abstract interfaces
-- Calculate real size of the dispatch table
- if not (Is_Predefined_Dispatching_Operation (Prim)
- or else Is_Predefined_Dispatching_Alias (Prim))
+ if not In_Predef_Prims_DT (Prim)
and then UI_To_Int (DT_Position (Prim)) > DT_Length
then
DT_Length := UI_To_Int (DT_Position (Prim));
-- Ensure that the assigned position to non-predefined
-- dispatching operations in the dispatch table is correct.
- if not (Is_Predefined_Dispatching_Operation (Prim)
- or else Is_Predefined_Dispatching_Alias (Prim))
+ if not Is_Predefined_Dispatching_Operation (Prim)
+ and then not Is_Predefined_Dispatching_Alias (Prim)
then
Validate_Position (Prim);
end if;
Set_Init_Proc (Typ, Init);
Set_Is_Imported (Init);
+ Set_Is_Constructor (Init);
Set_Interface_Name (Init, Interface_Name (E));
- Set_Convention (Init, Convention_C);
+ Set_Convention (Init, Convention_CPP);
Set_Is_Public (Init);
Set_Has_Completion (Init);
end if;
Parameter_Specifications => Parms));
Set_Is_Imported (Constructor_Id);
+ Set_Is_Constructor (Constructor_Id);
Set_Interface_Name (Constructor_Id, Interface_Name (E));
- Set_Convention (Constructor_Id, Convention_C);
+ Set_Convention (Constructor_Id, Convention_CPP);
Set_Is_Public (Constructor_Id);
Set_Has_Completion (Constructor_Id);
OSDN Git Service
