Skip to content

R
riscv-gcc-1
Commit dee4682a by Javier Miranda Committed by Arnaud Charlet
Options

exp_ch13.adb (Expand_External_Tag_Definition): Replace call to the run-time… 

exp_ch13.adb (Expand_External_Tag_Definition): Replace call to the run-time subprogram Set_External_Tag by call to...

2007-04-06  Javier Miranda  <miranda@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* exp_ch13.adb (Expand_External_Tag_Definition): Replace call to the
	run-time subprogram Set_External_Tag by call to Build_Set_External_Tag.

	* exp_ch4.adb (Expand_Allocator_Expression): Don't perform a run-time
	accessibility on class-wide allocators if the allocator occurs at the
	same scope level as the allocator's type. The check is guaranteed to
	succeed in that case, even when the expression originates from a
	parameter of the containing subprogram.
	(Expand_N_Op_Eq): Do nothing in case of dispatching call if compiling
	under No_Dispatching_Calls restriction. During the semantic analysis
	we already notified such violation.
	(Tagged_Membership): Constant folding. There is no need to check
	the tag at run-time if the type of the right operand is non
	class-wide abstract.
	Replace call to Is_Ancestor by call to Is_Parent
	to support concurrent types with interface types.
	(Expand_N_Allocator): Add an assertion associated with the generation
	of the master_id.
	(Expand_N_Slice): Do not enable range check to nodes associated
	with the frontend expansion of the dispatch table.
	(Is_Local_Access_Discriminant): Subsidiary function to
	Expand_N_Allocator.
	(Tagged_Membership): Replace generation of call to the run-time
	subprogram CW_Membership by call to Build_CW_Membership.
	(Expand_Allocator_Expression): Replace generation of call to the
	run-time subprogram Get_Access_Level by call to Build_Get_Access_Level.

	* exp_disp.ads, exp_disp.adb (Make_DT): Code reorganization to
	initialize most the TSD components by means of an aggregate.
	Modify the declaration of the object containing the TSD
	because we now expand code that has a higher level of abstraction.
	The TSD has a discriminant containing the Inheritance Depth Level,
	value that is used in the membership test but also to fix the size
	of the table of ancestors.
	(Expand_Interface_Conversion): Insert function body at the closest place
	to the conversion expression, to prevent access-before-elaboration
	errors in the backend.
	Code improved to reduce the size of the dispatch table if
	compiling under restriction No_Dispatching_Calls plus code cleanup.
	Code reorganization plus removal of calls to Set_Num_Prim_Ops
	(Make_Secondary_DT): Remove call to Set_Num_Prim_Ops.
	(Expand_Dispatching_Call): Minor code reorganization plus addition of
	code to return immediately if compiling under No_Dispatching_Calls
	restriction.
	(Set_All_DT_Position): Remove code associated with the old CPP pragmas.
	CPP_Virtual and CPP_Vtable are no longer supported.
	(Expand_Interface_Conversion): Add missing support for interface type
	derivations.
	(Expand_Interface_Actuals): Replace calls to Is_Ancestor by calls to
	Is_Parent to support concurrent types with interfaces.
	(Init_Predefined_Interface_Primitives): Removed.
	(Make_Secondary_DT): Modified to support concurrent record types.
	(Set_All_DT_Position): Modified to support concurrent record types.
	(Ada_Actions, Action_Is_Proc, Action_Nb_Arg): Remove entries associated
	with Get_External_Tag, Inherit_TSD, Set_External_Tag.
	(Ada_Actions, Action_Is_Proc, Action_Nb_Arg): Remove entry associated
	with CW_Membership.
	(Ada_Actions, Action_Is_Proc, Action_Nb_Arg): Remove entries associated
	with Get_Access_Level, Get_Predefined_Prim_Op_Address,
	Get_Prim_Op_Address Get_RC_Offset, Get_Remotely_Callable, Inherit_DT,
	Set_Access_Level, Set_Expanded_Name, Set_Predefined_Prim_Op_Address,
	Set_Prim_Op_Address, Set_RC_Offset, Set_Remotely_Callable, Set_TSD.
	(Expand_Dispatching_Call): Replace generation of call to the run-time
	subprograms Get_Predefined_Prim_Op_Address and Get_Prim_Op_Address by
	calls to Build_Get_Predefined_Prim_Op_Address, and Build_Get_Prim_Op_
	Address.
	(Fill_DT_Entry, Fill_Secondary_DT_Entry): Replace generation of call to
	the run-time subprograms Set_Predefined_Prim_Op_Address and Set_Prim_
	Op_Address by calls to Build_Set_Predefined_Prim_Op_Address, and
	Build_Set_Prim_Op_Address.
	(Get_Remotely_Callable): Subprogram removed.
	(Init_Predefined_Interface_Primitives): Replace generation of call to
	the run-time subprograms Inherit_DT by call to Build_Inherit_Predefined_
	Prims.

	* sem_elab.adb (Set_Elaboration_Constraint): Replace the call to
	First (Parameter_Associations ()) with the call to First_Actual that
	returns an actual parameter expression for both named and positional
	associations.

	* sem_disp.adb (Check_Dispatching_Call): In case of dispatching call
	check violation of restriction No_Dispatching_Calls.
	(Check_Controlling_Type): A formal of a tagged incomplete type is a
	controlling argument.

	* exp_util.ads, exp_util.adb (Type_May_Have_Bit_Aligned_Components): Use
	First/Next_Component_Or_Discriminant
	(Insert_Actions): Add entries for new N_Push and N_Pop nodes
	(Find_Implemented_Interface): Removed. All the calls to this subprogram
	specify Any_Limited_Interface, and this functionality is already
	provided by the function Has_Abstract_Interfaces.
	(Find_Interface, Find_Interface_Tag, Find_Interface_ADT): Modified to
	support concurrent types implementing interfaces.
	(Find_Implemented_Interface): Removed. All the calls to this subprogram
	specify kind Any_Limited_Interface, and this functionality is already
	provided by the function Has_Abstract_Interfaces.
	(Remove_Side_Effects): replace Controlled_Type by
	CW_Or_Controlled_Type whenever the issue is related to
	using or not the secondary stack.

	* par-ch12.adb (P_Formal_Type_Definition): Update calls to
	P_Interface_Type_Definition to fulfill the new interface (the formal
	Is_Synchronized is no longer required).

	* Make-lang.in (GNAT_ADA_OBJS): Addition of exp_atag.o
	Update dependencies.

	* exp_atag.ads, exp_atag.adb: New file

From-SVN: r123562
parent 5277cab6
Showing with 2531 additions and 1986 deletions
gcc/ada/Make-lang.in
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/exp_atag.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ A T A G --
-- --
-- S p e c --
-- --
-- Copyright (C) 2006, 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Exp_Util; use Exp_Util;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
package body Exp_Atag is
-----------------------
-- Local Subprograms --
-----------------------
function Build_Predefined_DT
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id;
-- Build code that displaces the Tag to reference the dispatch table
-- containing the predefined primitives.
--
-- Generates: To_Tag (To_Address (Tag_Node) - DT_Prologue_Size);
pragma Inline (Build_Predefined_DT);
function Build_Typeinfo_Offset (Loc : Source_Ptr) return Node_Id;
-- Build code that gives access to the distance from the tag to the
-- Typeinfo component of the dispatch table.
--
-- Generates: DT_Typeinfo_Ptr_Size
pragma Inline (Build_Typeinfo_Offset);
function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id;
-- Build code that retrieves the address of the record containing the Type
-- Specific Data generated by GNAT.
--
-- Generate: To_Type_Specific_Data_Ptr
-- (To_Address_Ptr (To_Address (Tag) - Typeinfo_Offset).all);
pragma Inline (Build_TSD);
function RTE_Tag_Node return Entity_Id;
-- Returns the entity associated with Ada.Tags.Tag
pragma Inline (RTE_Tag_Node);
-------------------------
-- Build_CW_Membership --
-------------------------
function Build_CW_Membership
(Loc : Source_Ptr;
Obj_Tag_Node : Node_Id;
Typ_Tag_Node : Node_Id) return Node_Id
is
function Build_Pos return Node_Id;
-- Generate TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
function Build_Pos return Node_Id is
begin
return
Make_Op_Subtract (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Duplicate_Subexpr (Obj_Tag_Node)),
Selector_Name =>
New_Reference_To (RTE_Record_Component (RE_Idepth), Loc)),
Right_Opnd =>
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Duplicate_Subexpr (Typ_Tag_Node)),
Selector_Name =>
New_Reference_To (RTE_Record_Component (RE_Idepth), Loc)));
end Build_Pos;
-- Start of processing for Build_CW_Membership
begin
return
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Ge (Loc,
Left_Opnd => Build_Pos,
Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
Right_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Indexed_Component (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Obj_Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Tags_Table), Loc)),
Expressions =>
New_List (Build_Pos)),
Right_Opnd => Typ_Tag_Node));
end Build_CW_Membership;
----------------------------
-- Build_Get_Access_Level --
----------------------------
function Build_Get_Access_Level
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id
is
begin
return
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Access_Level), Loc));
end Build_Get_Access_Level;
------------------------------------------
-- Build_Get_Predefined_Prim_Op_Address --
------------------------------------------
function Build_Get_Predefined_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position_Node : Node_Id) return Node_Id
is
begin
return
Make_Indexed_Component (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Build_Predefined_DT (Loc, Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Expressions =>
New_List (Position_Node));
end Build_Get_Predefined_Prim_Op_Address;
-------------------------------
-- Build_Get_Prim_Op_Address --
-------------------------------
function Build_Get_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position_Node : Node_Id) return Node_Id
is
begin
return
Make_Indexed_Component (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To
(RTE_Tag_Node, Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Expressions => New_List (Position_Node));
end Build_Get_Prim_Op_Address;
-------------------------
-- Build_Get_RC_Offset --
-------------------------
function Build_Get_RC_Offset
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id
is
begin
return
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_RC_Offset), Loc));
end Build_Get_RC_Offset;
---------------------------------
-- Build_Get_Remotely_Callable --
---------------------------------
function Build_Get_Remotely_Callable
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id
is
begin
return
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Remotely_Callable), Loc));
end Build_Get_Remotely_Callable;
------------------------------------
-- Build_Inherit_Predefined_Prims --
------------------------------------
function Build_Inherit_Predefined_Prims
(Loc : Source_Ptr;
Old_Tag_Node : Node_Id;
New_Tag_Node : Node_Id) return Node_Id
is
begin
return
Make_Assignment_Statement (Loc,
Name =>
Make_Slice (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Build_Predefined_DT (Loc, New_Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Discrete_Range => Make_Range (Loc,
Make_Integer_Literal (Loc, Uint_1),
New_Reference_To (RTE (RE_Default_Prim_Op_Count), Loc))),
Expression =>
Make_Slice (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Build_Predefined_DT (Loc, Old_Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Discrete_Range =>
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 1),
High_Bound =>
New_Reference_To (RTE (RE_Default_Prim_Op_Count), Loc))));
end Build_Inherit_Predefined_Prims;
-------------------------
-- Build_Inherit_Prims --
-------------------------
function Build_Inherit_Prims
(Loc : Source_Ptr;
Old_Tag_Node : Node_Id;
New_Tag_Node : Node_Id;
Num_Prims : Nat) return Node_Id
is
begin
return
Make_Assignment_Statement (Loc,
Name =>
Make_Slice (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (RTE_Tag_Node, New_Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Discrete_Range =>
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 1),
High_Bound => Make_Integer_Literal (Loc, Num_Prims))),
Expression =>
Make_Slice (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (RTE_Tag_Node, Old_Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Discrete_Range =>
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 1),
High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
end Build_Inherit_Prims;
-------------------
-- Build_New_TSD --
-------------------
function Build_New_TSD
(Loc : Source_Ptr;
New_Tag_Node : Node_Id) return List_Id
is
begin
return New_List (
Make_Assignment_Statement (Loc,
Name =>
Make_Indexed_Component (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Duplicate_Subexpr (New_Tag_Node)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Tags_Table), Loc)),
Expressions => New_List (Make_Integer_Literal (Loc, Uint_0))),
Expression => New_Tag_Node));
end Build_New_TSD;
-----------------------
-- Build_Inherit_TSD --
-----------------------
function Build_Inherit_TSD
(Loc : Source_Ptr;
Old_Tag_Node : Node_Id;
New_Tag_Node : Node_Id;
I_Depth : Nat;
Parent_Num_Ifaces : Nat) return Node_Id
is
function Build_Iface_Table_Ptr (Tag_Node : Node_Id) return Node_Id;
-- Generates: Interface_Data_Ptr! (TSD (Tag).Ifaces_Table_Ptr).all
----------------------------
-- Build_Iface_Table_Ptr --
----------------------------
function Build_Iface_Table_Ptr (Tag_Node : Node_Id) return Node_Id is
begin
return
Unchecked_Convert_To (RTE (RE_Interface_Data_Ptr),
Make_Selected_Component (Loc,
Prefix => Tag_Node,
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Ifaces_Table_Ptr), Loc)));
end Build_Iface_Table_Ptr;
-- Local variables
L : constant List_Id := New_List;
Old_TSD : Node_Id;
New_TSD : Node_Id;
-- Start of processing for Build_Inherit_TSD
begin
Old_TSD :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, New_Internal_Name ('T')),
Object_Definition =>
New_Reference_To (RTE (RE_Type_Specific_Data_Ptr), Loc),
Expression =>
Build_TSD (Loc, Duplicate_Subexpr (Old_Tag_Node)));
New_TSD :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, New_Internal_Name ('T')),
Object_Definition =>
New_Reference_To (RTE (RE_Type_Specific_Data_Ptr), Loc),
Expression =>
Build_TSD (Loc, Duplicate_Subexpr (New_Tag_Node)));
Append_List_To (L, New_List (
-- Copy the table of ancestors of the parent
-- TSD (New_Tag).Tags_Table (1 .. I_Depth) :=
-- TSD (Old_Tag).Tags_Table (0 .. I_Depth - 1);
Make_Assignment_Statement (Loc,
Name =>
Make_Slice (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Explicit_Dereference (Loc,
New_Reference_To (Defining_Identifier (New_TSD), Loc)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Tags_Table), Loc)),
Discrete_Range => Make_Range (Loc,
Make_Integer_Literal (Loc, Uint_1),
Make_Integer_Literal (Loc, I_Depth))),
Expression =>
Make_Slice (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Explicit_Dereference (Loc,
New_Reference_To (Defining_Identifier (Old_TSD), Loc)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Tags_Table), Loc)),
Discrete_Range => Make_Range (Loc,
Make_Integer_Literal (Loc, Uint_0),
Make_Integer_Literal (Loc, I_Depth - 1))))));
-- Copy the table of interfaces of the parent
-- if not System."=" (TSD (Old_Tag).Ifaces_Table_Ptr,
-- System.Null_Address)
-- then
-- New_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces):=
-- Old_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces);
-- end if;
-- The table of interfaces is not available under certified run-time
if RTE_Record_Component_Available (RE_Nb_Ifaces) then
Append_To (L,
Make_If_Statement (Loc,
Condition =>
Make_Op_Not (Loc,
Right_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
Prefix =>
Make_Explicit_Dereference (Loc,
New_Reference_To
(Defining_Identifier (Old_TSD), Loc)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Ifaces_Table_Ptr),
Loc)),
Right_Opnd =>
New_Reference_To (RTE (RE_Null_Address), Loc))),
Then_Statements => New_List (
Make_Assignment_Statement (Loc,
Name =>
Make_Slice (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Build_Iface_Table_Ptr
(New_Reference_To
(Defining_Identifier (New_TSD), Loc)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Ifaces_Table), Loc)),
Discrete_Range => Make_Range (Loc,
Make_Integer_Literal (Loc, Uint_1),
Make_Integer_Literal (Loc, Parent_Num_Ifaces))),
Expression =>
Make_Slice (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Build_Iface_Table_Ptr
(New_Reference_To
(Defining_Identifier (Old_TSD), Loc)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Ifaces_Table), Loc)),
Discrete_Range => Make_Range (Loc,
Make_Integer_Literal (Loc, Uint_1),
Make_Integer_Literal (Loc, Parent_Num_Ifaces)))))));
end if;
-- TSD (New_Tag).Tags_Table (0) := New_Tag;
Append_To (L,
Make_Assignment_Statement (Loc,
Name =>
Make_Indexed_Component (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Explicit_Dereference (Loc,
New_Reference_To
(Defining_Identifier (New_TSD), Loc)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Tags_Table), Loc)),
Expressions =>
New_List (Make_Integer_Literal (Loc, Uint_0))),
Expression => New_Tag_Node));
return
Make_Block_Statement (Loc,
Declarations => New_List (
Old_TSD,
New_TSD),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, L));
end Build_Inherit_TSD;
-------------------------
-- Build_Predefined_DT --
-------------------------
function Build_Predefined_DT
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id
is
begin
return
Unchecked_Convert_To (RTE_Tag_Node,
Make_Function_Call (Loc,
Name =>
Make_Expanded_Name (Loc,
Chars => Name_Op_Subtract,
Prefix =>
New_Reference_To (RTU_Entity (System_Storage_Elements), Loc),
Selector_Name =>
Make_Identifier (Loc,
Chars => Name_Op_Subtract)),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
New_Reference_To (RTE (RE_DT_Prologue_Size), Loc))));
end Build_Predefined_DT;
----------------------------
-- Build_Set_External_Tag --
----------------------------
function Build_Set_External_Tag
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Value_Node : Node_Id) return Node_Id
is
begin
return
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RO_TA_External_Tag), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Value_Node));
end Build_Set_External_Tag;
------------------------------------------
-- Build_Set_Predefined_Prim_Op_Address --
------------------------------------------
function Build_Set_Predefined_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position_Node : Node_Id;
Address_Node : Node_Id) return Node_Id
is
begin
return
Make_Assignment_Statement (Loc,
Name => Build_Get_Predefined_Prim_Op_Address
(Loc, Tag_Node, Position_Node),
Expression => Address_Node);
end Build_Set_Predefined_Prim_Op_Address;
-------------------------------
-- Build_Set_Prim_Op_Address --
-------------------------------
function Build_Set_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position_Node : Node_Id;
Address_Node : Node_Id) return Node_Id
is
begin
return
Make_Assignment_Statement (Loc,
Name => Build_Get_Prim_Op_Address (Loc,
Tag_Node, Position_Node),
Expression => Address_Node);
end Build_Set_Prim_Op_Address;
-------------------
-- Build_Set_TSD --
-------------------
function Build_Set_TSD
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Value_Node : Node_Id) return Node_Id
is
begin
return
Make_Assignment_Statement (Loc,
Name =>
Make_Explicit_Dereference (Loc,
Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr),
Make_Function_Call (Loc,
Name =>
Make_Expanded_Name (Loc,
Chars => Name_Op_Subtract,
Prefix =>
New_Reference_To
(RTU_Entity (System_Storage_Elements), Loc),
Selector_Name =>
Make_Identifier (Loc,
Chars => Name_Op_Subtract)),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
Build_Typeinfo_Offset (Loc))))),
Expression => Value_Node);
end Build_Set_TSD;
---------------
-- Build_TSD --
---------------
function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id is
begin
return
Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr),
Make_Explicit_Dereference (Loc,
Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr),
Make_Function_Call (Loc,
Name =>
Make_Expanded_Name (Loc,
Chars => Name_Op_Subtract,
Prefix =>
New_Reference_To
(RTU_Entity (System_Storage_Elements), Loc),
Selector_Name =>
Make_Identifier (Loc,
Chars => Name_Op_Subtract)),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
Build_Typeinfo_Offset (Loc))))));
end Build_TSD;
---------------------------
-- Build_Typeinfo_Offset --
---------------------------
function Build_Typeinfo_Offset (Loc : Source_Ptr) return Node_Id is
begin
return New_Reference_To (RTE (RE_DT_Typeinfo_Ptr_Size), Loc);
end Build_Typeinfo_Offset;
---------------
-- Tag_Node --
---------------
function RTE_Tag_Node return Entity_Id is
E : constant Entity_Id := RTE (RE_Tag);
begin
if Atree.Present (Full_View (E)) then
return Full_View (E);
else
return E;
end if;
end RTE_Tag_Node;
end Exp_Atag;
gcc/ada/exp_atag.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ A T A G --
-- --
-- S p e c --
-- --
-- Copyright (C) 2006, 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package contains routines involved in the frontend expansion of
-- subprograms of package Ada.Tags
with Types; use Types;
package Exp_Atag is
function Build_CW_Membership
(Loc : Source_Ptr;
Obj_Tag_Node : Node_Id;
Typ_Tag_Node : Node_Id) return Node_Id;
-- Build code that returns true if Obj_Tag is in Typ_Tag'Class. Each
-- dispatch table contains a reference to a table of ancestors (stored
-- in the first part of the Tags_Table) and a count of the level of
-- inheritance "Idepth". Obj is in Typ'Class if Typ'Tag is in the table
-- of ancestors that are contained in the dispatch table referenced by
-- Obj'Tag. Knowing the level of inheritance of both types, this can be
-- computed in constant time by the formula:
--
-- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
-- = Typ'tag
function Build_Get_Access_Level
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id;
-- Build code that retrieves the accessibility level of the tagged type.
--
-- Generates: TSD (Tag).Access_Level
function Build_Get_Predefined_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position_Node : Node_Id) return Node_Id;
-- Given a pointer to a dispatch table (T) and a position in the DT, build
-- code that gets the address of the predefined virtual function stored in
-- it (used for dispatching calls).
--
-- Generates: Predefined_DT (Tag).D (Position);
function Build_Get_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position_Node : Node_Id) return Node_Id;
-- Build code that retrieves the address of the virtual function stored in
-- a given position of the dispatch table (used for dispatching calls).
--
-- Generates: To_Tag (Tag).D (Position);
function Build_Get_RC_Offset
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id;
-- Build code that retrieves the Offset of the implicit record controller
-- when the object has controlled components. O otherwise.
--
-- Generates: TSD (T).RC_Offset;
function Build_Get_Remotely_Callable
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id;
-- Build code that retrieves the value previously saved by Set_Remotely
-- Callable
--
-- Generates: TSD (Tag).Remotely_Callable
function Build_Inherit_Predefined_Prims
(Loc : Source_Ptr;
Old_Tag_Node : Node_Id;
New_Tag_Node : Node_Id) return Node_Id;
-- Build code that inherits the predefined primitives of the parent.
--
-- Generates: Predefined_DT (New_T).D (All_Predefined_Prims) :=
-- Predefined_DT (Old_T).D (All_Predefined_Prims);
function Build_Inherit_Prims
(Loc : Source_Ptr;
Old_Tag_Node : Node_Id;
New_Tag_Node : Node_Id;
Num_Prims : Nat) return Node_Id;
-- Build code that inherits Num_Prims user-defined primitives from the
-- dispatch table of the parent type.
--
-- Generates:
-- New_Tag.Prims_Ptr (1 .. Num_Prims) :=
-- Old_Tag.Prims_Ptr (1 .. Num_Prims);
function Build_Inherit_TSD
(Loc : Source_Ptr;
Old_Tag_Node : Node_Id;
New_Tag_Node : Node_Id;
I_Depth : Nat;
Parent_Num_Ifaces : Nat) return Node_Id;
-- Generates code that initializes the TSD of a type knowing the tag,
-- inheritance depth, and number of interface types of the parent type.
--
-- Generates:
-- -- Copy the table of ancestors of the parent
--
-- TSD (New_Tag).Tags_Table (1 .. I_Depth) :=
-- TSD (Old_Tag).Tags_Table (0 .. I_Depth - 1);
--
-- -- Copy the table of interfaces of the parent
--
-- if TSD (Old_Tag).Ifaces_Table_Ptr /= null then
-- New_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces):=
-- Old_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces);
-- end if;
--
-- TSD (New_Tag).Tags_Table (0) := New_Tag;
function Build_New_TSD
(Loc : Source_Ptr;
New_Tag_Node : Node_Id) return List_Id;
-- Build code that initializes the TSD of a root type.
-- Generates: TSD (New_Tag).Tags_Table (0) := New_Tag;
function Build_Set_External_Tag
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Value_Node : Node_Id) return Node_Id;
-- Build code that saves the address of the string containing the external
-- tag in the dispatch table.
--
-- Generates: TSD (Tag).External_Tag := Cstring_Ptr! (Value);
function Build_Set_Predefined_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position_Node : Node_Id;
Address_Node : Node_Id) return Node_Id;
-- Build code that saves the address of a virtual function in a given
-- Position of the portion of the dispatch table associated with the
-- predefined primitives of Tag (used for overriding).
--
-- Generates: Predefined_DT (Tag).D (Position) := Value
function Build_Set_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position_Node : Node_Id;
Address_Node : Node_Id) return Node_Id;
-- Build code that saves the address of a virtual function in a given
-- Position of the dispatch table associated with the Tag (used for
-- overriding).
--
-- Generates: Tag.D (Position) := Value
function Build_Set_TSD
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Value_Node : Node_Id) return Node_Id;
-- Build code that saves the address of the record containing the Type
-- Specific Data generated by GNAT.
--
-- Generates: To_Addr_Ptr (To_Address (Tag) - K_Typeinfo).all := Value
end Exp_Atag;
gcc/ada/exp_ch13.adb
......@@ -27,6 +27,7 @@
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Exp_Atag; use Exp_Atag;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6; use Exp_Ch6;
with Exp_Imgv; use Exp_Imgv;
......@@ -211,16 +212,16 @@ package body Exp_Ch13 is
Make_String_Literal (Loc, Strval => New_Val)));
Append_Freeze_Actions (Ent, New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Set_External_Tag), Loc),
Parameter_Associations => New_List (
Build_Set_External_Tag (Loc,
Tag_Node =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Tag,
Prefix => New_Occurrence_Of (Ent, Loc)),
Value_Node =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address,
Prefix => New_Occurrence_Of (E, Loc)))),
Prefix => New_Occurrence_Of (E, Loc))),
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
......
gcc/ada/exp_disp.adb
......@@ -30,6 +30,7 @@ with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Atag; use Exp_Atag;
with Exp_Ch7; use Exp_Ch7;
with Exp_Dbug; use Exp_Dbug;
with Exp_Tss; use Exp_Tss;
......@@ -154,10 +155,10 @@ package body Exp_Disp is
------------------------------------------------
procedure Build_Common_Dispatching_Select_Statements
(Loc : Source_Ptr;
Typ : Entity_Id;
(Loc : Source_Ptr;
Typ : Entity_Id;
DT_Ptr : Entity_Id;
Stmts : List_Id)
Stmts : List_Id)
is
begin
-- Generate:
......@@ -305,115 +306,49 @@ package body Exp_Disp is
package SEU renames Select_Expansion_Utilities;
Ada_Actions : constant array (DT_Access_Action) of RE_Id :=
(CW_Membership => RE_CW_Membership,
IW_Membership => RE_IW_Membership,
DT_Entry_Size => RE_DT_Entry_Size,
DT_Prologue_Size => RE_DT_Prologue_Size,
Get_Access_Level => RE_Get_Access_Level,
(IW_Membership => RE_IW_Membership,
Get_Entry_Index => RE_Get_Entry_Index,
Get_External_Tag => RE_Get_External_Tag,
Get_Predefined_Prim_Op_Address => RE_Get_Predefined_Prim_Op_Address,
Get_Prim_Op_Address => RE_Get_Prim_Op_Address,
Get_Prim_Op_Kind => RE_Get_Prim_Op_Kind,
Get_RC_Offset => RE_Get_RC_Offset,
Get_Remotely_Callable => RE_Get_Remotely_Callable,
Get_Tagged_Kind => RE_Get_Tagged_Kind,
Inherit_DT => RE_Inherit_DT,
Inherit_TSD => RE_Inherit_TSD,
Register_Interface_Tag => RE_Register_Interface_Tag,
Register_Tag => RE_Register_Tag,
Set_Access_Level => RE_Set_Access_Level,
Set_Entry_Index => RE_Set_Entry_Index,
Set_Expanded_Name => RE_Set_Expanded_Name,
Set_External_Tag => RE_Set_External_Tag,
Set_Interface_Table => RE_Set_Interface_Table,
Set_Offset_Index => RE_Set_Offset_Index,
Set_OSD => RE_Set_OSD,
Set_Predefined_Prim_Op_Address => RE_Set_Predefined_Prim_Op_Address,
Set_Prim_Op_Address => RE_Set_Prim_Op_Address,
Set_Prim_Op_Kind => RE_Set_Prim_Op_Kind,
Set_RC_Offset => RE_Set_RC_Offset,
Set_Remotely_Callable => RE_Set_Remotely_Callable,
Set_Signature => RE_Set_Signature,
Set_SSD => RE_Set_SSD,
Set_TSD => RE_Set_TSD,
Set_Tagged_Kind => RE_Set_Tagged_Kind,
TSD_Entry_Size => RE_TSD_Entry_Size,
TSD_Prologue_Size => RE_TSD_Prologue_Size);
Set_Tagged_Kind => RE_Set_Tagged_Kind);
Action_Is_Proc : constant array (DT_Access_Action) of Boolean :=
(CW_Membership => False,
IW_Membership => False,
DT_Entry_Size => False,
DT_Prologue_Size => False,
Get_Access_Level => False,
(IW_Membership => False,
Get_Entry_Index => False,
Get_External_Tag => False,
Get_Predefined_Prim_Op_Address => False,
Get_Prim_Op_Address => False,
Get_Prim_Op_Kind => False,
Get_RC_Offset => False,
Get_Remotely_Callable => False,
Get_Tagged_Kind => False,
Inherit_DT => True,
Inherit_TSD => True,
Register_Interface_Tag => True,
Register_Tag => True,
Set_Access_Level => True,
Set_Entry_Index => True,
Set_Expanded_Name => True,
Set_External_Tag => True,
Set_Interface_Table => True,
Set_Offset_Index => True,
Set_OSD => True,
Set_Predefined_Prim_Op_Address => True,
Set_Prim_Op_Address => True,
Set_Prim_Op_Kind => True,
Set_RC_Offset => True,
Set_Remotely_Callable => True,
Set_Signature => True,
Set_SSD => True,
Set_TSD => True,
Set_Tagged_Kind => True,
TSD_Entry_Size => False,
TSD_Prologue_Size => False);
Set_Tagged_Kind => True);
Action_Nb_Arg : constant array (DT_Access_Action) of Int :=
(CW_Membership => 2,
IW_Membership => 2,
DT_Entry_Size => 0,
DT_Prologue_Size => 0,
Get_Access_Level => 1,
(IW_Membership => 2,
Get_Entry_Index => 2,
Get_External_Tag => 1,
Get_Predefined_Prim_Op_Address => 2,
Get_Prim_Op_Address => 2,
Get_Prim_Op_Kind => 2,
Get_RC_Offset => 1,
Get_Remotely_Callable => 1,
Get_Tagged_Kind => 1,
Inherit_DT => 3,
Inherit_TSD => 2,
Register_Interface_Tag => 3,
Register_Tag => 1,
Set_Access_Level => 2,
Set_Entry_Index => 3,
Set_Expanded_Name => 2,
Set_External_Tag => 2,
Set_Interface_Table => 2,
Set_Offset_Index => 3,
Set_OSD => 2,
Set_Predefined_Prim_Op_Address => 3,
Set_Prim_Op_Address => 3,
Set_Prim_Op_Kind => 3,
Set_RC_Offset => 2,
Set_Remotely_Callable => 2,
Set_Signature => 2,
Set_SSD => 2,
Set_TSD => 2,
Set_Tagged_Kind => 2,
TSD_Entry_Size => 0,
TSD_Prologue_Size => 0);
Set_Tagged_Kind => 2);
function Default_Prim_Op_Position (E : Entity_Id) return Uint;
-- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
......@@ -550,7 +485,18 @@ package body Exp_Disp is
-- Start of processing for Expand_Dispatching_Call
begin
Check_Restriction (No_Dispatching_Calls, Call_Node);
-- 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.
if not Expander_Active
or else Restriction_Active (No_Dispatching_Calls)
then
return;
end if;
-- Set subprogram. If this is an inherited operation that was
-- overridden, the body that is being called is its alias.
......@@ -564,14 +510,6 @@ package body Exp_Disp is
Subp := Alias (Subp);
end if;
-- Expand_Dispatching_Call is called directly from the semantics,
-- so we need a check to see whether expansion is active before
-- proceeding.
if not Expander_Active then
return;
end if;
-- Definition of the class-wide type and the tagged type
-- If the controlling argument is itself a tag rather than a tagged
......@@ -606,12 +544,10 @@ package body Exp_Disp is
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
end if;
-- Why do we check the Root_Type instead of Typ???
if Is_CPP_Class (Root_Type (Typ)) then
-- Create a new parameter list with the displaced 'this'
-- Dispatching call to C++ primitive. Create a new parameter list
-- with no tag checks.
if Is_CPP_Class (Typ) then
New_Params := New_List;
Param := First_Actual (Call_Node);
while Present (Param) loop
......@@ -619,6 +555,8 @@ package body Exp_Disp is
Next_Actual (Param);
end loop;
-- Dispatching call to Ada primitive
elsif Present (Param_List) then
-- Generate the Tag checks when appropriate
......@@ -805,6 +743,22 @@ package body Exp_Disp is
then
Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
-- Extract the tag from an unchecked type conversion. Done to avoid
-- the expansion of additional code just to obtain the value of such
-- tag because the current management of interface type conversions
-- generates in some cases this unchecked type conversion with the
-- tag of the object (see Expand_Interface_Conversion).
elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion
and then
(Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag)
or else
(RTE_Available (RE_Interface_Tag)
and then
Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag)))
then
Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg));
-- Ada 2005 (AI-251): Abstract interface class-wide type
elsif Is_Interface (Etype (Ctrl_Arg))
......@@ -819,42 +773,27 @@ package body Exp_Disp is
Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc));
end if;
-- Generate:
-- Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos));
-- Handle dispatching calls to predefined primitives
if Is_Predefined_Dispatching_Operation (Subp)
or else Is_Predefined_Dispatching_Alias (Subp)
then
New_Call_Name :=
Unchecked_Convert_To (Subp_Ptr_Typ,
Make_DT_Access_Action (Typ,
Action => Get_Predefined_Prim_Op_Address,
Args => New_List (
-- Vptr
Unchecked_Convert_To (RTE (RE_Tag),
Controlling_Tag),
Build_Get_Predefined_Prim_Op_Address (Loc,
Tag_Node => Controlling_Tag,
Position_Node => Make_Integer_Literal (Loc,
DT_Position (Subp))));
-- Position
Make_Integer_Literal (Loc, DT_Position (Subp)))));
-- Handle dispatching calls to user-defined primitives
else
New_Call_Name :=
Unchecked_Convert_To (Subp_Ptr_Typ,
Make_DT_Access_Action (Typ,
Action => Get_Prim_Op_Address,
Args => New_List (
-- Vptr
Unchecked_Convert_To (RTE (RE_Tag),
Controlling_Tag),
-- Position
Make_Integer_Literal (Loc, DT_Position (Subp)))));
Build_Get_Prim_Op_Address (Loc,
Tag_Node => Controlling_Tag,
Position_Node => Make_Integer_Literal (Loc,
DT_Position (Subp))));
end if;
if Nkind (Call_Node) = N_Function_Call then
......@@ -946,17 +885,14 @@ package body Exp_Disp is
Iface_Typ : Entity_Id := Etype (N);
Iface_Tag : Entity_Id;
New_Itype : Entity_Id;
P : Node_Id;
begin
pragma Assert (Nkind (Operand) /= N_Attribute_Reference);
-- Ada 2005 (AI-345): Handle task interfaces
-- Ada 2005 (AI-345): Handle synchronized interface type derivations
if Ekind (Operand_Typ) = E_Task_Type
or else Ekind (Operand_Typ) = E_Protected_Type
then
Operand_Typ := Corresponding_Record_Type (Operand_Typ);
if Is_Concurrent_Type (Operand_Typ) then
Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
end if;
-- Handle access types to interfaces
......@@ -1145,24 +1081,10 @@ package body Exp_Disp is
New_Occurrence_Of (Iface_Tag, Loc)),
Attribute_Name => Name_Address))))))));
-- Insert the new declaration in the nearest enclosing scope
-- that has declarations.
P := N;
while not Has_Declarations (Parent (P)) loop
P := Parent (P);
end loop;
if Is_List_Member (P) then
Insert_Before (P, Func);
elsif Nkind (Parent (P)) = N_Package_Specification then
Append_To (Visible_Declarations (Parent (P)), Func);
else
Append_To (Declarations (Parent (P)), Func);
end if;
-- Place function body before the expression containing
-- the conversion
Insert_Action (N, Func);
Analyze (Func);
if Is_Access_Type (Etype (Expression (N))) then
......@@ -1282,7 +1204,7 @@ package body Exp_Disp is
-- the interface primitives are located in the primary dispatch
-- table.
elsif Is_Ancestor (Formal_Typ, Actual_Typ) then
elsif Is_Parent (Formal_Typ, Actual_Typ) then
null;
else
......@@ -1334,7 +1256,7 @@ package body Exp_Disp is
-- derivation of the interface (because in this case the interface
-- primitives are located in the primary dispatch table)
elsif Is_Ancestor (Formal_DDT, Actual_DDT) then
elsif Is_Parent (Formal_DDT, Actual_DDT) then
null;
else
......@@ -1646,32 +1568,23 @@ package body Exp_Disp is
or else Is_Predefined_Dispatching_Alias (Prim)
then
return
Make_DT_Access_Action (Typ,
Action => Set_Predefined_Prim_Op_Address,
Args => New_List (
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (DT_Ptr, Loc)), -- DTptr
Make_Integer_Literal (Loc, Pos), -- Position
Build_Set_Predefined_Prim_Op_Address (Loc,
Tag_Node => New_Reference_To (DT_Ptr, Loc),
Position_Node => Make_Integer_Literal (Loc, Pos),
Address_Node => Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Address));
Make_Attribute_Reference (Loc, -- Value
Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Address)));
else
pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
return
Make_DT_Access_Action (Typ,
Action => Set_Prim_Op_Address,
Args => New_List (
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (DT_Ptr, Loc)), -- DTptr
Make_Integer_Literal (Loc, Pos), -- Position
Make_Attribute_Reference (Loc, -- Value
Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Address)));
Build_Set_Prim_Op_Address (Loc,
Tag_Node => New_Reference_To (DT_Ptr, Loc),
Position_Node => Make_Integer_Literal (Loc, Pos),
Address_Node => Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Address));
end if;
end Fill_DT_Entry;
......@@ -1685,7 +1598,6 @@ package body Exp_Disp is
Thunk_Id : Entity_Id;
Iface_DT_Ptr : Entity_Id) return Node_Id
is
Typ : constant Entity_Id := Scope (DTC_Entity (Alias (Prim)));
Iface_Prim : constant Entity_Id := Abstract_Interface_Alias (Prim);
Pos : constant Uint := DT_Position (Iface_Prim);
Tag : constant Entity_Id :=
......@@ -1696,99 +1608,28 @@ package body Exp_Disp is
or else Is_Predefined_Dispatching_Alias (Prim)
then
return
Make_DT_Access_Action (Typ,
Action => Set_Predefined_Prim_Op_Address,
Args => New_List (
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Iface_DT_Ptr, Loc)), -- DTptr
Make_Integer_Literal (Loc, Pos), -- Position
Make_Attribute_Reference (Loc, -- Value
Build_Set_Predefined_Prim_Op_Address (Loc,
Tag_Node =>
New_Reference_To (Iface_DT_Ptr, Loc),
Position_Node =>
Make_Integer_Literal (Loc, Pos),
Address_Node =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Thunk_Id, Loc),
Attribute_Name => Name_Address)));
Attribute_Name => Name_Address));
else
pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
return
Make_DT_Access_Action (Typ,
Action => Set_Prim_Op_Address,
Args => New_List (
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Iface_DT_Ptr, Loc)), -- DTptr
Make_Integer_Literal (Loc, Pos), -- Position
Make_Attribute_Reference (Loc, -- Value
Prefix => New_Reference_To (Thunk_Id, Loc),
Attribute_Name => Name_Address)));
Build_Set_Prim_Op_Address (Loc,
Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
Position_Node => Make_Integer_Literal (Loc, Pos),
Address_Node => Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Thunk_Id, Loc),
Attribute_Name => Name_Address));
end if;
end Fill_Secondary_DT_Entry;
---------------------------
-- Get_Remotely_Callable --
---------------------------
function Get_Remotely_Callable (Obj : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Obj);
begin
return Make_DT_Access_Action
(Typ => Etype (Obj),
Action => Get_Remotely_Callable,
Args => New_List (
Make_Selected_Component (Loc,
Prefix => Obj,
Selector_Name => Make_Identifier (Loc, Name_uTag))));
end Get_Remotely_Callable;
------------------------------------------
-- Init_Predefined_Interface_Primitives --
------------------------------------------
function Init_Predefined_Interface_Primitives
(Typ : Entity_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
DT_Ptr : constant Node_Id :=
Node (First_Elmt (Access_Disp_Table (Typ)));
Result : constant List_Id := New_List;
AI : Elmt_Id;
begin
-- No need to inherit primitives if we have an abstract interface
-- type or a concurrent type.
if Is_Interface (Typ)
or else Is_Concurrent_Record_Type (Typ)
or else Restriction_Active (No_Dispatching_Calls)
then
return Result;
end if;
AI := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
while Present (AI) loop
-- All the secondary tables inherit the dispatch table entries
-- associated with predefined primitives.
-- Generate:
-- Inherit_DT (T'Tag, Iface'Tag, 0);
Append_To (Result,
Make_DT_Access_Action (Typ,
Action => Inherit_DT,
Args => New_List (
Node1 => New_Reference_To (DT_Ptr, Loc),
Node2 => Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Node (AI), Loc)),
Node3 => Make_Integer_Literal (Loc, Uint_0))));
Next_Elmt (AI);
end loop;
return Result;
end Init_Predefined_Interface_Primitives;
-------------------------------------
-- Is_Predefined_Dispatching_Alias --
-------------------------------------
......@@ -2651,6 +2492,8 @@ package body Exp_Disp is
Name_TSD : constant Name_Id := New_External_Name (Tname, 'B');
Name_Exname : constant Name_Id := New_External_Name (Tname, 'E');
Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F');
-- The following external name is only generated if Typ has interfaces
Name_ITable : Name_Id;
DT : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT);
......@@ -2659,23 +2502,26 @@ package body Exp_Disp is
TSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD);
Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname);
No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg);
ITable : Node_Id;
Generalized_Tag : constant Entity_Id := RTE (RE_Tag);
AI : Elmt_Id;
I_Depth : Int;
Nb_Prim : Int;
Num_Ifaces : Int;
Old_Tag1 : Node_Id;
Old_Tag2 : Node_Id;
Parent_Num_Ifaces : Int;
Size_Expr_Node : Node_Id;
TSD_Num_Entries : Int;
Empty_DT : Boolean := False;
Ancestor_Ifaces : Elist_Id;
Typ_Ifaces : Elist_Id;
Generalized_Tag : constant Entity_Id := RTE (RE_Tag);
Ancestor_Ifaces : Elist_Id;
AI : Elmt_Id;
Has_Dispatch_Table : Boolean := True;
I_Depth : Nat := 0;
ITable : Node_Id;
Iface_Table_Node : Node_Id;
Nb_Prim : Nat := 0;
Null_Parent_Tag : Boolean := False;
Num_Ifaces : Nat := 0;
Old_Tag1 : Node_Id;
Old_Tag2 : Node_Id;
Parent : Entity_Id;
Parent_Num_Ifaces : Nat := 0;
Remotely_Callable : Entity_Id;
RC_Offset_Node : Node_Id;
Size_Expr_Node : Node_Id;
Typ_Ifaces : Elist_Id;
TSD_Aggr_List : List_Id;
begin
if not RTE_Available (RE_Tag) then
......@@ -2683,34 +2529,49 @@ package body Exp_Disp is
return New_List;
end if;
-- Calculate the size of the DT and the TSD. First we count the number
-- of interfaces implemented by the ancestors
-- Ensure that the unit System_Storage_Elements is loaded. This is
-- required to properly expand the routines of Ada.Tags
if not RTU_Loaded (System_Storage_Elements)
and then not Present (RTE (RE_Storage_Offset))
then
raise Program_Error;
end if;
if Ada_Version >= Ada_05 then
-- Count the interface types of the parents
Parent := Empty;
if Typ /= Etype (Typ) then
Parent := Etype (Typ);
elsif Is_Concurrent_Record_Type (Typ) then
Parent := Etype (First (Abstract_Interface_List (Typ)));
end if;
if Present (Parent) then
Collect_Abstract_Interfaces (Parent, Ancestor_Ifaces);
Parent_Num_Ifaces := 0;
Num_Ifaces := 0;
AI := First_Elmt (Ancestor_Ifaces);
while Present (AI) loop
Parent_Num_Ifaces := Parent_Num_Ifaces + 1;
Next_Elmt (AI);
end loop;
end if;
-- Count the abstract interfaces of the ancestors
-- Count the additional interfaces implemented by Typ
if Typ /= Etype (Typ) then
Collect_Abstract_Interfaces (Etype (Typ), Ancestor_Ifaces);
Collect_Abstract_Interfaces (Typ, Typ_Ifaces);
AI := First_Elmt (Ancestor_Ifaces);
AI := First_Elmt (Typ_Ifaces);
while Present (AI) loop
Parent_Num_Ifaces := Parent_Num_Ifaces + 1;
Num_Ifaces := Num_Ifaces + 1;
Next_Elmt (AI);
end loop;
end if;
-- Count the number of additional interfaces implemented by Typ
Collect_Abstract_Interfaces (Typ, Typ_Ifaces);
AI := First_Elmt (Typ_Ifaces);
while Present (AI) loop
Num_Ifaces := Num_Ifaces + 1;
Next_Elmt (AI);
end loop;
-- Count ancestors to compute the inheritance depth. For private
-- extensions, always go to the full view in order to compute the
-- real inheritance depth.
......@@ -2735,31 +2596,19 @@ package body Exp_Disp is
end loop;
end;
-- Abstract interfaces don't need the DT. We reserve a single entry
-- for its DT because at run-time the pointer to this dummy DT will
-- be used as the tag of this abstract interface type. The table of
-- interfaces is required to give support to AI-405
if Is_Interface (Typ) then
Empty_DT := True;
Nb_Prim := 1;
TSD_Num_Entries := 0;
-- Calculate the number of primitives of the dispatch table and the
-- size of the Type_Specific_Data record.
else
TSD_Num_Entries := I_Depth + 1;
Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
-- Abstract interfaces don't need the dispatch table. In addition,
-- compiling with restriction No_Dispatching_Calls we do not generate
-- the dispatch table.
-- If the number of primitives of Typ is 0 (or we are compiling
-- with the No_Dispatching_Calls restriction) we reserve a dummy
-- single entry for its DT because at run-time the pointer to this
-- dummy DT will be used as the tag of this tagged type.
Has_Dispatch_Table :=
not Is_Interface (Typ)
and then not Restriction_Active (No_Dispatching_Calls);
if Nb_Prim = 0
or else Restriction_Active (No_Dispatching_Calls)
then
Empty_DT := True;
Nb_Prim := 1;
end if;
if Has_Dispatch_Table then
Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
end if;
-- Dispatch table and related entities are allocated statically
......@@ -2792,18 +2641,49 @@ package body Exp_Disp is
-- Generate code to create the storage for the Dispatch_Table object:
-- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
-- DT : Storage_Array (1 .. Size_Expr);
-- for DT'Alignment use Address'Alignment
Size_Expr_Node :=
Make_Op_Add (Loc,
Left_Opnd => Make_DT_Access_Action (Typ, DT_Prologue_Size, No_List),
Right_Opnd =>
Make_Op_Multiply (Loc,
Left_Opnd =>
Make_DT_Access_Action (Typ, DT_Entry_Size, No_List),
Right_Opnd =>
Make_Integer_Literal (Loc, Nb_Prim)));
-- Under No_Dispatching_Calls the size of the table is small just
-- containing:
-- 1) the pointer to the TSD
-- 2) a dummy entry used as the Tag of the type (see a-tags.ads).
if not Has_Dispatch_Table then
Size_Expr_Node :=
New_Reference_To (RTE (RE_DT_Min_Prologue_Size), Loc);
-- If the object has no primitives we ensure that the table will
-- have at least a dummy entry which will be used as the Tag.
-- Size_Expr := DT_Prologue_Size + DT_Entry_Size
elsif Nb_Prim = 0 then
Size_Expr_Node :=
Make_Op_Add (Loc,
Left_Opnd =>
New_Reference_To (RTE (RE_DT_Prologue_Size), Loc),
Right_Opnd =>
New_Reference_To (RTE (RE_DT_Entry_Size), Loc));
-- Common case. The dispatch table has space to save the pointers to
-- all the predefined primitives, the C++ ABI header of the DT, and
-- the pointers to the primitives of Typ. That is,
-- Size_Expr := DT_Prologue_Size + nb_prim * DT_Entry_Size
else
Size_Expr_Node :=
Make_Op_Add (Loc,
Left_Opnd =>
New_Reference_To (RTE (RE_DT_Prologue_Size), Loc),
Right_Opnd =>
Make_Op_Multiply (Loc,
Left_Opnd =>
New_Reference_To (RTE (RE_DT_Entry_Size), Loc),
Right_Opnd =>
Make_Integer_Literal (Loc, Nb_Prim)));
end if;
Append_To (Result,
Make_Object_Declaration (Loc,
......@@ -2836,34 +2716,42 @@ package body Exp_Disp is
-- prologue containing Offset_To_Top, and Typeinfo_Ptr. Hence, we move
-- down the pointer to the real base of the vtable
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => DT_Ptr,
Constant_Present => True,
Object_Definition => New_Reference_To (Generalized_Tag, Loc),
Expression =>
Unchecked_Convert_To (Generalized_Tag,
Make_Op_Add (Loc,
Left_Opnd =>
Unchecked_Convert_To (RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (DT, Loc),
Attribute_Name => Name_Address)),
Right_Opnd =>
Make_DT_Access_Action (Typ,
DT_Prologue_Size, No_List)))));
-- Generate code to define the boolean that controls registration, in
-- order to avoid multiple registrations for tagged types defined in
-- multiple-called scopes.
if not Has_Dispatch_Table then
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => DT_Ptr,
Constant_Present => True,
Object_Definition => New_Reference_To (Generalized_Tag, Loc),
Expression =>
Unchecked_Convert_To (Generalized_Tag,
Make_Op_Add (Loc,
Left_Opnd =>
Unchecked_Convert_To (RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (DT, Loc),
Attribute_Name => Name_Address)),
Right_Opnd =>
New_Reference_To (RTE (RE_DT_Typeinfo_Ptr_Size), Loc)))));
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => No_Reg,
Object_Definition => New_Reference_To (Standard_Boolean, Loc),
Expression => New_Reference_To (Standard_True, Loc)));
else
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => DT_Ptr,
Constant_Present => True,
Object_Definition => New_Reference_To (Generalized_Tag, Loc),
Expression =>
Unchecked_Convert_To (Generalized_Tag,
Make_Op_Add (Loc,
Left_Opnd =>
Unchecked_Convert_To (RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (DT, Loc),
Attribute_Name => Name_Address)),
Right_Opnd =>
New_Reference_To (RTE (RE_DT_Prologue_Size), Loc)))));
end if;
-- Set Access_Disp_Table field to be the dispatch table pointer
-- Save the tag in the Access_Disp_Table attribute
if No (Access_Disp_Table (Typ)) then
Set_Access_Disp_Table (Typ, New_Elmt_List);
......@@ -2871,57 +2759,28 @@ package body Exp_Disp is
Prepend_Elmt (DT_Ptr, Access_Disp_Table (Typ));
-- Generate code to create the storage for the type specific data object
-- with enough space to store the tags of the ancestors plus the tags
-- of all the implemented interfaces (as described in a-tags.adb).
-- TSD: Storage_Array
-- (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size);
-- for TSD'Alignment use Address'Alignment
Size_Expr_Node :=
Make_Op_Add (Loc,
Left_Opnd =>
Make_DT_Access_Action (Typ, TSD_Prologue_Size, No_List),
Right_Opnd =>
Make_Op_Multiply (Loc,
Left_Opnd =>
Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List),
Right_Opnd =>
Make_Integer_Literal (Loc, TSD_Num_Entries)));
-- Generate code to define the boolean that controls registration, in
-- order to avoid multiple registrations for tagged types defined in
-- multiple-called scopes.
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => TSD,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 1),
High_Bound => Size_Expr_Node))))));
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (TSD, Loc),
Chars => Name_Alignment,
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
Defining_Identifier => No_Reg,
Object_Definition => New_Reference_To (Standard_Boolean, Loc),
Expression => New_Reference_To (Standard_True, Loc)));
-- Generate:
-- Set_Signature (DT_Ptr, Value);
if RTE_Available (RE_Set_Signature) then
if Has_Dispatch_Table
and then RTE_Available (RE_Set_Signature)
then
if Is_Interface (Typ) then
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Set_Signature,
Args => New_List (
New_Reference_To (DT_Ptr, Loc), -- DTptr
New_Reference_To (DT_Ptr, Loc),
New_Reference_To (RTE (RE_Abstract_Interface), Loc))));
else
......@@ -2929,88 +2788,240 @@ package body Exp_Disp is
Make_DT_Access_Action (Typ,
Action => Set_Signature,
Args => New_List (
New_Reference_To (DT_Ptr, Loc), -- DTptr
New_Reference_To (DT_Ptr, Loc),
New_Reference_To (RTE (RE_Primary_DT), Loc))));
end if;
end if;
-- Generate code to put the Address of the TSD in the dispatch table
-- Set_TSD (DT_Ptr, TSD);
-- 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 (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Set_TSD,
Args => New_List (
New_Reference_To (DT_Ptr, Loc), -- DTptr
Make_Attribute_Reference (Loc, -- Value
Prefix => New_Reference_To (TSD, Loc),
Attribute_Name => Name_Address))));
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Exname,
Constant_Present => True,
Object_Definition => New_Reference_To (Standard_String, Loc),
Expression =>
Make_String_Literal (Loc,
Full_Qualified_Name (First_Subtype (Typ)))));
-- Set the pointer to the Interfaces_Table (if any). Otherwise the
-- corresponding access component is set to null.
-- Calculate the value of the RC_Offset component. These are the
-- valid valiues 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.
if Num_Ifaces = 0 then
if RTE_Available (RE_Set_Interface_Table) then
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Set_Interface_Table,
Args => New_List (
New_Reference_To (DT_Ptr, Loc), -- DTptr
New_Reference_To (RTE (RE_Null_Address), Loc)))); -- null
if Is_Interface (Typ)
or else not Has_Controlled_Component (Typ)
then
RC_Offset_Node := Make_Integer_Literal (Loc, 0);
elsif Etype (Typ) /= Typ
and then Has_Discriminants (Etype (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;
-- Generate the Interface_Table object and set the access
-- component if the TSD to it.
-- Set the pointer to the Interfaces_Table (if any). Otherwise the
-- corresponding access component is set to null. The table of
-- interfaces is required for AI-405
elsif RTE_Available (RE_Set_Interface_Table) then
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => ITable,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To
(RTE (RE_Interface_Data), Loc),
Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Integer_Literal (Loc,
Num_Ifaces))))));
if RTE_Record_Component_Available (RE_Ifaces_Table_Ptr) then
if Num_Ifaces = 0 then
Iface_Table_Node :=
New_Reference_To (RTE (RE_Null_Address), Loc);
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Set_Interface_Table,
Args => New_List (
New_Reference_To (DT_Ptr, Loc), -- DTptr
Make_Attribute_Reference (Loc, -- Value
Prefix => New_Reference_To (ITable, Loc),
Attribute_Name => Name_Address))));
-- Generate the Interface_Table object.
else
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => ITable,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To
(RTE (RE_Interface_Data), Loc),
Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Integer_Literal (Loc,
Num_Ifaces))))));
Iface_Table_Node :=
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (ITable, Loc),
Attribute_Name => Name_Address);
end if;
end if;
-- Generate:
-- Set_Num_Prim_Ops (T'Tag, Nb_Prim)
-- Generate: Set_Remotely_Callable (DT_Ptr, Status); where Status is
-- described in E.4 (18)
if RTE_Available (RE_Set_Num_Prim_Ops) then
if not Is_Interface (Typ) then
if Empty_DT then
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc),
Parameter_Associations => New_List (
New_Reference_To (DT_Ptr, Loc),
Make_Integer_Literal (Loc, Uint_0))));
else
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc),
Parameter_Associations => New_List (
New_Reference_To (DT_Ptr, Loc),
Make_Integer_Literal (Loc, Nb_Prim))));
end if;
end if;
Remotely_Callable :=
Boolean_Literals
(Is_Pure (Typ)
or else Is_Shared_Passive (Typ)
or else
((Is_Remote_Types (Typ)
or else Is_Remote_Call_Interface (Typ))
and then Original_View_In_Visible_Part (Typ))
or else not Comes_From_Source (Typ));
-- Generate code to create the storage for the type specific data object
-- with enough space to store the tags of the ancestors plus the tags
-- of all the implemented interfaces (as described in a-tags.adb).
-- TSD : Type_Specific_Data (I_Depth) :=
-- (Idepth => I_Depth,
-- Access_Level => Type_Access_Level (Typ),
-- Expanded_Name => Cstring_Ptr!(Exname'Address))
-- [ External_Tag => Cstring_Ptr!(Exname'Address)) ]
-- RC_Offset => <<integer-value>>,
-- Remotely_Callable => <<boolean-value>>
-- [ Ifaces_Table_Ptr => <<access-value>> ]
-- others => <>);
-- for TSD'Alignment use Address'Alignment
TSD_Aggr_List := New_List (
Make_Component_Association (Loc,
Choices => New_List (
New_Occurrence_Of (RTE_Record_Component (RE_Idepth), Loc)),
Expression => Make_Integer_Literal (Loc, I_Depth)),
Make_Component_Association (Loc,
Choices => New_List (
New_Occurrence_Of (RTE_Record_Component (RE_Access_Level), Loc)),
Expression => Make_Integer_Literal (Loc, Type_Access_Level (Typ))),
Make_Component_Association (Loc,
Choices => New_List (
New_Occurrence_Of
(RTE_Record_Component (RE_Expanded_Name), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Exname, Loc),
Attribute_Name => Name_Address))));
if not Has_External_Tag_Rep_Clause (Typ) then
-- Should be the external name not the qualified name???
Append_To (TSD_Aggr_List,
Make_Component_Association (Loc,
Choices => New_List (
New_Occurrence_Of
(RTE_Record_Component (RE_External_Tag), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Exname, Loc),
Attribute_Name => Name_Address))));
end if;
Append_List_To (TSD_Aggr_List, New_List (
Make_Component_Association (Loc,
Choices => New_List (
New_Occurrence_Of (RTE_Record_Component (RE_RC_Offset), Loc)),
Expression => RC_Offset_Node),
Make_Component_Association (Loc,
Choices => New_List (
New_Occurrence_Of
(RTE_Record_Component (RE_Remotely_Callable), Loc)),
Expression => New_Occurrence_Of (Remotely_Callable, Loc))));
if RTE_Record_Component_Available (RE_Ifaces_Table_Ptr) then
Append_To (TSD_Aggr_List,
Make_Component_Association (Loc,
Choices => New_List (
New_Occurrence_Of
(RTE_Record_Component (RE_Ifaces_Table_Ptr), Loc)),
Expression => Iface_Table_Node));
end if;
Append_To (TSD_Aggr_List,
Make_Component_Association (Loc,
Choices => New_List (Make_Others_Choice (Loc)),
Expression => Empty,
Box_Present => True));
-- Save the expanded name in the dispatch table
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => TSD,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To (
RTE (RE_Type_Specific_Data), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Integer_Literal (Loc, I_Depth)))),
Expression => Make_Aggregate (Loc,
Component_Associations => TSD_Aggr_List)));
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (TSD, Loc),
Chars => Name_Alignment,
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
Attribute_Name => Name_Alignment)));
-- Generate code to put the Address of the TSD in the dispatch table
Append_To (Elab_Code,
Build_Set_TSD (Loc,
Tag_Node => New_Reference_To (DT_Ptr, Loc),
Value_Node =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (TSD, Loc),
Attribute_Name => Name_Address)));
-- Generate extra code required for synchronized interfaces
if RTE_Available (RE_Set_Tagged_Kind) then
if Ada_Version >= Ada_05
and then not Is_Interface (Typ)
and then not Is_Abstract (Typ)
and then not Is_Abstract_Type (Typ)
and then not Is_Controlled (Typ)
and then not Restriction_Active (No_Dispatching_Calls)
then
......@@ -3029,13 +3040,12 @@ package body Exp_Disp is
-- of the table is constrained by the number of non-predefined
-- primitive operations.
if not Empty_DT
if Has_Dispatch_Table
and then Is_Concurrent_Record_Type (Typ)
and then Implements_Interface (
Typ => Typ,
Kind => Any_Limited_Interface,
Check_Parent => True)
and then Has_Abstract_Interfaces (Typ)
then
-- No need to generate this code if Nb_Prim = 0 ???
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => SSD,
......@@ -3063,46 +3073,10 @@ package body Exp_Disp is
end if;
end if;
-- 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_Reference_To (Standard_String, Loc),
Expression =>
Make_String_Literal (Loc,
Full_Qualified_Name (First_Subtype (Typ)))));
-- Generate: Set_Expanded_Name (DT_Ptr, exname'Address);
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Set_Expanded_Name,
Args => New_List (
Node1 => New_Reference_To (DT_Ptr, Loc),
Node2 =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Exname, Loc),
Attribute_Name => Name_Address))));
if not Is_Interface (Typ) then
-- Generate: Set_Access_Level (DT_Ptr, <type's accessibility level>);
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Set_Access_Level,
Args => New_List (
Node1 => New_Reference_To (DT_Ptr, Loc),
Node2 => Make_Integer_Literal (Loc, Type_Access_Level (Typ)))));
end if;
-- If the ancestor is a CPP_Class type we inherit the dispatch tables
-- in the init proc, and we don't need to fill them in here.
if Is_CPP_Class (Etype (Typ)) and then not Debug_Flag_QQ then
if Is_CPP_Class (Etype (Typ)) then
null;
-- Otherwise we fill in the dispatch tables here
......@@ -3112,6 +3086,8 @@ package body Exp_Disp is
or else Is_CPP_Class (Etype (Typ))
or else Is_Interface (Typ)
then
Null_Parent_Tag := True;
Old_Tag1 :=
Unchecked_Convert_To (Generalized_Tag,
Make_Integer_Literal (Loc, 0));
......@@ -3132,27 +3108,34 @@ package body Exp_Disp is
and then not Is_Interface (Typ)
and then not Restriction_Active (No_Dispatching_Calls)
then
-- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
-- Inherit the dispatch table
if not Is_Interface (Etype (Typ)) then
if Restriction_Active (No_Dispatching_Calls) then
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Inherit_DT,
Args => New_List (
Node1 => Old_Tag1,
Node2 => New_Reference_To (DT_Ptr, Loc),
Node3 => Make_Integer_Literal (Loc, Uint_0))));
null;
else
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Inherit_DT,
Args => New_List (
Node1 => Old_Tag1,
Node2 => New_Reference_To (DT_Ptr, Loc),
Node3 => Make_Integer_Literal (Loc,
DT_Entry_Count
(First_Tag_Component (Etype (Typ)))))));
if not Null_Parent_Tag then
declare
Nb_Prims : constant Int :=
UI_To_Int (DT_Entry_Count
(First_Tag_Component (Etype (Typ))));
begin
Append_To (Elab_Code,
Build_Inherit_Predefined_Prims (Loc,
Old_Tag_Node => Old_Tag1,
New_Tag_Node =>
New_Reference_To (DT_Ptr, Loc)));
if Nb_Prims /= 0 then
Append_To (Elab_Code,
Build_Inherit_Prims (Loc,
Old_Tag_Node => Old_Tag2,
New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
Num_Prims => Nb_Prims));
end if;
end;
end if;
end if;
end if;
......@@ -3207,21 +3190,41 @@ package body Exp_Disp is
loop
if Is_Tag (E) and then Chars (E) /= Name_uTag then
if not Is_Interface (Etype (Typ)) then
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Inherit_DT,
Args => New_List (
Node1 => Unchecked_Convert_To
(RTE (RE_Tag),
New_Reference_To
(Node (Sec_DT_Ancestor),
Loc)),
Node2 => Unchecked_Convert_To
(RTE (RE_Tag),
New_Reference_To
(Node (Sec_DT_Typ), Loc)),
Node3 => Make_Integer_Literal (Loc,
DT_Entry_Count (E)))));
-- Inherit the dispatch table
declare
Num_Prims : constant Int :=
UI_To_Int (DT_Entry_Count (E));
begin
Append_To (Elab_Code,
Build_Inherit_Predefined_Prims (Loc,
Old_Tag_Node =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Node (Sec_DT_Ancestor), Loc)),
New_Tag_Node =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Node (Sec_DT_Typ), Loc))));
if Num_Prims /= 0 then
Append_To (Elab_Code,
Build_Inherit_Prims (Loc,
Old_Tag_Node =>
Unchecked_Convert_To
(RTE (RE_Tag),
New_Reference_To
(Node (Sec_DT_Ancestor),
Loc)),
New_Tag_Node =>
Unchecked_Convert_To
(RTE (RE_Tag),
New_Reference_To
(Node (Sec_DT_Typ), Loc)),
Num_Prims => Num_Prims));
end if;
end;
end if;
Next_Elmt (Sec_DT_Ancestor);
......@@ -3253,157 +3256,68 @@ package body Exp_Disp is
-- Inherit_TSD (parent'tag, DT_Ptr);
if not Is_Interface (Typ) then
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Inherit_TSD,
Args => New_List (
Node1 => Old_Tag2,
Node2 => New_Reference_To (DT_Ptr, Loc))));
end if;
end if;
if not Is_Interface (Typ) then
-- For types with no controlled components, generate:
-- Set_RC_Offset (DT_Ptr, 0);
-- For simple types with controlled components, generate:
-- Set_RC_Offset (DT_Ptr, type._record_controller'position);
-- For complex types with controlled components where the position
-- of the record controller is not statically computable, if there
-- are controlled components at this level, generate:
-- Set_RC_Offset (DT_Ptr, -1);
-- to indicate that the _controller field is right after the _parent
-- Or if there are no controlled components at this level, generate:
-- Set_RC_Offset (DT_Ptr, -2);
-- to indicate that we need to get the position from the parent.
declare
Position : Node_Id;
begin
if not Has_Controlled_Component (Typ) then
Position := Make_Integer_Literal (Loc, 0);
elsif Etype (Typ) /= Typ
and then Has_Discriminants (Etype (Typ))
if Typ = Etype (Typ)
or else Is_CPP_Class (Etype (Typ))
then
if Has_New_Controlled_Component (Typ) then
Position := Make_Integer_Literal (Loc, -1);
else
Position := Make_Integer_Literal (Loc, -2);
end if;
else
Position :=
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 (Position);
Set_Etype (Prefix (Position), RTE (RE_Record_Controller));
Set_Etype (Prefix (Prefix (Position)), Typ);
Set_Etype (Selector_Name (Prefix (Position)),
RTE (RE_Record_Controller));
Set_Etype (Position, RTE (RE_Storage_Offset));
end if;
-- New_TSD (DT_Ptr);
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Set_RC_Offset,
Args => New_List (
Node1 => New_Reference_To (DT_Ptr, Loc),
Node2 => Position)));
end;
-- Generate: Set_Remotely_Callable (DT_Ptr, Status); where Status is
-- described in E.4 (18)
declare
Status : Entity_Id;
begin
Status :=
Boolean_Literals
(Is_Pure (Typ)
or else Is_Shared_Passive (Typ)
or else
((Is_Remote_Types (Typ)
or else Is_Remote_Call_Interface (Typ))
and then Original_View_In_Visible_Part (Typ))
or else not Comes_From_Source (Typ));
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Set_Remotely_Callable,
Args => New_List (
New_Occurrence_Of (DT_Ptr, Loc),
New_Occurrence_Of (Status, Loc))));
end;
if RTE_Available (RE_Set_Offset_To_Top) then
-- Generate:
-- Set_Offset_To_Top (0, DT_Ptr, True, 0, null);
Append_List_To (Elab_Code,
Build_New_TSD (Loc,
New_Tag_Node => New_Reference_To (DT_Ptr, Loc)));
else
-- Inherit_TSD (parent'tag, DT_Ptr);
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
Parameter_Associations => New_List (
New_Reference_To (RTE (RE_Null_Address), Loc),
New_Reference_To (DT_Ptr, Loc),
New_Occurrence_Of (Standard_True, Loc),
Make_Integer_Literal (Loc, Uint_0),
New_Reference_To (RTE (RE_Null_Address), Loc))));
Append_To (Elab_Code,
Build_Inherit_TSD (Loc,
Old_Tag_Node =>
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Etype (Typ)))),
Loc),
New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
I_Depth => I_Depth,
Parent_Num_Ifaces => Parent_Num_Ifaces));
end if;
end if;
end if;
-- Generate: Set_External_Tag (DT_Ptr, exname'Address);
-- Should be the external name not the qualified name???
if not Is_Interface (Typ)
and then RTE_Available (RE_Set_Offset_To_Top)
then
-- Generate:
-- Set_Offset_To_Top (0, DT_Ptr, True, 0, null);
if not Has_External_Tag_Rep_Clause (Typ) then
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
Action => Set_External_Tag,
Args => New_List (
Node1 => New_Reference_To (DT_Ptr, Loc),
Node2 =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Exname, Loc),
Attribute_Name => Name_Address))));
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
Parameter_Associations => New_List (
New_Reference_To (RTE (RE_Null_Address), Loc),
New_Reference_To (DT_Ptr, Loc),
New_Occurrence_Of (Standard_True, Loc),
Make_Integer_Literal (Loc, Uint_0),
New_Reference_To (RTE (RE_Null_Address), Loc))));
end if;
-- Generate code to register the Tag in the External_Tag hash
-- table for the pure Ada type only.
-- Generate code to register the Tag in the External_Tag hash table for
-- the pure Ada type only.
-- Register_Tag (Dt_Ptr);
-- Register_Tag (Dt_Ptr);
-- Skip this if routine not available, or in No_Run_Time mode
-- or Typ is an abstract interface type (because the table to
-- register it is not available in the abstract type but in
-- types implementing this interface)
-- Skip this if routine not available, or in No_Run_Time mode or Typ is
-- an abstract interface type (because the table to register it is not
-- available in the abstract type but in types implementing this
-- interface)
if not No_Run_Time_Mode
and then RTE_Available (RE_Register_Tag)
and then Is_RTE (Generalized_Tag, RE_Tag)
and then not Is_Interface (Typ)
then
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
Parameter_Associations =>
New_List (New_Reference_To (DT_Ptr, Loc))));
end if;
if not Has_External_Tag_Rep_Clause (Typ)
and then not No_Run_Time_Mode
and then RTE_Available (RE_Register_Tag)
and then Is_RTE (RTE (RE_Tag), RE_Tag)
and then not Is_Interface (Typ)
then
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
Parameter_Associations =>
New_List (New_Reference_To (DT_Ptr, Loc))));
end if;
-- Generate:
......@@ -3422,20 +3336,20 @@ package body Exp_Disp is
Condition => New_Reference_To (No_Reg, Loc),
Then_Statements => Elab_Code));
-- Ada 2005 (AI-251): Register the tag of the interfaces into
-- the table of implemented interfaces.
-- Ada 2005 (AI-251): Register the tag of the interfaces into the table
-- of interfaces.
if Num_Ifaces > 0 then
declare
Position : Int;
Position : Nat;
begin
-- If the parent is an interface we must generate code to register
-- all its interfaces; otherwise this code is not needed because
-- Inherit_TSD has already inherited such interfaces.
if Etype (Typ) /= Typ
and then Is_Interface (Etype (Typ))
if Is_Concurrent_Record_Type (Typ)
or else (Etype (Typ) /= Typ and then Is_Interface (Etype (Typ)))
then
Position := 1;
......@@ -3553,7 +3467,7 @@ package body Exp_Disp is
procedure Make_Secondary_DT
(Typ : Entity_Id;
Ancestor_Typ : Entity_Id;
Suffix_Index : Int;
Suffix_Index : Nat;
Iface : Entity_Id;
AI_Tag : Entity_Id;
Acc_Disp_Tables : in out Elist_Id;
......@@ -3566,7 +3480,7 @@ package body Exp_Disp is
Iface_DT : Node_Id;
Iface_DT_Ptr : Node_Id;
Name_DT_Ptr : Name_Id;
Nb_Prim : Int;
Nb_Prim : Nat;
OSD : Entity_Id;
Size_Expr_Node : Node_Id;
Tname : Name_Id;
......@@ -3613,15 +3527,12 @@ package body Exp_Disp is
Size_Expr_Node :=
Make_Op_Add (Loc,
Left_Opnd => Make_DT_Access_Action (Etype (AI_Tag),
DT_Prologue_Size,
No_List),
Left_Opnd =>
New_Reference_To (RTE (RE_DT_Prologue_Size), Loc),
Right_Opnd =>
Make_Op_Multiply (Loc,
Left_Opnd =>
Make_DT_Access_Action (Etype (AI_Tag),
DT_Entry_Size,
No_List),
New_Reference_To (RTE (RE_DT_Entry_Size), Loc),
Right_Opnd =>
Make_Integer_Literal (Loc, Nb_Prim)));
......@@ -3669,8 +3580,7 @@ package body Exp_Disp is
Prefix => New_Reference_To (Iface_DT, Loc),
Attribute_Name => Name_Address)),
Right_Opnd =>
Make_DT_Access_Action (Etype (AI_Tag),
DT_Prologue_Size, No_List)))));
New_Reference_To (RTE (RE_DT_Prologue_Size), Loc)))));
-- Note: Offset_To_Top will be initialized by the init subprogram
......@@ -3732,32 +3642,9 @@ package body Exp_Disp is
Prefix => New_Reference_To (OSD, Loc),
Attribute_Name => Name_Address))));
-- Generate:
-- Set_Num_Prim_Ops (T'Tag, Nb_Prim)
if RTE_Available (RE_Set_Num_Prim_Ops) then
if Empty_DT then
Append_To (Result,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Iface_DT_Ptr, Loc)),
Make_Integer_Literal (Loc, Uint_0))));
else
Append_To (Result,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Iface_DT_Ptr, Loc)),
Make_Integer_Literal (Loc, Nb_Prim))));
end if;
end if;
if Ada_Version >= Ada_05
and then not Is_Interface (Typ)
and then not Is_Abstract (Typ)
and then not Is_Interface (Typ)
and then not Is_Abstract_Type (Typ)
and then not Is_Controlled (Typ)
and then RTE_Available (RE_Set_Tagged_Kind)
and then not Restriction_Active (No_Dispatching_Calls)
......@@ -3775,10 +3662,7 @@ package body Exp_Disp is
if not Empty_DT
and then Is_Concurrent_Record_Type (Typ)
and then Implements_Interface (
Typ => Typ,
Kind => Any_Limited_Interface,
Check_Parent => True)
and then Has_Abstract_Interfaces (Typ)
then
declare
Prim : Entity_Id;
......@@ -3839,7 +3723,7 @@ package body Exp_Disp is
Prim_Als : Entity_Id;
Prim_Elmt : Elmt_Id;
Prim_Pos : Uint;
Nb_Prim : Int := 0;
Nb_Prim : Nat := 0;
type Examined_Array is array (Int range <>) of Boolean;
......@@ -4192,482 +4076,345 @@ package body Exp_Disp is
-- Local variables
Parent_Typ : constant Entity_Id := Etype (Typ);
Root_Typ : constant Entity_Id := Root_Type (Typ);
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;
Count_Prim : Int;
DT_Length : Int;
Nb_Prim : Int;
Parent_EC : Int;
Count_Prim : Nat;
DT_Length : Nat;
Nb_Prim : Nat;
Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
-- Start of processing for Set_All_DT_Position
begin
-- Get Entry_Count of the parent
if Parent_Typ /= Typ
and then DT_Entry_Count (First_Tag_Component (Parent_Typ)) /= No_Uint
then
Parent_EC := UI_To_Int (DT_Entry_Count
(First_Tag_Component (Parent_Typ)));
else
Parent_EC := 0;
end if;
-- C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable
-- give a coherent set of information
if Is_CPP_Class (Root_Typ) and then Debug_Flag_QQ then
-- Compute the number of primitive operations in the main Vtable
-- Set their position:
-- - where it was set if overriden or inherited
-- - after the end of the parent vtable otherwise
Prim_Elmt := First_Prim;
Nb_Prim := 0;
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
if not Is_CPP_Class (Typ) then
Set_DTC_Entity (Prim, The_Tag);
elsif Present (Alias (Prim)) then
Set_DTC_Entity (Prim, DTC_Entity (Alias (Prim)));
Set_DT_Position (Prim, DT_Position (Alias (Prim)));
-- Set the DT_Position for each primitive operation. Perform some
-- sanity checks to avoid to build completely inconsistant dispatch
-- tables.
elsif No (DTC_Entity (Prim)) and then Is_CPP_Class (Typ) then
Error_Msg_NE ("is a primitive operation of&," &
" pragma Cpp_Virtual required", Prim, Typ);
end if;
if DTC_Entity (Prim) = The_Tag then
-- First stage: Set the DTC entity of all the primitive operations
-- This is required to properly read the DT_Position attribute in
-- the latter stages.
-- Get the slot from the parent subprogram if any
Prim_Elmt := First_Prim;
Count_Prim := 0;
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
declare
H : Entity_Id;
-- Predefined primitives have a separate dispatch table
begin
H := Homonym (Prim);
while Present (H) loop
if Present (DTC_Entity (H))
and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ
then
Set_DT_Position (Prim, DT_Position (H));
exit;
end if;
H := Homonym (H);
end loop;
end;
if not (Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim))
then
Count_Prim := Count_Prim + 1;
end if;
-- Otherwise take the canonical slot after the end of the
-- parent Vtable
-- Ada 2005 (AI-251)
if DT_Position (Prim) = No_Uint then
Nb_Prim := Nb_Prim + 1;
Set_DT_Position (Prim, UI_From_Int (Parent_EC + Nb_Prim));
elsif UI_To_Int (DT_Position (Prim)) > Parent_EC then
Nb_Prim := Nb_Prim + 1;
end if;
end if;
if Present (Abstract_Interface_Alias (Prim))
and then Is_Interface
(Find_Dispatching_Type
(Abstract_Interface_Alias (Prim)))
then
Set_DTC_Entity (Prim,
Find_Interface_Tag
(T => Typ,
Iface => Find_Dispatching_Type
(Abstract_Interface_Alias (Prim))));
else
Set_DTC_Entity (Prim, The_Tag);
end if;
Next_Elmt (Prim_Elmt);
end loop;
-- Clear any previous value of the DT_Position attribute. In this
-- way we ensure that the final position of all the primitives is
-- stablished by the following stages of this algorithm.
-- Check that the declared size of the Vtable is bigger or equal
-- than the number of primitive operations (if bigger it means that
-- some of the c++ virtual functions were not imported, that is
-- allowed).
Set_DT_Position (Prim, No_Uint);
if DT_Entry_Count (The_Tag) = No_Uint
or else not Is_CPP_Class (Typ)
then
Set_DT_Entry_Count (The_Tag, UI_From_Int (Parent_EC + Nb_Prim));
Next_Elmt (Prim_Elmt);
end loop;
elsif UI_To_Int (DT_Entry_Count (The_Tag)) < Parent_EC + Nb_Prim then
Error_Msg_N ("not enough room in the Vtable for all virtual"
& " functions", The_Tag);
end if;
declare
Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean
:= (others => False);
E : Entity_Id;
-- Check that Positions are not duplicate nor outside the range of
-- the Vtable.
procedure Set_Fixed_Prim (Pos : Nat);
-- Sets to true an element of the Fixed_Prim table to indicate
-- that this entry of the dispatch table of Typ is occupied.
declare
Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag));
Pos : Int;
Prim_Pos_Table : array (1 .. Size) of Entity_Id :=
(others => Empty);
--------------------
-- Set_Fixed_Prim --
--------------------
procedure Set_Fixed_Prim (Pos : Nat) is
begin
Prim_Elmt := First_Prim;
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
pragma Assert (Pos >= 0 and then Pos <= Count_Prim);
Fixed_Prim (Pos) := True;
exception
when Constraint_Error =>
raise Program_Error;
end Set_Fixed_Prim;
if DTC_Entity (Prim) = The_Tag then
Pos := UI_To_Int (DT_Position (Prim));
begin
-- Second stage: Register fixed entries
if Pos not in Prim_Pos_Table'Range then
Error_Msg_N
("position not in range of virtual table", Prim);
Nb_Prim := 0;
Prim_Elmt := First_Prim;
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
elsif Present (Prim_Pos_Table (Pos)) then
Error_Msg_NE ("cannot be at the same position in the"
& " vtable than&", Prim, Prim_Pos_Table (Pos));
-- Predefined primitives have a separate table and all its
-- entries are at predefined fixed positions.
else
Prim_Pos_Table (Pos) := Prim;
end if;
end if;
if Is_Predefined_Dispatching_Operation (Prim) then
Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
Next_Elmt (Prim_Elmt);
end loop;
end;
-- Generate listing showing the contents of the dispatch tables
elsif Is_Predefined_Dispatching_Alias (Prim) then
E := Alias (Prim);
while Present (Alias (E)) loop
E := Alias (E);
end loop;
if Debug_Flag_ZZ then
Write_DT (Typ);
end if;
Set_DT_Position (Prim, Default_Prim_Op_Position (E));
-- For regular Ada tagged types, just set the DT_Position for
-- each primitive operation. Perform some sanity checks to avoid
-- to build completely inconsistant dispatch tables.
-- Overriding primitives of ancestor abstract interfaces
-- Note that the _Size primitive is always set at position 1 in order
-- to comply with the needs of Ada.Tags.Parent_Size (see documentation
-- in Ada.Tags).
elsif Present (Abstract_Interface_Alias (Prim))
and then Is_Parent
(Find_Dispatching_Type
(Abstract_Interface_Alias (Prim)),
Typ)
then
pragma Assert (DT_Position (Prim) = No_Uint
and then Present (DTC_Entity
(Abstract_Interface_Alias (Prim))));
else
-- First stage: Set the DTC entity of all the primitive operations
-- This is required to properly read the DT_Position attribute in
-- the latter stages.
E := Abstract_Interface_Alias (Prim);
Set_DT_Position (Prim, DT_Position (E));
Prim_Elmt := First_Prim;
Count_Prim := 0;
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
pragma Assert
(DT_Position (Alias (Prim)) = No_Uint
or else DT_Position (Alias (Prim)) = DT_Position (E));
Set_DT_Position (Alias (Prim), DT_Position (E));
Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
-- Predefined primitives have a separate dispatch table
-- Overriding primitives must use the same entry as the
-- overriden primitive
if not (Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim))
elsif not Present (Abstract_Interface_Alias (Prim))
and then Present (Alias (Prim))
and then Find_Dispatching_Type (Alias (Prim)) /= Typ
and then Is_Parent
(Find_Dispatching_Type (Alias (Prim)), Typ)
and then Present (DTC_Entity (Alias (Prim)))
then
Count_Prim := Count_Prim + 1;
end if;
-- Ada 2005 (AI-251)
E := Alias (Prim);
Set_DT_Position (Prim, DT_Position (E));
if Present (Abstract_Interface_Alias (Prim))
and then Is_Interface
(Find_Dispatching_Type
(Abstract_Interface_Alias (Prim)))
then
Set_DTC_Entity (Prim,
Find_Interface_Tag
(T => Typ,
Iface => Find_Dispatching_Type
(Abstract_Interface_Alias (Prim))));
else
Set_DTC_Entity (Prim, The_Tag);
if not Is_Predefined_Dispatching_Alias (E) then
Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
end if;
end if;
-- Clear any previous value of the DT_Position attribute. In this
-- way we ensure that the final position of all the primitives is
-- stablished by the following stages of this algorithm.
Set_DT_Position (Prim, No_Uint);
Next_Elmt (Prim_Elmt);
end loop;
declare
Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean
:= (others => False);
E : Entity_Id;
-- Third stage: Fix the position of all the new primitives
-- Entries associated with primitives covering interfaces
-- are handled in a latter round.
procedure Set_Fixed_Prim (Pos : Int);
-- Sets to true an element of the Fixed_Prim table to indicate
-- that this entry of the dispatch table of Typ is occupied.
--------------------
-- Set_Fixed_Prim --
--------------------
procedure Set_Fixed_Prim (Pos : Int) is
begin
pragma Assert (Pos >= 0 and then Pos <= Count_Prim);
Fixed_Prim (Pos) := True;
exception
when Constraint_Error =>
raise Program_Error;
end Set_Fixed_Prim;
begin
-- Second stage: Register fixed entries
Nb_Prim := 0;
Prim_Elmt := First_Prim;
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
-- 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));
elsif Is_Predefined_Dispatching_Alias (Prim) then
E := Alias (Prim);
while Present (Alias (E)) loop
E := Alias (E);
end loop;
Set_DT_Position (Prim, Default_Prim_Op_Position (E));
-- Overriding primitives of ancestor abstract interfaces
elsif Present (Abstract_Interface_Alias (Prim))
and then Is_Ancestor
(Find_Dispatching_Type
(Abstract_Interface_Alias (Prim)),
Typ)
then
pragma Assert (DT_Position (Prim) = No_Uint
and then Present (DTC_Entity
(Abstract_Interface_Alias (Prim))));
E := Abstract_Interface_Alias (Prim);
Set_DT_Position (Prim, DT_Position (E));
pragma Assert
(DT_Position (Alias (Prim)) = No_Uint
or else DT_Position (Alias (Prim)) = DT_Position (E));
Set_DT_Position (Alias (Prim), DT_Position (E));
Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
-- Overriding primitives must use the same entry as the
-- overriden primitive
elsif not Present (Abstract_Interface_Alias (Prim))
and then Present (Alias (Prim))
and then Find_Dispatching_Type (Alias (Prim)) /= Typ
and then Is_Ancestor
(Find_Dispatching_Type (Alias (Prim)), Typ)
and then Present (DTC_Entity (Alias (Prim)))
then
E := Alias (Prim);
Set_DT_Position (Prim, DT_Position (E));
Prim_Elmt := First_Prim;
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
if not Is_Predefined_Dispatching_Alias (E) then
Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
end if;
end if;
-- Skip primitives previously set entries
Next_Elmt (Prim_Elmt);
end loop;
-- Third stage: Fix the position of all the new primitives
-- Entries associated with primitives covering interfaces
-- are handled in a latter round.
if DT_Position (Prim) /= No_Uint then
null;
Prim_Elmt := First_Prim;
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
-- Primitives covering interface primitives are handled later
-- Skip primitives previously set entries
elsif Present (Abstract_Interface_Alias (Prim)) then
null;
if DT_Position (Prim) /= No_Uint then
null;
else
-- Take the next available position in the DT
-- Primitives covering interface primitives are handled later
loop
Nb_Prim := Nb_Prim + 1;
pragma Assert (Nb_Prim <= Count_Prim);
exit when not Fixed_Prim (Nb_Prim);
end loop;
elsif Present (Abstract_Interface_Alias (Prim)) then
null;
Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
Set_Fixed_Prim (Nb_Prim);
end if;
else
-- Take the next available position in the DT
Next_Elmt (Prim_Elmt);
end loop;
end;
loop
Nb_Prim := Nb_Prim + 1;
pragma Assert (Nb_Prim <= Count_Prim);
exit when not Fixed_Prim (Nb_Prim);
end loop;
-- Fourth stage: Complete the decoration of primitives covering
-- interfaces (that is, propagate the DT_Position attribute
-- from the aliased primitive)
Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
Set_Fixed_Prim (Nb_Prim);
end if;
Prim_Elmt := First_Prim;
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
Next_Elmt (Prim_Elmt);
end loop;
end;
if DT_Position (Prim) = No_Uint
and then Present (Abstract_Interface_Alias (Prim))
then
pragma Assert (Present (Alias (Prim))
and then Find_Dispatching_Type (Alias (Prim)) = Typ);
-- Fourth stage: Complete the decoration of primitives covering
-- interfaces (that is, propagate the DT_Position attribute
-- from the aliased primitive)
-- Check if this entry will be placed in the primary DT
Prim_Elmt := First_Prim;
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
if DT_Position (Prim) = No_Uint
and then Present (Abstract_Interface_Alias (Prim))
if Is_Parent (Find_Dispatching_Type
(Abstract_Interface_Alias (Prim)),
Typ)
then
pragma Assert (Present (Alias (Prim))
and then Find_Dispatching_Type (Alias (Prim)) = Typ);
-- Check if this entry will be placed in the primary DT
if Is_Ancestor (Find_Dispatching_Type
(Abstract_Interface_Alias (Prim)),
Typ)
then
pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
Set_DT_Position (Prim, DT_Position (Alias (Prim)));
pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
Set_DT_Position (Prim, DT_Position (Alias (Prim)));
-- Otherwise it will be placed in the secondary DT
-- Otherwise it will be placed in the secondary DT
else
pragma Assert
(DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint);
Set_DT_Position (Prim,
DT_Position (Abstract_Interface_Alias (Prim)));
end if;
else
pragma Assert
(DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint);
Set_DT_Position (Prim,
DT_Position (Abstract_Interface_Alias (Prim)));
end if;
end if;
Next_Elmt (Prim_Elmt);
end loop;
-- Generate listing showing the contents of the dispatch tables.
-- This action is done before some further static checks because
-- in case of critical errors caused by a wrong dispatch table
-- we need to see the contents of such table.
Next_Elmt (Prim_Elmt);
end loop;
if Debug_Flag_ZZ then
Write_DT (Typ);
end if;
-- Generate listing showing the contents of the dispatch tables.
-- This action is done before some further static checks because
-- in case of critical errors caused by a wrong dispatch table
-- we need to see the contents of such table.
-- Final stage: Ensure that the table is correct plus some further
-- verifications concerning the primitives.
if Debug_Flag_ZZ then
Write_DT (Typ);
end if;
Prim_Elmt := First_Prim;
DT_Length := 0;
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
-- Final stage: Ensure that the table is correct plus some further
-- verifications concerning the primitives.
-- At this point all the primitives MUST have a position
-- in the dispatch table
Prim_Elmt := First_Prim;
DT_Length := 0;
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
if DT_Position (Prim) = No_Uint then
raise Program_Error;
end if;
-- At this point all the primitives MUST have a position
-- in the dispatch table
-- Calculate real size of the dispatch table
if DT_Position (Prim) = No_Uint then
raise Program_Error;
end if;
if not (Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim))
and then UI_To_Int (DT_Position (Prim)) > DT_Length
then
DT_Length := UI_To_Int (DT_Position (Prim));
end if;
-- Calculate real size of the dispatch table
-- Ensure that the asignated 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))
and then UI_To_Int (DT_Position (Prim)) > DT_Length
then
DT_Length := UI_To_Int (DT_Position (Prim));
end if;
if not (Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim))
then
Validate_Position (Prim);
end if;
-- Ensure that the asignated position to non-predefined
-- dispatching operations in the dispatch table is correct.
if Chars (Prim) = Name_Finalize then
Finalized := True;
end if;
if not (Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim))
then
Validate_Position (Prim);
end if;
if Chars (Prim) = Name_Adjust then
Adjusted := True;
end if;
if Chars (Prim) = Name_Finalize then
Finalized := True;
end if;
-- An abstract operation cannot be declared in the private part
-- for a visible abstract type, because it could never be over-
-- ridden. For explicit declarations this is checked at the
-- point of declaration, but for inherited operations it must
-- be done when building the dispatch table.
if Chars (Prim) = Name_Adjust then
Adjusted := True;
end if;
-- Ada 2005 (AI-251): Hidden entities associated with abstract
-- interface primitives are not taken into account because the
-- check is done with the aliased primitive.
-- An abstract operation cannot be declared in the private part
-- for a visible abstract type, because it could never be over-
-- ridden. For explicit declarations this is checked at the
-- point of declaration, but for inherited operations it must
-- be done when building the dispatch table.
-- Ada 2005 (AI-251): Hidden entities associated with abstract
-- interface primitives are not taken into account because the
-- check is done with the aliased primitive.
if Is_Abstract_Type (Typ)
and then Is_Abstract_Subprogram (Prim)
and then Present (Alias (Prim))
and then not Present (Abstract_Interface_Alias (Prim))
and then Is_Derived_Type (Typ)
and then In_Private_Part (Current_Scope)
and then
List_Containing (Parent (Prim)) =
Private_Declarations
(Specification (Unit_Declaration_Node (Current_Scope)))
and then Original_View_In_Visible_Part (Typ)
then
-- We exclude Input and Output stream operations because
-- Limited_Controlled inherits useless Input and Output
-- stream operations from Root_Controlled, which can
-- never be overridden.
if Is_Abstract (Typ)
and then Is_Abstract (Prim)
and then Present (Alias (Prim))
and then not Present (Abstract_Interface_Alias (Prim))
and then Is_Derived_Type (Typ)
and then In_Private_Part (Current_Scope)
and then
List_Containing (Parent (Prim)) =
Private_Declarations
(Specification (Unit_Declaration_Node (Current_Scope)))
and then Original_View_In_Visible_Part (Typ)
if not Is_TSS (Prim, TSS_Stream_Input)
and then
not Is_TSS (Prim, TSS_Stream_Output)
then
-- We exclude Input and Output stream operations because
-- Limited_Controlled inherits useless Input and Output
-- stream operations from Root_Controlled, which can
-- never be overridden.
if not Is_TSS (Prim, TSS_Stream_Input)
and then
not Is_TSS (Prim, TSS_Stream_Output)
then
Error_Msg_NE
("abstract inherited private operation&" &
" must be overridden ('R'M 3.9.3(10))",
Parent (Typ), Prim);
end if;
Error_Msg_NE
("abstract inherited private operation&" &
" must be overridden ('R'M 3.9.3(10))",
Parent (Typ), Prim);
end if;
end if;
Next_Elmt (Prim_Elmt);
end loop;
Next_Elmt (Prim_Elmt);
end loop;
-- Additional check
-- Additional check
if Is_Controlled (Typ) then
if not Finalized then
Error_Msg_N
("controlled type has no explicit Finalize method?", Typ);
if Is_Controlled (Typ) then
if not Finalized then
Error_Msg_N
("controlled type has no explicit Finalize method?", Typ);
elsif not Adjusted then
Error_Msg_N
("controlled type has no explicit Adjust method?", Typ);
end if;
elsif not Adjusted then
Error_Msg_N
("controlled type has no explicit Adjust method?", Typ);
end if;
end if;
-- Set the final size of the Dispatch Table
-- Set the final size of the Dispatch Table
Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
-- The derived type must have at least as many components as its
-- parent (for root types, the Etype points back to itself
-- and the test should not fail)
-- The derived type must have at least as many components as its
-- parent (for root types, the Etype points back to itself
-- and the test should not fail)
-- This test fails compiling the partial view of a tagged type
-- derived from an interface which defines the overriding subprogram
-- in the private part. This needs further investigation???
-- This test fails compiling the partial view of a tagged type
-- derived from an interface which defines the overriding subprogram
-- in the private part. This needs further investigation???
if not Has_Private_Declaration (Typ) then
pragma Assert (
DT_Entry_Count (The_Tag) >=
DT_Entry_Count (First_Tag_Component (Parent_Typ)));
null;
end if;
if not Has_Private_Declaration (Typ) then
pragma Assert (
DT_Entry_Count (The_Tag) >=
DT_Entry_Count (First_Tag_Component (Parent_Typ)));
null;
end if;
end Set_All_DT_Position;
......@@ -4719,7 +4466,7 @@ package body Exp_Disp is
-- won't be able to declare objects of that type.
else
Set_Is_Abstract (Typ);
Set_Is_Abstract_Type (Typ);
end if;
end Set_Default_Constructor;
......@@ -4737,7 +4484,7 @@ package body Exp_Disp is
-- Abstract kinds
if Is_Abstract (T) then
if Is_Abstract_Type (T) then
if Is_Limited_Record (T) then
return New_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc);
else
......@@ -4862,7 +4609,7 @@ package body Exp_Disp is
Write_Int (UI_To_Int (DT_Position (Prim)));
end if;
if Is_Abstract (Prim) then
if Is_Abstract_Subprogram (Prim) then
Write_Str (" is abstract;");
-- Check if this is a null primitive
......
gcc/ada/exp_disp.ads
......@@ -168,46 +168,24 @@ package Exp_Disp is
-- Exp_Disp.Set_All_DT_Position - direct use
type DT_Access_Action is
(CW_Membership,
IW_Membership,
DT_Entry_Size,
DT_Prologue_Size,
Get_Access_Level,
(IW_Membership,
Get_Entry_Index,
Get_External_Tag,
Get_Predefined_Prim_Op_Address,
Get_Prim_Op_Address,
Get_Prim_Op_Kind,
Get_RC_Offset,
Get_Remotely_Callable,
Get_Tagged_Kind,
Inherit_DT,
Inherit_TSD,
Register_Interface_Tag,
Register_Tag,
Set_Access_Level,
Set_Entry_Index,
Set_Expanded_Name,
Set_External_Tag,
Set_Interface_Table,
Set_Offset_Index,
Set_OSD,
Set_Predefined_Prim_Op_Address,
Set_Prim_Op_Address,
Set_Prim_Op_Kind,
Set_RC_Offset,
Set_Remotely_Callable,
Set_Signature,
Set_SSD,
Set_TSD,
Set_Tagged_Kind,
TSD_Entry_Size,
TSD_Prologue_Size);
Set_Tagged_Kind);
procedure Expand_Dispatching_Call (Call_Node : Node_Id);
-- Expand the call to the operation through the dispatch table and perform
-- the required tag checks when appropriate. For CPP types the call is
-- done through the Vtable (tag checks are not relevant)
-- the required tag checks when appropriate. For CPP types tag checks are
-- not relevant.
procedure Expand_Interface_Actuals (Call_Node : Node_Id);
-- Ada 2005 (AI-251): Displace all the actuals corresponding to class-wide
......@@ -245,15 +223,6 @@ package Exp_Disp is
-- the secondary dispatch table of Prim's controlling type with Thunk_Id's
-- address.
function Get_Remotely_Callable (Obj : Node_Id) return Node_Id;
-- Return an expression that holds True if the object can be transmitted
-- onto another partition according to E.4 (18)
function Init_Predefined_Interface_Primitives
(Typ : Entity_Id) return List_Id;
-- Ada 2005 (AI-251): Initialize the entries associated with predefined
-- primitives in all the secondary dispatch tables of Typ.
function Make_DT_Access_Action
(Typ : Entity_Id;
Action : DT_Access_Action;
......@@ -333,7 +302,7 @@ package Exp_Disp is
procedure Make_Secondary_DT
(Typ : Entity_Id;
Ancestor_Typ : Entity_Id;
Suffix_Index : Int;
Suffix_Index : Nat;
Iface : Entity_Id;
AI_Tag : Entity_Id;
Acc_Disp_Tables : in out Elist_Id;
......
gcc/ada/exp_util.adb
......@@ -1303,145 +1303,6 @@ package body Exp_Util is
end if;
end Expand_Subtype_From_Expr;
--------------------------------
-- Find_Implemented_Interface --
--------------------------------
-- Given the following code (XXX denotes irrelevant value):
-- type Limd_Iface is limited interface;
-- type Prot_Iface is protected interface;
-- type Sync_Iface is synchronized interface;
-- type Parent_Subtype is new Limd_Iface and Sync_Iface with ...
-- type Child_Subtype is new Parent_Subtype and Prot_Iface with ...
-- The following calls will return the following values:
-- Find_Implemented_Interface
-- (Child_Subtype, Synchronized_Interface, False) -> Empty
-- Find_Implemented_Interface
-- (Child_Subtype, Synchronized_Interface, True) -> Sync_Iface
-- Find_Implemented_Interface
-- (Child_Subtype, Any_Synchronized_Interface, XXX) -> Prot_Iface
-- Find_Implemented_Interface
-- (Child_Subtype, Any_Limited_Interface, XXX) -> Prot_Iface
function Find_Implemented_Interface
(Typ : Entity_Id;
Kind : Interface_Kind;
Check_Parent : Boolean := False) return Entity_Id
is
Iface_Elmt : Elmt_Id;
function Interface_In_Kind
(I : Entity_Id;
Kind : Interface_Kind) return Boolean;
-- Determine whether an interface falls into a specified kind
-----------------------
-- Interface_In_Kind --
-----------------------
function Interface_In_Kind
(I : Entity_Id;
Kind : Interface_Kind) return Boolean is
begin
if Is_Limited_Interface (I)
and then (Kind = Any_Interface
or else Kind = Any_Limited_Interface
or else Kind = Limited_Interface)
then
return True;
elsif Is_Protected_Interface (I)
and then (Kind = Any_Interface
or else Kind = Any_Limited_Interface
or else Kind = Any_Synchronized_Interface
or else Kind = Protected_Interface)
then
return True;
elsif Is_Synchronized_Interface (I)
and then (Kind = Any_Interface
or else Kind = Any_Limited_Interface
or else Kind = Synchronized_Interface)
then
return True;
elsif Is_Task_Interface (I)
and then (Kind = Any_Interface
or else Kind = Any_Limited_Interface
or else Kind = Any_Synchronized_Interface
or else Kind = Task_Interface)
then
return True;
-- Regular interface. This should be the last kind to check since
-- all of the previous cases have their Is_Interface flags set.
elsif Is_Interface (I)
and then (Kind = Any_Interface
or else Kind = Iface)
then
return True;
else
return False;
end if;
end Interface_In_Kind;
-- Start of processing for Find_Implemented_Interface
begin
if not Is_Tagged_Type (Typ) then
return Empty;
end if;
-- Implementations of the form:
-- Typ is new Interface ...
if Is_Interface (Etype (Typ))
and then Interface_In_Kind (Etype (Typ), Kind)
then
return Etype (Typ);
end if;
-- Implementations of the form:
-- Typ is new Typ_Parent and Interface ...
if Present (Abstract_Interfaces (Typ)) then
Iface_Elmt := First_Elmt (Abstract_Interfaces (Typ));
while Present (Iface_Elmt) loop
if Interface_In_Kind (Node (Iface_Elmt), Kind) then
return Node (Iface_Elmt);
end if;
Iface_Elmt := Next_Elmt (Iface_Elmt);
end loop;
end if;
-- Typ is a derived type and may implement a limited interface
-- through its parent subtype. Check the parent subtype as well
-- as any interfaces explicitly implemented at this level.
if Check_Parent
and then Ekind (Typ) = E_Record_Type
and then Present (Parent_Subtype (Typ))
then
return Find_Implemented_Interface (
Parent_Subtype (Typ), Kind, Check_Parent);
end if;
-- Typ does not implement a limited interface either at this level or
-- in any of its parent subtypes.
return Empty;
end Find_Implemented_Interface;
------------------------
-- Find_Interface_ADT --
------------------------
......@@ -1466,9 +1327,22 @@ package body Exp_Util is
AI : Node_Id;
begin
-- Climb to the ancestor (if any) handling private types
pragma Assert (Typ /= Iface);
-- Climb to the ancestor (if any) handling synchronized interface
-- derivations and private types
if Is_Concurrent_Record_Type (Typ) then
declare
Iface_List : constant List_Id := Abstract_Interface_List (Typ);
begin
if Is_Non_Empty_List (Iface_List) then
Find_Secondary_Table (Etype (First (Iface_List)));
end if;
end;
if Present (Full_View (Etype (Typ))) then
elsif Present (Full_View (Etype (Typ))) then
if Full_View (Etype (Typ)) /= Typ then
Find_Secondary_Table (Full_View (Etype (Typ)));
end if;
......@@ -1477,13 +1351,10 @@ package body Exp_Util is
Find_Secondary_Table (Etype (Typ));
end if;
-- If we already found it there is nothing else to do
if Found then
return;
end if;
-- Traverse the list of interfaces implemented by the type
if Present (Abstract_Interfaces (Typ))
if not Found
and then Present (Abstract_Interfaces (Typ))
and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
then
AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
......@@ -1501,9 +1372,11 @@ package body Exp_Util is
end if;
end Find_Secondary_Table;
-- Start of processing for Find_Interface_Tag
-- Start of processing for Find_Interface_ADT
begin
pragma Assert (Is_Interface (Iface));
-- Handle private types
if Has_Private_Declaration (Typ)
......@@ -1520,12 +1393,14 @@ package body Exp_Util is
-- Handle task and protected types implementing interfaces
if Ekind (Typ) = E_Protected_Type
or else Ekind (Typ) = E_Task_Type
then
if Is_Concurrent_Type (Typ) then
Typ := Corresponding_Record_Type (Typ);
end if;
pragma Assert
(not Is_Class_Wide_Type (Typ)
and then Ekind (Typ) /= E_Incomplete_Type);
ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
pragma Assert (Present (Node (ADT)));
Find_Secondary_Table (Typ);
......@@ -1538,13 +1413,21 @@ package body Exp_Util is
------------------------
function Find_Interface_Tag
(T : Entity_Id;
Iface : Entity_Id) return Entity_Id
(T : Entity_Id;
Iface : Entity_Id) return Entity_Id
is
AI_Tag : Entity_Id;
Found : Boolean := False;
Found : Boolean := False;
Typ : Entity_Id := T;
Is_Primary_Tag : Boolean := False;
Is_Sync_Typ : Boolean := False;
-- In case of non concurrent-record-types each parent-type has the
-- tags associated with the interface types that are not implemented
-- by the ancestors; concurrent-record-types have their whole list of
-- interface tags (and this case requires some special management).
procedure Find_Tag (Typ : Entity_Id);
-- Internal subprogram used to recursively climb to the ancestors
......@@ -1561,15 +1444,32 @@ package body Exp_Util is
-- therefore shares the main tag.
if Typ = Iface then
pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
AI_Tag := First_Tag_Component (Typ);
if Is_Sync_Typ then
Is_Primary_Tag := True;
else
pragma Assert
(Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
AI_Tag := First_Tag_Component (Typ);
end if;
Found := True;
return;
end if;
-- Handle synchronized interface derivations
if Is_Concurrent_Record_Type (Typ) then
declare
Iface_List : constant List_Id := Abstract_Interface_List (Typ);
begin
if Is_Non_Empty_List (Iface_List) then
Find_Tag (Etype (First (Iface_List)));
end if;
end;
-- Climb to the root type handling private types
if Present (Full_View (Etype (Typ))) then
elsif Present (Full_View (Etype (Typ))) then
if Full_View (Etype (Typ)) /= Typ then
Find_Tag (Full_View (Etype (Typ)));
end if;
......@@ -1586,9 +1486,12 @@ package body Exp_Util is
then
-- Skip the tag associated with the primary table
pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
pragma Assert (Present (AI_Tag));
if not Is_Sync_Typ then
pragma Assert
(Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
pragma Assert (Present (AI_Tag));
end if;
AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
while Present (AI_Elmt) loop
......@@ -1641,9 +1544,25 @@ package body Exp_Util is
Typ := Non_Limited_View (Typ);
end if;
Find_Tag (Typ);
pragma Assert (Found);
return AI_Tag;
if not Is_Concurrent_Record_Type (Typ) then
Find_Tag (Typ);
pragma Assert (Found);
return AI_Tag;
-- Concurrent record types
else
Is_Sync_Typ := True;
AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
Find_Tag (Typ);
pragma Assert (Found);
if Is_Primary_Tag then
return First_Tag_Component (Typ);
else
return AI_Tag;
end if;
end if;
end Find_Interface_Tag;
--------------------
......@@ -1659,6 +1578,12 @@ package body Exp_Util is
Iface : Entity_Id;
Typ : Entity_Id := T;
Is_Sync_Typ : Boolean := False;
-- In case of non concurrent-record-types each parent-type has the
-- tags associated with the interface types that are not implemented
-- by the ancestors; concurrent-record-types have their whole list of
-- interface tags (and this case requires some special management).
procedure Find_Iface (Typ : Entity_Id);
-- Internal subprogram used to recursively climb to the ancestors
......@@ -1672,7 +1597,21 @@ package body Exp_Util is
begin
-- Climb to the root type
if Etype (Typ) /= Typ then
-- Handle sychronized interface derivations
if Is_Concurrent_Record_Type (Typ) then
declare
Iface_List : constant List_Id := Abstract_Interface_List (Typ);
begin
if Is_Non_Empty_List (Iface_List) then
Find_Iface (Etype (First (Iface_List)));
end if;
end;
-- Handle the common case
elsif Etype (Typ) /= Typ then
pragma Assert (not Present (Full_View (Etype (Typ))));
Find_Iface (Etype (Typ));
end if;
......@@ -1684,9 +1623,12 @@ package body Exp_Util is
then
-- Skip the tag associated with the primary table
pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
pragma Assert (Present (AI_Tag));
if not Is_Sync_Typ then
pragma Assert
(Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
pragma Assert (Present (AI_Tag));
end if;
AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
while Present (AI_Elmt) loop
......@@ -1736,6 +1678,11 @@ package body Exp_Util is
Typ := Non_Limited_View (Typ);
end if;
if Is_Concurrent_Record_Type (Typ) then
Is_Sync_Typ := True;
AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
end if;
Find_Iface (Typ);
pragma Assert (Found);
return Iface;
......@@ -1780,6 +1727,10 @@ package body Exp_Util is
return Node (Prim);
end Find_Prim_Op;
------------------
-- Find_Prim_Op --
------------------
function Find_Prim_Op
(T : Entity_Id;
Name : TSS_Name_Type) return Entity_Id
......@@ -2177,18 +2128,6 @@ package body Exp_Util is
return Count;
end Homonym_Number;
--------------------------
-- Implements_Interface --
--------------------------
function Implements_Interface
(Typ : Entity_Id;
Kind : Interface_Kind;
Check_Parent : Boolean := False) return Boolean is
begin
return Find_Implemented_Interface (Typ, Kind, Check_Parent) /= Empty;
end Implements_Interface;
------------------------------
-- In_Unconditional_Context --
------------------------------
......@@ -2747,10 +2686,16 @@ package body Exp_Util is
N_Package_Specification |
N_Parameter_Association |
N_Parameter_Specification |
N_Pop_Constraint_Error_Label |
N_Pop_Program_Error_Label |
N_Pop_Storage_Error_Label |
N_Pragma_Argument_Association |
N_Procedure_Specification |
N_Protected_Body |
N_Protected_Definition |
N_Push_Constraint_Error_Label |
N_Push_Program_Error_Label |
N_Push_Storage_Error_Label |
N_Qualified_Expression |
N_Range |
N_Range_Constraint |
......@@ -4485,7 +4430,7 @@ package body Exp_Util is
elsif Nkind (Exp) = N_Unchecked_Type_Conversion
and then not Safe_Unchecked_Type_Conversion (Exp)
then
if Controlled_Type (Exp_Type) then
if CW_Or_Controlled_Type (Exp_Type) then
-- Use a renaming to capture the expression, rather than create
-- a controlled temporary.
......@@ -5124,20 +5069,15 @@ package body Exp_Util is
E : Entity_Id;
begin
E := First_Entity (Typ);
E := First_Component_Or_Discriminant (Typ);
while Present (E) loop
if Ekind (E) = E_Component
or else Ekind (E) = E_Discriminant
if Component_May_Be_Bit_Aligned (E)
or else Type_May_Have_Bit_Aligned_Components (Etype (E))
then
if Component_May_Be_Bit_Aligned (E)
or else
Type_May_Have_Bit_Aligned_Components (Etype (E))
then
return True;
end if;
return True;
end if;
Next_Entity (E);
Next_Component_Or_Discriminant (E);
end loop;
return False;
......
gcc/ada/exp_util.ads
......@@ -33,21 +33,6 @@ with Types; use Types;
package Exp_Util is
-- An enumeration type used to capture all the possible interface
-- kinds and their hierarchical relation. These values are used in
-- Find_Implemented_Interface and Implements_Interface.
type Interface_Kind is (
Any_Interface, -- Any interface
Any_Limited_Interface, -- Only limited interfaces
Any_Synchronized_Interface, -- Only synchronized interfaces
Iface, -- Individual kinds
Limited_Interface,
Protected_Interface,
Synchronized_Interface,
Task_Interface);
-----------------------------------------------
-- Handling of Actions Associated with Nodes --
-----------------------------------------------
......@@ -363,16 +348,6 @@ package Exp_Util is
-- Ada 2005 (AI-251): Given a type T implementing the interface Iface,
-- return the record component containing the tag of Iface.
function Find_Implemented_Interface
(Typ : Entity_Id;
Kind : Interface_Kind;
Check_Parent : Boolean := False) return Entity_Id;
-- Ada 2005 (AI-345): Find a designated kind of interface implemented by
-- Typ or any parent subtype. Return the first encountered interface that
-- correspond to the selected class. Return Empty if no such interface is
-- found. Use Check_Parent to climb a potential derivation chain and
-- examine the parent subtypes for any implementation.
function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id;
-- Find the first primitive operation of type T whose name is 'Name'.
-- This function allows the use of a primitive operation which is not
......@@ -444,14 +419,6 @@ package Exp_Util is
-- chain, counting only entries in the curren scope. If an entity is not
-- overloaded, the returned number will be one.
function Implements_Interface
(Typ : Entity_Id;
Kind : Interface_Kind;
Check_Parent : Boolean := False) return Boolean;
-- Ada 2005 (AI-345): Determine whether Typ implements a designated kind
-- of interface. Use Check_Parent to climb a potential derivation chain
-- and examine the parent subtypes for any implementation.
function Inside_Init_Proc return Boolean;
-- Returns True if current scope is within an init proc
......
gcc/ada/par-ch12.adb
......@@ -635,8 +635,7 @@ package body Ch12 is
return P_Formal_Floating_Point_Definition;
when Tok_Interface => -- Ada 2005 (AI-251)
return P_Interface_Type_Definition (Abstract_Present => False,
Is_Synchronized => False);
return P_Interface_Type_Definition (Abstract_Present => False);
when Tok_Left_Paren =>
return P_Formal_Discrete_Type_Definition;
......@@ -646,9 +645,8 @@ package body Ch12 is
Scan; -- past LIMITED
if Token = Tok_Interface then
Typedef_Node := P_Interface_Type_Definition
(Abstract_Present => False,
Is_Synchronized => False);
Typedef_Node :=
P_Interface_Type_Definition (Abstract_Present => False);
Set_Limited_Present (Typedef_Node);
return Typedef_Node;
......@@ -720,9 +718,8 @@ package body Ch12 is
-- Interface
else
Typedef_Node := P_Interface_Type_Definition
(Abstract_Present => False,
Is_Synchronized => True);
Typedef_Node :=
P_Interface_Type_Definition (Abstract_Present => False);
case Saved_Token is
when Tok_Task =>
......
gcc/ada/sem_disp.adb
......@@ -204,6 +204,12 @@ package body Sem_Disp is
Tagged_Type := Base_Type (Designated_Type (T));
end if;
-- Ada 2005 : an incomplete type can be tagged. An operation with
-- an access parameter of the type is dispatching.
elsif Scope (Designated_Type (T)) = Current_Scope then
Tagged_Type := Designated_Type (T);
-- Ada 2005 (AI-50217)
elsif From_With_Type (Designated_Type (T))
......@@ -231,13 +237,13 @@ package body Sem_Disp is
and then (not Is_Generic_Type (Tagged_Type)
or else not Comes_From_Source (Subp)))
or else
(Is_Formal_Subprogram (Subp) and then Is_Abstract (Subp))
(Is_Formal_Subprogram (Subp) and then Is_Abstract_Subprogram (Subp))
or else
(Nkind (Parent (Parent (Subp))) = N_Subprogram_Renaming_Declaration
and then
Present (Corresponding_Formal_Spec (Parent (Parent (Subp))))
and then
Is_Abstract (Subp))
Is_Abstract_Subprogram (Subp))
then
return Tagged_Type;
......@@ -274,11 +280,11 @@ package body Sem_Disp is
Par : Node_Id;
begin
if Is_Abstract (Subp)
if Is_Abstract_Subprogram (Subp)
and then No (Controlling_Argument (N))
then
if Present (Alias (Subp))
and then not Is_Abstract (Alias (Subp))
and then not Is_Abstract_Subprogram (Alias (Subp))
and then No (DTC_Entity (Subp))
then
-- Private overriding of inherited abstract operation,
......@@ -428,6 +434,7 @@ package body Sem_Disp is
-- Mark call as a dispatching call
Set_Controlling_Argument (N, Control);
Check_Restriction (No_Dispatching_Calls, N);
-- Ada 2005 (AI-318-02): Check current implementation restriction
-- that a dispatching call cannot be made to a primitive function
......@@ -481,7 +488,7 @@ package body Sem_Disp is
(Expression (Original_Node (Actual)))));
end if;
if Present (Func) and then Is_Abstract (Func) then
if Present (Func) and then Is_Abstract_Subprogram (Func) then
Error_Msg_N (
"call to abstract function must be dispatching", N);
end if;
......@@ -1080,7 +1087,8 @@ package body Sem_Disp is
-- a descendant type and inherits a nonabstract version.
if Etype (Subp) /= Tagged_Type then
Set_Is_Abstract (Old_Subp, Is_Abstract (Alias (Subp)));
Set_Is_Abstract_Subprogram
(Old_Subp, Is_Abstract_Subprogram (Alias (Subp)));
end if;
end if;
end if;
......@@ -1315,7 +1323,8 @@ package body Sem_Disp is
then
-- Ada 2005 (AI-251): Update the attribute alias of all the aliased
-- entities of the overriden primitive to reference New_Op, and also
-- propagate them the new value of the attribute Is_Abstract.
-- propagate them the new value of the attribute
-- Is_Abstract_Subprogram.
Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
while Present (Elmt) loop
......@@ -1328,12 +1337,13 @@ package body Sem_Disp is
and then Alias (Prim) = Prev_Op
then
Set_Alias (Prim, New_Op);
Set_Is_Abstract (Prim, Is_Abstract (New_Op));
Set_Is_Abstract_Subprogram
(Prim, Is_Abstract_Subprogram (New_Op));
-- Ensure that this entity will be expanded to fill the
-- corresponding entry in its dispatch table.
if not Is_Abstract (Prim) then
if not Is_Abstract_Subprogram (Prim) then
Set_Has_Delayed_Freeze (Prim);
end if;
end if;
......
gcc/ada/sem_elab.adb
......@@ -2443,15 +2443,13 @@ package body Sem_Elab is
Chars (Subp) = Name_Initialize
and then Comes_From_Source (Subp)
and then Present (Parameter_Associations (Call))
and then Is_Controlled
(Etype (First (Parameter_Associations (Call))));
and then Is_Controlled (Etype (First_Actual (Call)));
begin
-- If the unit is mentioned in a with_clause of the current
-- unit, it is visible, and we can set the elaboration flag.
if Is_Immediately_Visible (Scop)
or else
(Is_Child_Unit (Scop) and then Is_Visible_Child_Unit (Scop))
or else (Is_Child_Unit (Scop) and then Is_Visible_Child_Unit (Scop))
then
Activate_Elaborate_All_Desirable (Call, Scop);
Set_Suppress_Elaboration_Warnings (Scop, True);
......@@ -2482,10 +2480,10 @@ package body Sem_Elab is
if Is_Init_Proc (Subp)
or else Init_Call
then
-- The initialization call is on an object whose type is not
-- declared in the same scope as the subprogram. The type of
-- the object must be a subtype of the type of operation. This
-- object is the first actual in the call.
-- The initialization call is on an object whose type is not declared
-- in the same scope as the subprogram. The type of the object must
-- be a subtype of the type of operation. This object is the first
-- actual in the call.
declare
Typ : constant Entity_Id :=
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment