-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, 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 Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
+with Expander; use Expander;
with Exp_Atag; use Exp_Atag;
with Exp_Ch6; use Exp_Ch6;
with Exp_CG; use Exp_CG;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
+with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
------------------------
function Building_Static_DT (Typ : Entity_Id) return Boolean is
- Root_Typ : Entity_Id := Root_Type (Typ);
+ Root_Typ : Entity_Id := Root_Type (Typ);
+ Static_DT : Boolean;
begin
-- Handle private types
Root_Typ := Full_View (Root_Typ);
end if;
- return Static_Dispatch_Tables
- and then Is_Library_Level_Tagged_Type (Typ)
+ Static_DT :=
+ Building_Static_Dispatch_Tables
+ and then Is_Library_Level_Tagged_Type (Typ)
- -- If the type is derived from a CPP class we cannot statically
- -- build the dispatch tables because we must inherit primitives
- -- from the CPP side.
+ -- If the type is derived from a CPP class we cannot statically
+ -- build the dispatch tables because we must inherit primitives
+ -- from the CPP side.
- and then not Is_CPP_Class (Root_Typ);
+ and then not Is_CPP_Class (Root_Typ);
+
+ if not Static_DT then
+ Check_Restriction (Static_Dispatch_Tables, Typ);
+ end if;
+
+ return Static_DT;
end Building_Static_DT;
+ ----------------------------------
+ -- Building_Static_Secondary_DT --
+ ----------------------------------
+
+ function Building_Static_Secondary_DT (Typ : Entity_Id) return Boolean is
+ Full_Typ : Entity_Id := Typ;
+ Root_Typ : Entity_Id := Root_Type (Typ);
+ Static_DT : Boolean;
+
+ begin
+ -- Handle private types
+
+ if Present (Full_View (Typ)) then
+ Full_Typ := Full_View (Typ);
+ end if;
+
+ if Present (Full_View (Root_Typ)) then
+ Root_Typ := Full_View (Root_Typ);
+ end if;
+
+ Static_DT :=
+ Building_Static_DT (Full_Typ)
+ and then not Is_Interface (Full_Typ)
+ and then Has_Interfaces (Full_Typ)
+ and then (Full_Typ = Root_Typ
+ or else not Is_Variable_Size_Record (Etype (Full_Typ)));
+
+ if not Static_DT
+ and then not Is_Interface (Full_Typ)
+ and then Has_Interfaces (Full_Typ)
+ then
+ Check_Restriction (Static_Dispatch_Tables, Typ);
+ end if;
+
+ return Static_DT;
+ end Building_Static_Secondary_DT;
+
----------------------------------
-- Build_Static_Dispatch_Tables --
----------------------------------
raise Program_Error;
end Default_Prim_Op_Position;
+ ----------------------
+ -- Elab_Flag_Needed --
+ ----------------------
+
+ function Elab_Flag_Needed (Typ : Entity_Id) return Boolean is
+ begin
+ return Ada_Version >= Ada_2005
+ and then not Is_Interface (Typ)
+ and then Has_Interfaces (Typ)
+ and then not Building_Static_DT (Typ);
+ end Elab_Flag_Needed;
+
-----------------------------
-- Expand_Dispatching_Call --
-----------------------------
Eq_Prim_Op : Entity_Id := Empty;
Controlling_Tag : Node_Id;
+ procedure Build_Class_Wide_Check;
+ -- If the denoted subprogram has a class-wide precondition, generate a
+ -- check using that precondition before the dispatching call, because
+ -- this is the only class-wide precondition that applies to the call.
+
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.
+ ----------------------------
+ -- Build_Class_Wide_Check --
+ ----------------------------
+
+ procedure Build_Class_Wide_Check is
+ function Replace_Formals (N : Node_Id) return Traverse_Result;
+ -- Replace occurrences of the formals of the subprogram by the
+ -- corresponding actuals in the call, given that this check is
+ -- performed outside of the body of the subprogram.
+
+ -- If the dispatching call appears in the same scope as the
+ -- declaration of the dispatching subprogram (for example in
+ -- the expression of a local expression function), the spec
+ -- has not been analyzed yet, in which case we use the Chars
+ -- field to recognize intended occurrences of the formals.
+
+ ---------------------
+ -- Replace_Formals --
+ ---------------------
+
+ function Replace_Formals (N : Node_Id) return Traverse_Result is
+ A : Node_Id;
+ F : Entity_Id;
+ begin
+ if Is_Entity_Name (N) then
+ F := First_Formal (Subp);
+ A := First_Actual (Call_Node);
+
+ if Present (Entity (N)) and then Is_Formal (Entity (N)) then
+ while Present (F) loop
+ if F = Entity (N) then
+ Rewrite (N, New_Copy_Tree (A));
+
+ -- If the formal is class-wide, and thus not a
+ -- controlling argument, preserve its type because
+ -- it may appear in a nested call with a class-wide
+ -- parameter.
+
+ if Is_Class_Wide_Type (Etype (F)) then
+ Set_Etype (N, Etype (F));
+
+ -- Conversely, if this is a controlling argument
+ -- (in a dispatching call in the condition) that is a
+ -- dereference, the source is an access-to-class-wide
+ -- type, so preserve the dispatching nature of the
+ -- call in the rewritten condition.
+
+ elsif Nkind (Parent (N)) = N_Explicit_Dereference
+ and then Is_Controlling_Actual (Parent (N))
+ then
+ Set_Controlling_Argument (Parent (Parent (N)),
+ Parent (N));
+ end if;
+
+ exit;
+ end if;
+
+ Next_Formal (F);
+ Next_Actual (A);
+ end loop;
+
+ -- If the node is not analyzed, recognize occurrences of a
+ -- formal by name, as would be done when resolving the aspect
+ -- expression in the context of the subprogram.
+
+ elsif not Analyzed (N)
+ and then Nkind (N) = N_Identifier
+ and then No (Entity (N))
+ then
+ while Present (F) loop
+ if Chars (N) = Chars (F) then
+ Rewrite (N, New_Copy_Tree (A));
+ return Skip;
+ end if;
+
+ Next_Formal (F);
+ Next_Actual (A);
+ end loop;
+ end if;
+ end if;
+
+ return OK;
+ end Replace_Formals;
+
+ procedure Update is new Traverse_Proc (Replace_Formals);
+
+ -- Local variables
+
+ Str_Loc : constant String := Build_Location_String (Loc);
+
+ Cond : Node_Id;
+ Msg : Node_Id;
+ Prec : Node_Id;
+
+ -- Start of processing for Build_Class_Wide_Check
+
+ begin
+
+ -- Locate class-wide precondition, if any
+
+ if Present (Contract (Subp))
+ and then Present (Pre_Post_Conditions (Contract (Subp)))
+ then
+ Prec := Pre_Post_Conditions (Contract (Subp));
+
+ while Present (Prec) loop
+ exit when Pragma_Name (Prec) = Name_Precondition
+ and then Class_Present (Prec);
+ Prec := Next_Pragma (Prec);
+ end loop;
+
+ if No (Prec) or else Is_Ignored (Prec) then
+ return;
+ end if;
+
+ -- The expression for the precondition is analyzed within the
+ -- generated pragma. The message text is the last parameter of
+ -- the generated pragma, indicating source of precondition.
+
+ Cond :=
+ New_Copy_Tree
+ (Expression (First (Pragma_Argument_Associations (Prec))));
+ Update (Cond);
+
+ -- Build message indicating the failed precondition and the
+ -- dispatching call that caused it.
+
+ Msg := Expression (Last (Pragma_Argument_Associations (Prec)));
+ Name_Len := 0;
+ Append (Global_Name_Buffer, Strval (Msg));
+ Append (Global_Name_Buffer, " in dispatching call at ");
+ Append (Global_Name_Buffer, Str_Loc);
+ Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len));
+
+ Insert_Action (Call_Node,
+ Make_If_Statement (Loc,
+ Condition => Make_Op_Not (Loc, Cond),
+ Then_Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
+ Parameter_Associations => New_List (Msg)))));
+ end if;
+ end Build_Class_Wide_Check;
+
---------------
-- New_Value --
---------------
-- Local variables
New_Node : Node_Id;
- SCIL_Node : Node_Id;
+ SCIL_Node : Node_Id := Empty;
SCIL_Related_Node : Node_Id := Call_Node;
-- Start of processing for Expand_Dispatching_Call
Subp := Alias (Subp);
end if;
+ Build_Class_Wide_Check;
+
-- Definition of the class-wide type and the tagged type
-- If the controlling argument is itself a tag rather than a tagged
Next_Formal (Old_Formal);
exit when No (Old_Formal);
- Set_Next_Entity (New_Formal, New_Copy (Old_Formal));
- Next_Entity (New_Formal);
- Next_Actual (Param);
+ Link_Entities (New_Formal, New_Copy (Old_Formal));
+ Next_Entity (New_Formal);
+ Next_Actual (Param);
end loop;
- Set_Next_Entity (New_Formal, Empty);
+ Unlink_Next_Entity (New_Formal);
Set_Last_Entity (Subp_Typ, Extra);
end if;
procedure Expand_Interface_Conversion (N : Node_Id) is
function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id;
- -- Return the underlying record type of Typ.
+ -- Return the underlying record type of Typ
----------------------------
-- Underlying_Record_Type --
E : Entity_Id := Typ;
begin
- -- Handle access to class-wide interface types
+ -- Handle access types
if Is_Access_Type (E) then
- E := Etype (Directly_Designated_Type (E));
+ E := Directly_Designated_Type (E);
end if;
-- Handle class-wide types. This conversion can appear explicitly in
Opnd := Designated_Type (Opnd);
end if;
+ Opnd := Underlying_Record_Type (Opnd);
+
if not Is_Interface (Opnd)
and then Is_Ancestor (Iface_Typ, Opnd, Use_Full_View => True)
then
return;
end if;
+
+ -- When the type of the operand and the target interface type match,
+ -- it is generally safe to skip generating code to displace the
+ -- pointer to the object to reference the secondary dispatch table
+ -- associated with the target interface type. The exception to this
+ -- general rule is when the underlying object of the type conversion
+ -- is an object built by means of a dispatching constructor (since in
+ -- such case the expansion of the constructor call is a direct call
+ -- to an object primitive, i.e. without thunks, and the expansion of
+ -- the constructor call adds an explicit conversion to the target
+ -- interface type to force the displacement of the pointer to the
+ -- object to reference the corresponding secondary dispatch table
+ -- (cf. Make_DT and Expand_Dispatching_Constructor_Call)).
+
+ -- At this stage we cannot identify whether the underlying object is
+ -- a BIP object and hence we cannot skip generating the code to try
+ -- displacing the pointer to the object. However, under configurable
+ -- runtime it is safe to skip generating code to displace the pointer
+ -- to the object, because generic dispatching constructors are not
+ -- supported.
+
+ if Opnd = Iface_Typ and then not RTE_Available (RE_Displace) then
+ return;
+ end if;
end;
-- Evaluate if we can statically displace the pointer to the object
if not Tagged_Type_Expansion then
return;
- -- A static conversion to an interface type that is not classwide is
+ -- A static conversion to an interface type that is not class-wide is
-- curious but legal if the interface operation is a null procedure.
-- If the operation is abstract it will be rejected later.
if not Is_Static then
- -- Give error if configurable run time and Displace not available
+ -- Give error if configurable run-time and Displace not available
if not RTE_Available (RE_Displace) then
Error_Msg_CRT ("dynamic interface conversion", N);
end if;
Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
- pragma Assert (Iface_Tag /= Empty);
+ pragma Assert (Present (Iface_Tag));
-- Keep separate access types to interfaces because one internal
-- function is used to handle the null value (see following comments)
if Is_Access_Type (Etype (Expression (N))) then
- Apply_Accessibility_Check
- (N => Expression (N),
- Typ => Etype (N),
- Insert_Node => N);
-
-- Generate: Func (Address!(Expression))
Rewrite (N,
Formal : Entity_Id;
Formal_Typ : Entity_Id;
Subp : Entity_Id;
- Formal_DDT : Entity_Id;
- Actual_DDT : Entity_Id;
+ Formal_DDT : Entity_Id := Empty; -- initialize to prevent warning
+ Actual_DDT : Entity_Id := Empty; -- initialize to prevent warning
begin
-- This subprogram is called directly from the semantics, so we need a
while Present (Formal) loop
Formal_Typ := Etype (Formal);
+ if Has_Non_Limited_View (Formal_Typ) then
+ Formal_Typ := Non_Limited_View (Formal_Typ);
+ end if;
+
if Ekind (Formal_Typ) = E_Record_Type_With_Private then
Formal_Typ := Full_View (Formal_Typ);
end if;
if Is_Access_Type (Formal_Typ) then
Formal_DDT := Directly_Designated_Type (Formal_Typ);
+
+ if Has_Non_Limited_View (Formal_DDT) then
+ Formal_DDT := Non_Limited_View (Formal_DDT);
+ end if;
end if;
Actual_Typ := Etype (Actual);
+ if Has_Non_Limited_View (Actual_Typ) then
+ Actual_Typ := Non_Limited_View (Actual_Typ);
+ end if;
+
if Is_Access_Type (Actual_Typ) then
Actual_DDT := Directly_Designated_Type (Actual_Typ);
+
+ if Has_Non_Limited_View (Actual_DDT) then
+ Actual_DDT := Non_Limited_View (Actual_DDT);
+ end if;
end if;
if Is_Interface (Formal_Typ)
-- interface conversion, so if this is a BIP call then we need
-- to handle it now.
- if Ada_Version >= Ada_2005
- and then Is_Build_In_Place_Function_Call (Actual)
- then
+ if Is_Build_In_Place_Function_Call (Actual) then
Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
end if;
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 nonlimited view is already available,
+ -- we replace the anonymous access type by a duplicate
+ -- declaration whose designated type is the nonlimited view.
if Has_Non_Limited_View (Actual_DDT) then
Anon := New_Copy (Actual_Typ);
procedure Expand_Interface_Thunk
(Prim : Node_Id;
Thunk_Id : out Entity_Id;
- Thunk_Code : out Node_Id)
+ Thunk_Code : out Node_Id;
+ Iface : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Prim);
Actuals : constant List_Id := New_List;
Expr : Node_Id;
Formal : Node_Id;
Ftyp : Entity_Id;
- Iface_Formal : Node_Id;
+ Iface_Formal : Node_Id := Empty; -- initialize to prevent warning
+ Is_Predef_Op : constant Boolean :=
+ Is_Predefined_Dispatching_Operation (Prim)
+ or else Is_Predefined_Dispatching_Operation (Target);
New_Arg : Node_Id;
Offset_To_Top : Node_Id;
Target_Formal : Entity_Id;
-- No thunk needed if the primitive has been eliminated
- if Is_Eliminated (Ultimate_Alias (Prim)) then
+ if Is_Eliminated (Target) then
return;
-- In case of primitives that are functions without formals and a
-- actual object) generate code that modify its contents.
-- Note: This special management is not done for predefined primitives
- -- because???
+ -- because they don't have available the Interface_Alias attribute (see
+ -- Sem_Ch3.Add_Internal_Interface_Entities).
- if not Is_Predefined_Dispatching_Operation (Prim) then
+ if not Is_Predef_Op then
Iface_Formal := First_Formal (Interface_Alias (Prim));
end if;
-- Use the interface type as the type of the controlling formal (see
-- comment above).
- if not Is_Controlling_Formal (Formal)
- or else Is_Predefined_Dispatching_Operation (Prim)
- then
+ if not Is_Controlling_Formal (Formal) then
Ftyp := Etype (Formal);
Expr := New_Copy_Tree (Expression (Parent (Formal)));
+
+ -- For predefined primitives the controlling type of the thunk is
+ -- the interface type passed by the caller (since they don't have
+ -- available the Interface_Alias attribute; see comment above).
+
+ elsif Is_Predef_Op then
+ Ftyp := Iface;
+ Expr := Empty;
+
else
Ftyp := Etype (Iface_Formal);
Expr := Empty;
+
+ -- Sanity check performed to ensure the proper controlling type
+ -- when the thunk has exactly one controlling parameter and it
+ -- comes first. In such case the GCC backend reuses the C++
+ -- thunks machinery which perform a computation equivalent to
+ -- the code generated by the expander; for other cases the GCC
+ -- backend translates the expanded code unmodified. However, as
+ -- a generalization, the check is performed for all controlling
+ -- types.
+
+ if Is_Access_Type (Ftyp) then
+ pragma Assert (Base_Type (Designated_Type (Ftyp)) = Iface);
+ null;
+ else
+ Ftyp := Base_Type (Ftyp);
+ pragma Assert (Ftyp = Iface);
+ end if;
end if;
Append_To (Formals,
Parameter_Type => New_Occurrence_Of (Ftyp, Loc),
Expression => Expr));
- if not Is_Predefined_Dispatching_Operation (Prim) then
+ if not Is_Predef_Op then
Next_Formal (Iface_Formal);
end if;
-- Generate:
-- type T is access all <<type of the target formal>>
-- S : Storage_Offset := Storage_Offset!(Formal)
- -- - Offset_To_Top (address!(Formal))
+ -- + Offset_To_Top (address!(Formal))
Decl_2 :=
Make_Full_Type_Declaration (Loc,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
Expression =>
- Make_Op_Subtract (Loc,
+ Make_Op_Add (Loc,
Left_Opnd =>
Unchecked_Convert_To
(RTE (RE_Storage_Offset),
-- Generate:
-- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
- -- - Offset_To_Top (Formal'Address)
+ -- + Offset_To_Top (Formal'Address)
-- S2 : Addr_Ptr := Addr_Ptr!(S1)
New_Arg :=
Object_Definition =>
New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
Expression =>
- Make_Op_Subtract (Loc,
+ Make_Op_Add (Loc,
Left_Opnd =>
Unchecked_Convert_To
(RTE (RE_Storage_Offset),
Set_Ekind (Thunk_Id, Ekind (Prim));
Set_Is_Thunk (Thunk_Id);
Set_Convention (Thunk_Id, Convention (Prim));
+ Set_Needs_Debug_Info (Thunk_Id, Needs_Debug_Info (Target));
Set_Thunk_Entity (Thunk_Id, Target);
-- Procedure case
and then Is_Dispatch_Table_Entity (Etype (Name (N)));
end Is_Expanded_Dispatching_Call;
- -----------------------------------------
- -- Is_Predefined_Dispatching_Operation --
- -----------------------------------------
-
- function Is_Predefined_Dispatching_Operation
- (E : Entity_Id) return Boolean
- is
- TSS_Name : TSS_Name_Type;
-
- begin
- if not Is_Dispatching_Operation (E) then
- return False;
- end if;
-
- Get_Name_String (Chars (E));
-
- -- Most predefined primitives have internally generated names. Equality
- -- must be treated differently; the predefined operation is recognized
- -- as a homogeneous binary operator that returns Boolean.
-
- if Name_Len > TSS_Name_Type'Last then
- TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
- .. Name_Len));
- if Chars (E) = Name_uSize
- or else TSS_Name = TSS_Stream_Read
- or else TSS_Name = TSS_Stream_Write
- or else TSS_Name = TSS_Stream_Input
- or else TSS_Name = TSS_Stream_Output
- or else
- (Chars (E) = Name_Op_Eq
- and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
- or else Chars (E) = Name_uAssign
- or else TSS_Name = TSS_Deep_Adjust
- or else TSS_Name = TSS_Deep_Finalize
- or else Is_Predefined_Interface_Primitive (E)
- then
- return True;
- end if;
- end if;
-
- return False;
- end Is_Predefined_Dispatching_Operation;
-
- ---------------------------------------
- -- Is_Predefined_Internal_Operation --
- ---------------------------------------
-
- function Is_Predefined_Internal_Operation
- (E : Entity_Id) return Boolean
- is
- TSS_Name : TSS_Name_Type;
-
- begin
- if not Is_Dispatching_Operation (E) then
- return False;
- end if;
-
- Get_Name_String (Chars (E));
-
- -- Most predefined primitives have internally generated names. Equality
- -- must be treated differently; the predefined operation is recognized
- -- as a homogeneous binary operator that returns Boolean.
-
- if Name_Len > TSS_Name_Type'Last then
- TSS_Name :=
- TSS_Name_Type
- (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
-
- if Nam_In (Chars (E), Name_uSize, Name_uAssign)
- or else
- (Chars (E) = Name_Op_Eq
- and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
- or else TSS_Name = TSS_Deep_Adjust
- or else TSS_Name = TSS_Deep_Finalize
- or else Is_Predefined_Interface_Primitive (E)
- then
- return True;
- end if;
- end if;
-
- return False;
- end Is_Predefined_Internal_Operation;
-
-------------------------------------
-- Is_Predefined_Dispatching_Alias --
-------------------------------------
and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim));
end Is_Predefined_Dispatching_Alias;
- ---------------------------------------
- -- Is_Predefined_Interface_Primitive --
- ---------------------------------------
-
- function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is
- 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.
-
- return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion)
- 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;
-
----------------------------------------
-- Make_Disp_Asynchronous_Select_Body --
----------------------------------------
(Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
- Def_Id : constant Node_Id :=
+ B_Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
+ Def_Id : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Name_uDisp_Asynchronous_Select);
Params : constant List_Id := New_List;
-- B : out Dummy_Communication_Block; -- Communication block dummy
-- F : out Boolean; -- Status flag
+ -- The B parameter may be left uninitialized
+
+ Set_Warnings_Off (B_Id);
+
Append_List_To (Params, New_List (
Make_Parameter_Specification (Loc,
Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc,
- Defining_Identifier => Make_Defining_Identifier (Loc, Name_uB),
+ Defining_Identifier => B_Id,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Dummy_Communication_Block), Loc),
Out_Present => True),
(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_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 =>
-- ...
-- end;
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ);
DT_Aggr : constant Elist_Id := New_Elmt_List;
-- Entities marked with attribute Is_Dispatch_Table_Entity
+ Dummy_Object : Entity_Id := Empty;
+ -- Extra nonexistent object of type Typ internally used to compute the
+ -- offset to the components that reference secondary dispatch tables.
+ -- Used to compute the offset of components located at fixed position.
+
procedure Check_Premature_Freezing
(Subp : Entity_Id;
Tagged_Type : Entity_Id;
procedure Make_Secondary_DT
(Typ : Entity_Id;
Iface : Entity_Id;
+ Iface_Comp : Node_Id;
Suffix_Index : Int;
Num_Iface_Prims : Nat;
Iface_DT_Ptr : Entity_Id;
-- this secondary dispatch table by Make_Tags when its unique external
-- name was generated.
+ function Number_Of_Predefined_Prims (Typ : Entity_Id) return Nat;
+ -- Returns the number of predefined primitives of Typ
+
------------------------------
-- Check_Premature_Freezing --
------------------------------
procedure Make_Secondary_DT
(Typ : Entity_Id;
Iface : Entity_Id;
+ Iface_Comp : Node_Id;
Suffix_Index : Int;
Num_Iface_Prims : Nat;
Iface_DT_Ptr : Entity_Id;
DT_Constr_List : List_Id;
DT_Aggr_List : List_Id;
Empty_DT : Boolean := False;
- Nb_Predef_Prims : Nat := 0;
Nb_Prim : Nat;
New_Node : Node_Id;
OSD : Entity_Id;
OSD_Aggr_List : List_Id;
- Pos : Nat;
Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
Prim_Ops_Aggr_List : List_Id;
-- predef-prim-op-thunk-2'address,
-- ...
-- predef-prim-op-thunk-n'address);
- -- for Predef_Prims'Alignment use Address'Alignment
-
- -- Stage 1: Calculate the number of predefined primitives
-
- if not Building_Static_DT (Typ) then
- Nb_Predef_Prims := Max_Predef_Prims;
- else
- Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
- while Present (Prim_Elmt) loop
- Prim := Node (Prim_Elmt);
-
- if Is_Predefined_Dispatching_Operation (Prim)
- and then not Is_Abstract_Subprogram (Prim)
- then
- Pos := UI_To_Int (DT_Position (Prim));
-
- if Pos > Nb_Predef_Prims then
- Nb_Predef_Prims := Pos;
- end if;
- end if;
-
- Next_Elmt (Prim_Elmt);
- end loop;
- end if;
-
- if Generate_SCIL then
- Nb_Predef_Prims := 0;
- end if;
- -- Stage 2: Create the thunks associated with the predefined
- -- primitives and save their entity to fill the aggregate.
+ -- Create the thunks associated with the predefined primitives and
+ -- save their entity to fill the aggregate.
declare
- Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
+ Nb_P_Prims : constant Nat := Number_Of_Predefined_Prims (Typ);
+ Prim_Table : array (Nat range 1 .. Nb_P_Prims) of Entity_Id;
Decl : Node_Id;
Thunk_Id : Entity_Id;
Thunk_Code : Node_Id;
else
Expand_Interface_Thunk
- (Ultimate_Alias (Prim), Thunk_Id, Thunk_Code);
+ (Prim, Thunk_Id, Thunk_Code, Iface);
if Present (Thunk_Id) then
Append_To (Result, Thunk_Code);
- Prim_Table (UI_To_Int (DT_Position (Prim)))
- := Thunk_Id;
+ Prim_Table (UI_To_Int (DT_Position (Prim))) :=
+ Thunk_Id;
end if;
end if;
end if;
Object_Definition => New_Occurrence_Of
(Defining_Identifier (Decl), Loc),
Expression => New_Node));
-
- Append_To (Result,
- Make_Attribute_Definition_Clause (Loc,
- Name => New_Occurrence_Of (Predef_Prims, Loc),
- Chars => Name_Alignment,
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
- Attribute_Name => Name_Alignment)));
end;
-- Generate
-- (OSD_Table => (1 => <value>,
-- ...
-- N => <value>));
+ -- for OSD'Alignment use Address'Alignment;
-- Iface_DT : Dispatch_Table (Nb_Prims) :=
-- ([ Signature => <sig-value> ],
-- prim-op-2'address,
-- ...
-- prim-op-n'address));
- -- for Iface_DT'Alignment use Address'Alignment;
-- Stage 3: Initialize the discriminant and the record components
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
- -- subprogram
+ -- Interface component located at variable offset; the value of
+ -- Offset_To_Top will be set by the init subprogram.
- Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
+ if No (Dummy_Object)
+ or else Is_Variable_Size_Record (Etype (Scope (Iface_Comp)))
+ then
+ Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
+
+ -- Interface component located at fixed offset
+
+ else
+ Append_To (DT_Aggr_List,
+ Make_Op_Minus (Loc,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (Dummy_Object, Loc),
+ Selector_Name =>
+ New_Occurrence_Of (Iface_Comp, Loc)),
+ Attribute_Name => Name_Position)));
+ end if;
-- Generate the Object Specific Data table required to dispatch calls
-- through synchronized interfaces.
Prim_Table (Prim_Pos) := Alias (Prim);
else
- Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
+ Expand_Interface_Thunk
+ (Prim, Thunk_Id, Thunk_Code, Iface);
if Present (Thunk_Id) then
Prim_Pos :=
Append_Elmt (New_Node, DT_Aggr);
- -- Note: Secondary dispatch tables cannot be declared constant
- -- because the component Offset_To_Top is currently initialized
- -- by the IP routine.
+ -- Note: Secondary dispatch tables are declared constant only if
+ -- we can compute their offset field by means of the extra dummy
+ -- object; otherwise they cannot be declared constant and the
+ -- Offset_To_Top component is initialized by the IP routine.
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Iface_DT,
Aliased_Present => True,
- Constant_Present => False,
+ Constant_Present => Building_Static_Secondary_DT (Typ),
Object_Definition =>
Make_Subtype_Indication (Loc,
Make_Aggregate (Loc,
Expressions => DT_Aggr_List)));
- Append_To (Result,
- Make_Attribute_Definition_Clause (Loc,
- Name => New_Occurrence_Of (Iface_DT, Loc),
- Chars => Name_Alignment,
-
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
- Attribute_Name => Name_Alignment)));
-
if Exporting_Table then
Export_DT (Typ, Iface_DT, Suffix_Index);
Append_Elmt (Iface_DT, DT_Decl);
end Make_Secondary_DT;
+ --------------------------------
+ -- Number_Of_Predefined_Prims --
+ --------------------------------
+
+ function Number_Of_Predefined_Prims (Typ : Entity_Id) return Nat is
+ Nb_Predef_Prims : Nat := 0;
+
+ begin
+ if not Generate_SCIL then
+ declare
+ Prim : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+ Pos : Nat;
+
+ begin
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ if Is_Predefined_Dispatching_Operation (Prim)
+ and then not Is_Abstract_Subprogram (Prim)
+ then
+ Pos := UI_To_Int (DT_Position (Prim));
+
+ if Pos > Nb_Predef_Prims then
+ Nb_Predef_Prims := Pos;
+ end if;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end;
+ end if;
+
+ pragma Assert (Nb_Predef_Prims <= Max_Predef_Prims);
+ return Nb_Predef_Prims;
+ end Number_Of_Predefined_Prims;
+
-- Local variables
- Elab_Code : constant List_Id := New_List;
- Result : constant List_Id := New_List;
- Tname : constant Name_Id := Chars (Typ);
+ Elab_Code : constant List_Id := New_List;
+ Result : constant List_Id := New_List;
+ Tname : constant Name_Id := Chars (Typ);
+
+ -- When pragmas Discard_Names and No_Tagged_Streams simultaneously apply
+ -- we initialize the Expanded_Name and the External_Tag of this tagged
+ -- type with an empty string. This is useful to avoid exposing entity
+ -- names at binary level. It can be done when both pragmas apply because
+ -- (1) Discard_Names allows initializing Expanded_Name with an
+ -- implementation defined value (Ada RM Section C.5 (7/2)).
+ -- (2) External_Tag (combined with Internal_Tag) is used for object
+ -- streaming and No_Tagged_Streams inhibits the generation of
+ -- streams.
+
+ Discard_Names : constant Boolean :=
+ Present (No_Tagged_Streams_Pragma (Typ))
+ and then (Global_Discard_Names
+ or else Einfo.Discard_Names (Typ));
+
+ -- The following name entries are used by Make_DT to generate a number
+ -- of entities related to a tagged type. These entities may be generated
+ -- in a scope other than that of the tagged type declaration, and if
+ -- the entities for two tagged types with the same name happen to be
+ -- generated in the same scope, we have to take care to use different
+ -- names. This is achieved by means of a unique serial number appended
+ -- to each generated entity name.
+
+ Name_DT : constant Name_Id :=
+ New_External_Name (Tname, 'T', Suffix_Index => -1);
+ Name_Exname : constant Name_Id :=
+ New_External_Name (Tname, 'E', Suffix_Index => -1);
+ Name_HT_Link : constant Name_Id :=
+ New_External_Name (Tname, 'H', Suffix_Index => -1);
+ Name_Predef_Prims : constant Name_Id :=
+ New_External_Name (Tname, 'R', Suffix_Index => -1);
+ Name_SSD : constant Name_Id :=
+ New_External_Name (Tname, 'S', Suffix_Index => -1);
+ Name_TSD : constant Name_Id :=
+ New_External_Name (Tname, 'B', Suffix_Index => -1);
+
+ Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
+ Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
+ -- Save the Ghost-related attributes to restore on exit
+
AI : Elmt_Id;
AI_Tag_Elmt : Elmt_Id;
AI_Tag_Comp : Elmt_Id;
+ DT : Entity_Id;
DT_Aggr_List : List_Id;
DT_Constr_List : List_Id;
DT_Ptr : Entity_Id;
+ Exname : Entity_Id;
+ HT_Link : Entity_Id;
ITable : Node_Id;
I_Depth : Nat := 0;
Iface_Table_Node : Node_Id;
Name_ITable : Name_Id;
- Nb_Predef_Prims : Nat := 0;
Nb_Prim : Nat := 0;
New_Node : Node_Id;
Num_Ifaces : Nat := 0;
Parent_Typ : Entity_Id;
+ Predef_Prims : Entity_Id;
Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
Prim_Ops_Aggr_List : List_Id;
+ SSD : Entity_Id;
Suffix_Index : Int;
Typ_Comps : Elist_Id;
Typ_Ifaces : Elist_Id;
+ TSD : Entity_Id;
TSD_Aggr_List : List_Id;
TSD_Tags_List : List_Id;
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
+ -- Start of processing for Make_DT
- -- The following name entries are used by Make_DT to generate a number
- -- of entities related to a tagged type. These entities may be generated
- -- in a scope other than that of the tagged type declaration, and if
- -- the entities for two tagged types with the same name happen to be
- -- generated in the same scope, we have to take care to use different
- -- names. This is achieved by means of a unique serial number appended
- -- to each generated entity name.
-
- Name_DT : constant Name_Id :=
- New_External_Name (Tname, 'T', Suffix_Index => -1);
- Name_Exname : constant Name_Id :=
- New_External_Name (Tname, 'E', Suffix_Index => -1);
- Name_HT_Link : constant Name_Id :=
- New_External_Name (Tname, 'H', Suffix_Index => -1);
- Name_Predef_Prims : constant Name_Id :=
- New_External_Name (Tname, 'R', Suffix_Index => -1);
- Name_SSD : constant Name_Id :=
- New_External_Name (Tname, 'S', Suffix_Index => -1);
- Name_TSD : constant Name_Id :=
- New_External_Name (Tname, 'B', Suffix_Index => -1);
-
- -- Entities built with above names
-
- DT : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_DT);
- Exname : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_Exname);
- HT_Link : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_HT_Link);
- Predef_Prims : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_Predef_Prims);
- SSD : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_SSD);
- TSD : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_TSD);
-
- -- Start of processing for Make_DT
-
- begin
- pragma Assert (Is_Frozen (Typ));
+ begin
+ pragma Assert (Is_Frozen (Typ));
-- The tagged type being processed may be subject to pragma Ghost. Set
-- the mode now to ensure that any nodes generated during dispatch table
-- creation are properly marked as Ghost.
- Set_Ghost_Mode (Declaration_Node (Typ), Typ);
+ Set_Ghost_Mode (Typ);
-- Handle cases in which there is no need to build the dispatch table
or else No (Access_Disp_Table (Typ))
or else Is_CPP_Class (Typ)
then
- Ghost_Mode := Save_Ghost_Mode;
- return Result;
+ goto Leave;
elsif No_Run_Time_Mode then
Error_Msg_CRT ("tagged types", Typ);
- Ghost_Mode := Save_Ghost_Mode;
- return Result;
+ goto Leave;
elsif not RTE_Available (RE_Tag) then
Append_To (Result,
Make_Object_Declaration (Loc,
- Defining_Identifier => Node (First_Elmt
- (Access_Disp_Table (Typ))),
+ Defining_Identifier =>
+ Node (First_Elmt (Access_Disp_Table (Typ))),
Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc),
Constant_Present => True,
Expression =>
Analyze_List (Result, Suppress => All_Checks);
Error_Msg_CRT ("tagged types", Typ);
- Ghost_Mode := Save_Ghost_Mode;
- return Result;
+ goto Leave;
end if;
-- Ensure that the value of Max_Predef_Prims defined in a-tags is
if RTE_Available (RE_Interface_Data) then
if Max_Predef_Prims /= 15 then
Error_Msg_N ("run-time library configuration error", Typ);
- Ghost_Mode := Save_Ghost_Mode;
- return Result;
+ goto Leave;
end if;
else
if Max_Predef_Prims /= 9 then
Error_Msg_N ("run-time library configuration error", Typ);
Error_Msg_CRT ("tagged types", Typ);
- Ghost_Mode := Save_Ghost_Mode;
- return Result;
+ goto Leave;
end if;
end if;
+ DT := Make_Defining_Identifier (Loc, Name_DT);
+ Exname := Make_Defining_Identifier (Loc, Name_Exname);
+ HT_Link := Make_Defining_Identifier (Loc, Name_HT_Link);
+ Predef_Prims := Make_Defining_Identifier (Loc, Name_Predef_Prims);
+ SSD := Make_Defining_Identifier (Loc, Name_SSD);
+ TSD := Make_Defining_Identifier (Loc, Name_TSD);
+
-- Initialize Parent_Typ handling private types
Parent_Typ := Etype (Typ);
if Building_Static_DT (Typ) then
declare
- Save : constant Boolean := Freezing_Library_Level_Tagged_Type;
+ Saved_FLLTT : constant Boolean :=
+ Freezing_Library_Level_Tagged_Type;
+
+ Formal : Entity_Id;
+ Frnodes : List_Id;
Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
- Frnodes : List_Id;
begin
Freezing_Library_Level_Tagged_Type := True;
Prim := Node (Prim_Elmt);
Frnodes := Freeze_Entity (Prim, Typ);
- declare
- F : Entity_Id;
-
- begin
- F := First_Formal (Prim);
- while Present (F) loop
- Check_Premature_Freezing (Prim, Typ, Etype (F));
- Next_Formal (F);
+ -- We disable this check for abstract subprograms, given that
+ -- they cannot be called directly and thus the state of their
+ -- untagged formals is of no concern. The RM is unclear in any
+ -- case concerning the need for this check, and this topic may
+ -- go back to the ARG.
+
+ if not Is_Abstract_Subprogram (Prim) then
+ Formal := First_Formal (Prim);
+ while Present (Formal) loop
+ Check_Premature_Freezing (Prim, Typ, Etype (Formal));
+ Next_Formal (Formal);
end loop;
Check_Premature_Freezing (Prim, Typ, Etype (Prim));
- end;
+ end if;
if Present (Frnodes) then
Append_List_To (Result, Frnodes);
Next_Elmt (Prim_Elmt);
end loop;
- Freezing_Library_Level_Tagged_Type := Save;
+ Freezing_Library_Level_Tagged_Type := Saved_FLLTT;
+ end;
+ end if;
+
+ if not Is_Interface (Typ) and then Has_Interfaces (Typ) then
+ declare
+ Cannot_Have_Null_Disc : Boolean := False;
+ Dummy_Object_Typ : constant Entity_Id := Typ;
+ Name_Dummy_Object : constant Name_Id :=
+ New_External_Name (Tname,
+ 'P', Suffix_Index => -1);
+ begin
+ Dummy_Object := Make_Defining_Identifier (Loc, Name_Dummy_Object);
+
+ -- Define the extra object imported and constant to avoid linker
+ -- errors (since this object is never declared). Required because
+ -- we implement RM 13.3(19) for exported and imported (variable)
+ -- objects by making them volatile.
+
+ Set_Is_Imported (Dummy_Object);
+ Set_Ekind (Dummy_Object, E_Constant);
+ Set_Is_True_Constant (Dummy_Object);
+ Set_Related_Type (Dummy_Object, Typ);
+
+ -- The scope must be set now to call Get_External_Name
+
+ Set_Scope (Dummy_Object, Current_Scope);
+
+ Get_External_Name (Dummy_Object);
+ Set_Interface_Name (Dummy_Object,
+ Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
+
+ -- Ensure proper Sprint output of this implicit importation
+
+ Set_Is_Internal (Dummy_Object);
+
+ if not Has_Discriminants (Dummy_Object_Typ) then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Dummy_Object,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of
+ (Dummy_Object_Typ, Loc)));
+ else
+ declare
+ Constr_List : constant List_Id := New_List;
+ Discrim : Node_Id;
+
+ begin
+ Discrim := First_Discriminant (Dummy_Object_Typ);
+ while Present (Discrim) loop
+ if Is_Discrete_Type (Etype (Discrim)) then
+ Append_To (Constr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Etype (Discrim), Loc),
+ Attribute_Name => Name_First));
+
+ else
+ pragma Assert (Is_Access_Type (Etype (Discrim)));
+ Cannot_Have_Null_Disc :=
+ Cannot_Have_Null_Disc
+ or else Can_Never_Be_Null (Etype (Discrim));
+ Append_To (Constr_List, Make_Null (Loc));
+ end if;
+
+ Next_Discriminant (Discrim);
+ end loop;
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Dummy_Object,
+ Constant_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Dummy_Object_Typ, Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => Constr_List))));
+ end;
+ end if;
+
+ -- Given that the dummy object will not be declared at run time,
+ -- analyze its declaration with expansion disabled and warnings
+ -- and error messages ignored.
+
+ Expander_Mode_Save_And_Set (False);
+ Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
+ Analyze (Last (Result), Suppress => All_Checks);
+ Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
+ Expander_Mode_Restore;
end;
end if;
Make_Secondary_DT
(Typ => Typ,
- Iface => Base_Type
- (Related_Type (Node (AI_Tag_Comp))),
+ Iface =>
+ Base_Type (Related_Type (Node (AI_Tag_Comp))),
+ Iface_Comp => Node (AI_Tag_Comp),
Suffix_Index => Suffix_Index,
- Num_Iface_Prims => UI_To_Int
- (DT_Entry_Count (Node (AI_Tag_Comp))),
+ 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,
(Typ => Typ,
Iface => Base_Type
(Related_Type (Node (AI_Tag_Comp))),
+ Iface_Comp => Node (AI_Tag_Comp),
Suffix_Index => -1,
Num_Iface_Prims => UI_To_Int
(DT_Entry_Count (Node (AI_Tag_Comp))),
-- Generate:
-- DT : No_Dispatch_Table_Wrapper;
- -- for DT'Alignment use Address'Alignment;
-- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
if not Has_DT (Typ) then
New_Occurrence_Of
(RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
- Append_To (Result,
- Make_Attribute_Definition_Clause (Loc,
- Name => New_Occurrence_Of (DT, Loc),
- Chars => Name_Alignment,
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
- Attribute_Name => Name_Alignment)));
-
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => DT_Ptr,
Set_SCIL_Entity (New_Node, Typ);
Set_SCIL_Node (Last (Result), New_Node);
- goto Early_Exit_For_SCIL;
+ goto Leave_SCIL;
-- Gnat2scil has its own implementation of dispatch tables,
-- different than what is being implemented here. Generating
-- Generate:
-- DT : Dispatch_Table_Wrapper (Nb_Prim);
- -- for DT'Alignment use Address'Alignment;
-- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
else
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => DT_Constr_List))));
- Append_To (Result,
- Make_Attribute_Definition_Clause (Loc,
- Name => New_Occurrence_Of (DT, Loc),
- Chars => Name_Alignment,
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
- Attribute_Name => Name_Alignment)));
-
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => DT_Ptr,
Set_SCIL_Entity (New_Node, Typ);
Set_SCIL_Node (Last (Result), New_Node);
- goto Early_Exit_For_SCIL;
+ goto Leave_SCIL;
-- Gnat2scil has its own implementation of dispatch tables,
-- different than what is being implemented here. Generating
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Address), Loc),
- Expression =>
+ Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
end if;
end if;
+ -- Generate: Expanded_Name : constant String := "";
+
+ if Discard_Names then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Exname,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Standard_String, Loc),
+ Expression =>
+ Make_String_Literal (Loc, "")));
+
-- Generate: Exname : constant String := full_qualified_name (typ);
-- The type itself may be an anonymous parent type, so use the first
-- subtype to have a user-recognizable name.
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Exname,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Standard_String, Loc),
- Expression =>
- Make_String_Literal (Loc,
- Strval => Fully_Qualified_Name_String (First_Subtype (Typ)))));
+ else
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Exname,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Standard_String, Loc),
+ Expression =>
+ Make_String_Literal (Loc,
+ Fully_Qualified_Name_String (First_Subtype (Typ)))));
+ end if;
+
Set_Is_Statically_Allocated (Exname);
Set_Is_True_Constant (Exname);
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => HT_Link,
- Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc)));
+ Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc),
+ Expression => New_Occurrence_Of (RTE (RE_No_Tag), Loc)));
end if;
-- Generate code to create the storage for the type specific data object
-- External_Tag => Cstring_Ptr!(Exname'Address))
-- HT_Link => HT_Link'Address,
-- Transportable => <<boolean-value>>,
- -- Type_Is_Abstract => <<boolean-value>>,
+ -- Is_Abstract => <<boolean-value>>,
-- Needs_Finalization => <<boolean-value>>,
-- [ Size_Func => Size_Prim'Access, ]
-- [ Interfaces_Table => <<access-value>>, ]
-- Tags_Table => (0 => null,
-- 1 => Parent'Tag
-- ...);
- -- for TSD'Alignment use Address'Alignment
TSD_Aggr_List := New_List;
-- specified. That's an odd case for which we have already issued a
-- warning, where we will not be able to compute the internal tag.
- if not Is_Library_Level_Entity (Typ)
+ if not Discard_Names
+ and then not Is_Library_Level_Entity (Typ)
and then not Has_External_Tag_Rep_Clause (Typ)
then
declare
Right_Opnd =>
Make_String_Literal (Loc, Str2_Id)))));
+ -- Generate:
+ -- Exname : constant String := Str1 & Str2;
+
else
Append_To (Result,
Make_Object_Declaration (Loc,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (HT_Link, Loc),
Attribute_Name => Name_Address)));
- else
+
+ elsif RTE_Record_Component_Available (RE_HT_Link) then
Append_To (TSD_Aggr_List,
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
New_Occurrence_Of (Transportable, Loc));
end;
- -- Type_Is_Abstract (Ada 2012: AI05-0173). This functionality is
- -- not available in the HIE runtime.
+ -- Is_Abstract (Ada 2012: AI05-0173). This functionality is not
+ -- available in the HIE runtime.
- if RTE_Record_Component_Available (RE_Type_Is_Abstract) then
+ if RTE_Record_Component_Available (RE_Is_Abstract) then
declare
- Type_Is_Abstract : Entity_Id;
+ Is_Abstract : Entity_Id;
begin
- Type_Is_Abstract := Boolean_Literals (Is_Abstract_Type (Typ));
+ Is_Abstract := Boolean_Literals (Is_Abstract_Type (Typ));
Append_To (TSD_Aggr_List,
- New_Occurrence_Of (Type_Is_Abstract, Loc));
+ New_Occurrence_Of (Is_Abstract, Loc));
end;
end if;
declare
Prim_Elmt : Elmt_Id;
Prim : Entity_Id;
- Size_Comp : Node_Id;
+ Size_Comp : Node_Id := Empty;
begin
Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
else
declare
- TSD_Ifaces_List : constant List_Id := New_List;
- Elmt : Elmt_Id;
- Sec_DT_Tag : Node_Id;
+ TSD_Ifaces_List : constant List_Id := New_List;
+ Elmt : Elmt_Id;
+ Offset_To_Top : Node_Id;
+ Sec_DT_Tag : Node_Id;
+
+ Dummy_Object_Ifaces_List : Elist_Id := No_Elist;
+ Dummy_Object_Ifaces_Comp_List : Elist_Id := No_Elist;
+ Dummy_Object_Ifaces_Tag_List : Elist_Id := No_Elist;
+ -- Interfaces information of the dummy object
begin
+ -- Collect interfaces information if we need to compute the
+ -- offset to the top using the dummy object.
+
+ if Present (Dummy_Object) then
+ Collect_Interfaces_Info (Typ,
+ Ifaces_List => Dummy_Object_Ifaces_List,
+ Components_List => Dummy_Object_Ifaces_Comp_List,
+ Tags_List => Dummy_Object_Ifaces_Tag_List);
+ end if;
+
AI := First_Elmt (Typ_Ifaces);
while Present (AI) loop
if Is_Ancestor (Node (AI), Typ, Use_Full_View => True) then
- Sec_DT_Tag :=
- New_Occurrence_Of (DT_Ptr, Loc);
+ Sec_DT_Tag := New_Occurrence_Of (DT_Ptr, Loc);
+
else
Elmt :=
Next_Elmt
pragma Assert (Has_Thunks (Node (Elmt)));
while Is_Tag (Node (Elmt))
- and then not
- Is_Ancestor (Node (AI), Related_Type (Node (Elmt)),
- Use_Full_View => True)
+ and then not
+ Is_Ancestor (Node (AI), Related_Type (Node (Elmt)),
+ Use_Full_View => True)
loop
pragma Assert (Has_Thunks (Node (Elmt)));
Next_Elmt (Elmt);
pragma Assert (Ekind (Node (Elmt)) = E_Constant
and then not
Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt)))));
+
Sec_DT_Tag :=
- New_Occurrence_Of (Node (Next_Elmt (Next_Elmt (Elmt))),
- Loc);
+ New_Occurrence_Of
+ (Node (Next_Elmt (Next_Elmt (Elmt))), Loc);
+ end if;
+
+ -- Use the dummy object to compute Offset_To_Top of
+ -- components located at fixed position.
+
+ if Present (Dummy_Object) then
+ declare
+ Iface : constant Node_Id := Node (AI);
+ Iface_Comp : Node_Id := Empty;
+ Iface_Comp_Elmt : Elmt_Id;
+ Iface_Elmt : Elmt_Id;
+
+ begin
+ Iface_Elmt :=
+ First_Elmt (Dummy_Object_Ifaces_List);
+ Iface_Comp_Elmt :=
+ First_Elmt (Dummy_Object_Ifaces_Comp_List);
+
+ while Present (Iface_Elmt) loop
+ if Node (Iface_Elmt) = Iface then
+ Iface_Comp := Node (Iface_Comp_Elmt);
+ exit;
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ Next_Elmt (Iface_Comp_Elmt);
+ end loop;
+
+ pragma Assert (Present (Iface_Comp));
+
+ if not
+ Is_Variable_Size_Record (Etype (Scope (Iface_Comp)))
+ then
+ Offset_To_Top :=
+ Make_Op_Minus (Loc,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (Dummy_Object, Loc),
+ Selector_Name =>
+ New_Occurrence_Of (Iface_Comp, Loc)),
+ Attribute_Name => Name_Position));
+ else
+ Offset_To_Top := Make_Integer_Literal (Loc, 0);
+ end if;
+ end;
+ else
+ Offset_To_Top := Make_Integer_Literal (Loc, 0);
end if;
Append_To (TSD_Ifaces_List,
- Make_Aggregate (Loc,
- Expressions => New_List (
+ Make_Aggregate (Loc,
+ Expressions => New_List (
-- Iface_Tag
-- Offset_To_Top_Value
- Make_Integer_Literal (Loc, 0),
+ Offset_To_Top,
-- Offset_To_Top_Func
-- Secondary_DT
- Unchecked_Convert_To (RTE (RE_Tag), Sec_DT_Tag)
-
- )));
+ Unchecked_Convert_To (RTE (RE_Tag), Sec_DT_Tag))));
Next_Elmt (AI);
end loop;
Set_Is_Statically_Allocated (ITable,
Is_Library_Level_Tagged_Type (Typ));
- -- The table of interfaces is not constant; its slots are
- -- filled at run time by the IP routine using attribute
- -- 'Position to know the location of the tag components
- -- (and this attribute cannot be safely used before the
- -- object is initialized).
+ -- The table of interfaces is constant if we are building a
+ -- static dispatch table; otherwise is not constant because
+ -- its slots are filled at run time by the IP routine.
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => ITable,
Aliased_Present => True,
- Constant_Present => False,
+ Constant_Present => Building_Static_Secondary_DT (Typ),
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
Constraints => New_List (
Make_Integer_Literal (Loc, Num_Ifaces)))),
- Expression => Make_Aggregate (Loc,
- Expressions => New_List (
- Make_Integer_Literal (Loc, Num_Ifaces),
- Make_Aggregate (Loc, TSD_Ifaces_List)))));
-
- Append_To (Result,
- Make_Attribute_Definition_Clause (Loc,
- Name => New_Occurrence_Of (ITable, Loc),
- Chars => Name_Alignment,
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
- Attribute_Name => Name_Alignment)));
+ Expression =>
+ Make_Aggregate (Loc,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Num_Ifaces),
+ Make_Aggregate (Loc, TSD_Ifaces_List)))));
Iface_Table_Node :=
Make_Attribute_Reference (Loc,
Set_Is_True_Constant (TSD, Building_Static_DT (Typ));
- Append_To (Result,
- Make_Attribute_Definition_Clause (Loc,
- Name => New_Occurrence_Of (TSD, Loc),
- Chars => Name_Alignment,
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
- Attribute_Name => Name_Alignment)));
-
-- Initialize or declare the dispatch table object
if not Has_DT (Typ) then
-- DT : aliased constant No_Dispatch_Table :=
-- (NDT_TSD => TSD'Address;
-- NDT_Prims_Ptr => 0);
- -- for DT'Alignment use Address'Alignment;
else
Append_To (Result,
New_Occurrence_Of (RTE (RE_No_Dispatch_Table_Wrapper), Loc),
Expression => Make_Aggregate (Loc, DT_Aggr_List)));
- Append_To (Result,
- Make_Attribute_Definition_Clause (Loc,
- Name => New_Occurrence_Of (DT, Loc),
- Chars => Name_Alignment,
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
- Attribute_Name => Name_Alignment)));
-
Export_DT (Typ, DT);
end if;
-- predef-prim-op-2'address,
-- ...
-- predef-prim-op-n'address);
- -- for Predef_Prims'Alignment use Address'Alignment
-- DT : Dispatch_Table (Nb_Prims) :=
-- (Signature => <sig-value>,
else
declare
- Pos : Nat;
+ Nb_P_Prims : constant Nat := Number_Of_Predefined_Prims (Typ);
+ Prim_Table : array (Nat range 1 .. Nb_P_Prims) of Entity_Id;
+ Decl : Node_Id;
+ E : Entity_Id;
begin
- if not Building_Static_DT (Typ) then
- Nb_Predef_Prims := Max_Predef_Prims;
+ Prim_Ops_Aggr_List := New_List;
+ Prim_Table := (others => Empty);
- else
- Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ if Building_Static_DT (Typ) then
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
if Is_Predefined_Dispatching_Operation (Prim)
and then not Is_Abstract_Subprogram (Prim)
+ and then not Is_Eliminated (Prim)
+ and then not Generate_SCIL
+ and then not Present (Prim_Table
+ (UI_To_Int (DT_Position (Prim))))
then
- Pos := UI_To_Int (DT_Position (Prim));
-
- if Pos > Nb_Predef_Prims then
- Nb_Predef_Prims := Pos;
- end if;
+ E := Ultimate_Alias (Prim);
+ pragma Assert (not Is_Abstract_Subprogram (E));
+ Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
end if;
Next_Elmt (Prim_Elmt);
end loop;
end if;
- declare
- Prim_Table : array
- (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
- Decl : Node_Id;
- E : Entity_Id;
-
- begin
- Prim_Ops_Aggr_List := New_List;
-
- Prim_Table := (others => Empty);
-
- if Building_Static_DT (Typ) then
- Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
- while Present (Prim_Elmt) loop
- Prim := Node (Prim_Elmt);
-
- if Is_Predefined_Dispatching_Operation (Prim)
- and then not Is_Abstract_Subprogram (Prim)
- and then not Is_Eliminated (Prim)
- and then not Present (Prim_Table
- (UI_To_Int (DT_Position (Prim))))
- then
- E := Ultimate_Alias (Prim);
- pragma Assert (not Is_Abstract_Subprogram (E));
- Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
- end if;
-
- Next_Elmt (Prim_Elmt);
- end loop;
+ for J in Prim_Table'Range loop
+ if Present (Prim_Table (J)) then
+ New_Node :=
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Prim_Table (J), Loc),
+ Attribute_Name => Name_Unrestricted_Access));
+ else
+ New_Node := Make_Null (Loc);
end if;
- for J in Prim_Table'Range loop
- if Present (Prim_Table (J)) then
- New_Node :=
- Unchecked_Convert_To (RTE (RE_Prim_Ptr),
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Prim_Table (J), Loc),
- Attribute_Name => Name_Unrestricted_Access));
- else
- New_Node := Make_Null (Loc);
- end if;
-
- Append_To (Prim_Ops_Aggr_List, New_Node);
- end loop;
-
- New_Node :=
- Make_Aggregate (Loc,
- Expressions => Prim_Ops_Aggr_List);
+ Append_To (Prim_Ops_Aggr_List, New_Node);
+ end loop;
- Decl :=
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Make_Temporary (Loc, 'S'),
- Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Address_Array), Loc));
+ New_Node :=
+ Make_Aggregate (Loc,
+ Expressions => Prim_Ops_Aggr_List);
- Append_To (Result, Decl);
+ Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'S'),
+ Subtype_Indication =>
+ New_Occurrence_Of (RTE (RE_Address_Array), Loc));
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Predef_Prims,
- Aliased_Present => True,
- Constant_Present => Building_Static_DT (Typ),
- Object_Definition =>
- New_Occurrence_Of (Defining_Identifier (Decl), Loc),
- Expression => New_Node));
+ Append_To (Result, Decl);
- -- Remember aggregates initializing dispatch tables
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Predef_Prims,
+ Aliased_Present => True,
+ Constant_Present => Building_Static_DT (Typ),
+ Object_Definition =>
+ New_Occurrence_Of (Defining_Identifier (Decl), Loc),
+ Expression => New_Node));
- Append_Elmt (New_Node, DT_Aggr);
+ -- Remember aggregates initializing dispatch tables
- Append_To (Result,
- Make_Attribute_Definition_Clause (Loc,
- Name => New_Occurrence_Of (Predef_Prims, Loc),
- Chars => Name_Alignment,
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
- Attribute_Name => Name_Alignment)));
- end;
+ Append_Elmt (New_Node, DT_Aggr);
end;
-- Stage 1: Initialize the discriminant and the record components
-- Retrieve the ultimate alias of the primitive for proper
-- handling of renamings and eliminated primitives.
- E := Ultimate_Alias (Prim);
+ E := Ultimate_Alias (Prim);
+
+ -- If the alias is not a primitive operation then Prim does
+ -- not rename another primitive, but rather an operation
+ -- declared elsewhere (e.g. in another scope) and therefore
+ -- Prim is a new primitive.
+
+ if No (Find_Dispatching_Type (E)) then
+ E := Prim;
+ end if;
+
Prim_Pos := UI_To_Int (DT_Position (E));
-- Skip predefined primitives because they are located in a
Constraints => DT_Constr_List)),
Expression => Make_Aggregate (Loc, DT_Aggr_List)));
- Append_To (Result,
- Make_Attribute_Definition_Clause (Loc,
- Name => New_Occurrence_Of (DT, Loc),
- Chars => Name_Alignment,
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
- Attribute_Name => Name_Alignment)));
-
Export_DT (Typ, DT);
end if;
end if;
(Node
(Next_Elmt
(First_Elmt
- (Access_Disp_Table (Typ)))), Loc)));
+ (Access_Disp_Table (Typ)))), Loc),
+ Num_Predef_Prims =>
+ Number_Of_Predefined_Prims (Parent_Typ)));
if Nb_Prims /= 0 then
Append_To (Elab_Code,
Unchecked_Convert_To (RTE (RE_Tag),
New_Occurrence_Of
(Node (Next_Elmt (Sec_DT_Typ)),
- Loc))));
+ Loc)),
+ Num_Predef_Prims =>
+ Number_Of_Predefined_Prims
+ (Parent_Typ)));
if Num_Prims /= 0 then
Append_To (Elab_Code,
Unchecked_Convert_To (RTE (RE_Tag),
New_Occurrence_Of
(Node (Next_Elmt (Sec_DT_Typ)),
- Loc))));
+ Loc)),
+ Num_Predef_Prims =>
+ Number_Of_Predefined_Prims
+ (Parent_Typ)));
if Num_Prims /= 0 then
Append_To (Elab_Code,
-- applies to Ada 2005 (and Ada 2012). It might be argued that it is
-- a desirable check to add in Ada 95 mode, but we hesitate to make
-- this change, as it would be incompatible, and could conceivably
- -- cause a problem in existing Aa 95 code.
+ -- cause a problem in existing Ada 95 code.
-- We check for No_Run_Time_Mode here, because we do not want to pick
-- up the RE_Check_TSD entity and call it in No_Run_Time mode.
+ -- We cannot perform this check if the generation of its expanded name
+ -- was discarded.
+
if not No_Run_Time_Mode
+ and then not Discard_Names
and then Ada_Version >= Ada_2005
and then RTE_Available (RE_Check_TSD)
and then not Duplicated_Tag_Checks_Suppressed (Typ)
end;
end if;
- <<Early_Exit_For_SCIL>>
+ <<Leave_SCIL>>
-- Register the tagged type in the call graph nodes table
Register_CG_Node (Typ);
- Ghost_Mode := Save_Ghost_Mode;
+ <<Leave>>
+ Restore_Ghost_Region (Saved_GM, Saved_IGR);
+
return Result;
end Make_DT;
Loc : constant Source_Ptr := Sloc (Typ);
Conc_Typ : Entity_Id;
- Decls : List_Id;
+ Decls : List_Id := No_List;
Prim : Entity_Id;
Prim_Als : Entity_Id;
Prim_Elmt : Elmt_Id;
pragma Assert (No (Access_Disp_Table (Typ)));
Set_Access_Disp_Table (Typ, New_Elmt_List);
+ -- If the elaboration of this tagged type needs a boolean flag then
+ -- define now its entity. It is initialized to True to indicate that
+ -- elaboration is still pending; set to False by the IP routine.
+
+ -- TypFxx : boolean := True;
+
+ if Elab_Flag_Needed (Typ) then
+ Set_Access_Disp_Table_Elab_Flag (Typ,
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Tname, 'F')));
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Access_Disp_Table_Elab_Flag (Typ),
+ Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression => New_Occurrence_Of (Standard_True, Loc)));
+ end if;
+
-- 1) Generate the primary tag entities
-- Primary dispatch table containing user-defined primitives
Analyze_List (Result);
-- Generate:
- -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
+ -- subtype Typ_DT is Address_Array (1 .. Nb_Prims);
-- type Typ_DT_Acc is access Typ_DT;
else
Name_DT_Prims_Acc);
begin
Append_To (Result,
- Make_Full_Type_Declaration (Loc,
+ Make_Subtype_Declaration (Loc,
Defining_Identifier => DT_Prims,
- Type_Definition =>
- Make_Constrained_Array_Definition (Loc,
- Discrete_Subtype_Definitions => New_List (
- Make_Range (Loc,
- Low_Bound => Make_Integer_Literal (Loc, 1),
- High_Bound => Make_Integer_Literal (Loc,
- DT_Entry_Count
- (First_Tag_Component (Typ))))),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Prim_Ptr), Loc)))));
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_Address_Array), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc, New_List (
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound =>
+ Make_Integer_Literal (Loc,
+ DT_Entry_Count
+ (First_Tag_Component (Typ)))))))));
Append_To (Result,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => DT_Prims_Acc,
- Type_Definition =>
+ Type_Definition =>
Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (DT_Prims, Loc))));
return L;
end if;
- Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
+ Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code, Iface_Typ);
if not Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True)
and then Present (Thunk_Code)
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
Prefix =>
- New_Occurrence_Of (Alias (Prim), Loc),
+ New_Occurrence_Of (Ultimate_Alias (Prim), Loc),
Attribute_Name => Name_Unrestricted_Access))));
end if;
------------------------
function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean is
- E : Entity_Id;
-
begin
-- Predefined primitives
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
+ -- An overriding operation that is a user-defined renaming of
+ -- predefined equality inherits its slot from the overridden
+ -- operation. Otherwise it is treated as a predefined op and
+ -- occupies the same predefined slot as equality. A call to it is
+ -- transformed into a call to its alias, which is the predefined
+ -- equality op. A dispatching call thus uses the proper slot if
+ -- operation is further inherited and called with class-wide
+ -- arguments.
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);
+ return
+ not Comes_From_Source (Prim)
+ or else No (Overridden_Operation (Prim));
end if;
-- User-defined primitives
Set_DT_Position_Value (Alias (Prim), DT_Position (E));
Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
- -- Overriding primitives must use the same entry as the
- -- overridden primitive.
+ -- Overriding primitives must use the same entry as the overridden
+ -- primitive. Note that the Alias of the operation is set when the
+ -- operation is declared by a renaming, in which case it is not
+ -- overriding. If it renames another primitive it will use the
+ -- same dispatch table slot, but if it renames an operation in a
+ -- nested package it's a new primitive and will have its own slot.
elsif not Present (Interface_Alias (Prim))
and then Present (Alias (Prim))
and then Chars (Prim) = Chars (Alias (Prim))
- and then Find_Dispatching_Type (Alias (Prim)) /= Typ
- and then Is_Ancestor
- (Find_Dispatching_Type (Alias (Prim)), Typ,
- Use_Full_View => True)
- and then Present (DTC_Entity (Alias (Prim)))
+ and then Nkind (Unit_Declaration_Node (Prim)) /=
+ N_Subprogram_Renaming_Declaration
then
- E := Alias (Prim);
- Set_DT_Position_Value (Prim, DT_Position (E));
+ declare
+ Par_Type : constant Entity_Id :=
+ Find_Dispatching_Type (Alias (Prim));
- if not Is_Predefined_Dispatching_Alias (E) then
- Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
- end if;
+ begin
+ if Present (Par_Type)
+ and then Par_Type /= Typ
+ and then Is_Ancestor (Par_Type, Typ, Use_Full_View => True)
+ and then Present (DTC_Entity (Alias (Prim)))
+ then
+ E := Alias (Prim);
+ Set_DT_Position_Value (Prim, DT_Position (E));
+
+ if not Is_Predefined_Dispatching_Alias (E) then
+ Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
+ end if;
+ end if;
+ end;
end if;
Next_Elmt (Prim_Elmt);
function Gen_Parameters_Profile (E : Entity_Id) return List_Id;
-- Duplicate the parameters profile of the imported C++ constructor
- -- adding an access to the object as an additional parameter.
+ -- adding the "this" pointer to the object as the additional first
+ -- parameter under the usual form _Init : in out Typ.
----------------------------
-- Gen_Parameters_Profile --
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uInit),
+ In_Present => True,
+ Out_Present => True,
Parameter_Type => New_Occurrence_Of (Typ, Loc)));
if Present (Parameter_Specifications (Parent (E))) then
Found := True;
Loc := Sloc (E);
Parms := Gen_Parameters_Profile (E);
- IP :=
- Make_Defining_Identifier (Loc,
- Chars => Make_Init_Proc_Name (Typ));
+ IP := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
-- Case 1: Constructor of untagged type
-- Case 2: Constructor of a tagged type
- -- In this case we generate the IP as a wrapper of the the
- -- C++ constructor because IP must also save copy of the _tag
+ -- In this case we generate the IP routine as a wrapper of the
+ -- C++ constructor because IP must also save a copy of the _tag
-- generated in the C++ side. The copy of the _tag is used by
-- Build_CPP_Init_Procedure to elaborate derivations of C++ types.
-- Generate:
- -- procedure IP (_init : Typ; ...) is
- -- procedure ConstructorP (_init : Typ; ...);
+ -- procedure IP (_init : in out Typ; ...) is
+ -- procedure ConstructorP (_init : in out Typ; ...);
-- pragma Import (ConstructorP);
-- begin
-- ConstructorP (_init, ...);
loop
-- Skip the following assertion with primary tags
-- because Related_Type is not set on primary tag
- -- components
+ -- components.
pragma Assert
(Tag_Comp = First_Tag_Component (Typ)
projects / thirdparty / gcc.git / blobdiff