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
This commit is contained in:
Javier Miranda
Arnaud Charlet
parent
5277cab69b
commit
dee4682a7a
1250
gcc/ada/Make-lang.in
1250
gcc/ada/Make-lang.in
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,688 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- 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;
|
||||
|
|
@ -0,0 +1,182 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- 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;
|
||||
|
|
@ -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),
|
||||
|
|
|
|||
2037
gcc/ada/exp_disp.adb
2037
gcc/ada/exp_disp.adb
File diff suppressed because it is too large
Load Diff
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
||||
if Present (Full_View (Etype (Typ))) then
|
||||
-- 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;
|
||||
|
||||
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
|
||||
-- Traverse the list of interfaces implemented by the type
|
||||
|
||||
if Found then
|
||||
return;
|
||||
end if;
|
||||
|
||||
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;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 =>
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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 :=
|
||||
|
|
|
|||
Loading…
Reference in New Issue