===================================================================
@@ -219,11 +219,11 @@ package body Einfo is
-- Last_Assignment Node26
-- Overridden_Operation Node26
-- Package_Instantiation Node26
- -- Related_Type Node26
-- Relative_Deadline_Variable Node26
-- Static_Initialization Node26
-- Current_Use_Clause Node27
+ -- Related_Type Node27
-- Wrapped_Entity Node27
-- Extra_Formals Node28
@@ -1481,7 +1481,6 @@ package body Einfo is
function Has_Thunks (Id : E) return B is
begin
- pragma Assert (Ekind (Id) = E_Constant);
return Flag228 (Id);
end Has_Thunks;
@@ -2442,8 +2441,8 @@ package body Einfo is
function Related_Type (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Component, E_Constant));
- return Node26 (Id);
+ pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable));
+ return Node27 (Id);
end Related_Type;
function Relative_Deadline_Variable (Id : E) return E is
@@ -3884,8 +3883,7 @@ package body Einfo is
procedure Set_Has_Thunks (Id : E; V : B := True) is
begin
- pragma Assert (Is_Tag (Id)
- and then Ekind (Id) = E_Constant);
+ pragma Assert (Is_Tag (Id));
Set_Flag228 (Id, V);
end Set_Has_Thunks;
@@ -4452,7 +4450,7 @@ package body Einfo is
procedure Set_Is_Tag (Id : E; V : B := True) is
begin
- pragma Assert (Ekind_In (Id, E_Component, E_Constant));
+ pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable));
Set_Flag78 (Id, V);
end Set_Is_Tag;
@@ -4883,8 +4881,8 @@ package body Einfo is
procedure Set_Related_Type (Id : E; V : E) is
begin
- pragma Assert (Ekind_In (Id, E_Component, E_Constant));
- Set_Node26 (Id, V);
+ pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable));
+ Set_Node27 (Id, V);
end Set_Related_Type;
procedure Set_Relative_Deadline_Variable (Id : E; V : E) is
@@ -8011,10 +8009,6 @@ package body Einfo is
procedure Write_Field26_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Component |
- E_Constant =>
- Write_Str ("Related_Type");
-
when E_Generic_Package |
E_Package =>
Write_Str ("Package_Instantiation");
@@ -8052,6 +8046,11 @@ package body Einfo is
procedure Write_Field27_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
+ when E_Component |
+ E_Constant |
+ E_Variable =>
+ Write_Str ("Related_Type");
+
when E_Procedure =>
Write_Str ("Wrapped_Entity");
===================================================================
@@ -3306,10 +3306,10 @@ package Einfo is
-- wrapper package, but for debugging purposes its external symbol
-- must correspond to the name and scope of the related instance.
+-- Related_Type (Node27)
+-- Present in components, constants and variables. Set when there is an
+-- associated dispatch table to point to entities containing primary or
+-- secondary tags. Not set in the _tag component of record types.
-- Relative_Deadline_Variable (Node26) [implementation base type only]
-- Present in task type entities. This flag is set if a valid and
@@ -4827,7 +4827,7 @@ package Einfo is
-- Interface_Name (Node21) (JGNAT usage only)
-- Original_Record_Component (Node22)
-- DT_Offset_To_Top_Func (Node25)
- -- Related_Type (Node26)
+ -- Related_Type (Node27)
-- Has_Biased_Representation (Flag139)
-- Has_Per_Object_Constraint (Flag154)
-- Is_Atomic (Flag85)
@@ -4850,7 +4850,7 @@ package Einfo is
-- Size_Check_Code (Node19) (constants only)
-- Prival_Link (Node20) (privals only)
-- Interface_Name (Node21)
- -- Related_Type (Node26) (constants only)
+ -- Related_Type (Node27) (constants only)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
@@ -5479,6 +5479,7 @@ package Einfo is
-- Related_Expression (Node24)
-- Debug_Renaming_Link (Node25)
-- Last_Assignment (Node26)
+ -- Related_Type (Node27)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
===================================================================
@@ -34,6 +34,7 @@ with Exp_Util; use Exp_Util;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
+with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
with Fname; use Fname;
with Freeze; use Freeze;
@@ -2840,12 +2841,61 @@ package body Exp_Aggr is
-- constructor to ensure the proper initialization of the _Tag
-- component.
- if Is_CPP_Class (Typ) then
- pragma Assert (Present (Base_Init_Proc (Typ)));
- Append_List_To (L,
- Build_Initialization_Call (Loc,
- Id_Ref => Lhs,
- Typ => Typ));
+ if Is_CPP_Class (Root_Type (Typ))
+ and then CPP_Num_Prims (Typ) > 0
+ then
+ Invoke_Constructor : declare
+ CPP_Parent : constant Entity_Id :=
+ Enclosing_CPP_Parent (Typ);
+
+ procedure Invoke_IC_Proc (T : Entity_Id);
+ -- Recursive routine used to climb to parents. Required because
+ -- parents must be initialized before descendants to ensure
+ -- propagation of inherited C++ slots.
+
+ --------------------
+ -- Invoke_IC_Proc --
+ --------------------
+
+ procedure Invoke_IC_Proc (T : Entity_Id) is
+ begin
+ -- Avoid generating extra calls. Initialization required
+ -- only for types defined from the level of derivation of
+ -- type of the constructor and the type of the aggregate.
+
+ if T = CPP_Parent then
+ return;
+ end if;
+
+ Invoke_IC_Proc (Etype (T));
+
+ -- Generate call to the IC routine
+
+ if Present (CPP_Init_Proc (T)) then
+ Append_To (L,
+ Make_Procedure_Call_Statement (Loc,
+ New_Reference_To (CPP_Init_Proc (T), Loc)));
+ end if;
+ end Invoke_IC_Proc;
+
+ -- Start of processing for Invoke_Constructor
+
+ begin
+ -- Implicit invocation of the C++ constructor
+
+ if Nkind (N) = N_Aggregate then
+ Append_To (L,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To
+ (Base_Init_Proc (CPP_Parent), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (CPP_Parent,
+ New_Copy_Tree (Lhs)))));
+ end if;
+
+ Invoke_IC_Proc (Typ);
+ end Invoke_Constructor;
end if;
-- Generate the assignments, component by component
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 2006-2010, 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- --
@@ -26,6 +26,7 @@
with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
+with Exp_Disp; use Exp_Disp;
with Exp_Util; use Exp_Util;
with Namet; use Namet;
with Nlists; use Nlists;
@@ -33,6 +34,7 @@ with Nmake; use Nmake;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sem_Aux; use Sem_Aux;
+with Sem_Disp; use Sem_Disp;
with Sem_Util; use Sem_Util;
with Stand; use Stand;
with Snames; use Snames;
@@ -327,6 +329,258 @@ package body Exp_Atag is
New_List (Make_Integer_Literal (Loc, Position)));
end Build_Get_Predefined_Prim_Op_Address;
+ -----------------------------
+ -- Build_Inherit_CPP_Prims --
+ -----------------------------
+
+ function Build_Inherit_CPP_Prims (Typ : Entity_Id) return List_Id is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
+ CPP_Table : array (1 .. CPP_Nb_Prims) of Boolean := (others => False);
+ CPP_Typ : constant Entity_Id := Enclosing_CPP_Parent (Typ);
+ Result : constant List_Id := New_List;
+ Parent_Typ : constant Entity_Id := Etype (Typ);
+ E : Entity_Id;
+ Elmt : Elmt_Id;
+ Parent_Tag : Entity_Id;
+ Prim : Entity_Id;
+ Prim_Pos : Nat;
+ Typ_Tag : Entity_Id;
+
+ begin
+ pragma Assert (not Is_CPP_Class (Typ));
+
+ -- No code needed if this type has no primitives inherited from C++
+
+ if CPP_Nb_Prims = 0 then
+ return Result;
+ end if;
+
+ -- Stage 1: Inherit and override C++ slots of the primary dispatch table
+
+ -- Generate:
+ -- Typ'Tag (Prim_Pos) := Prim'Unrestricted_Access;
+
+ Parent_Tag := Node (First_Elmt (Access_Disp_Table (Parent_Typ)));
+ Typ_Tag := Node (First_Elmt (Access_Disp_Table (Typ)));
+
+ Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Elmt) loop
+ Prim := Node (Elmt);
+ E := Ultimate_Alias (Prim);
+ Prim_Pos := UI_To_Int (DT_Position (E));
+
+ -- Skip predefined, abstract, and eliminated primitives. Skip also
+ -- primitives not located in the C++ part of the dispatch table.
+
+ if not Is_Predefined_Dispatching_Operation (Prim)
+ and then not Is_Predefined_Dispatching_Operation (E)
+ and then not Present (Interface_Alias (Prim))
+ and then not Is_Abstract_Subprogram (E)
+ and then not Is_Eliminated (E)
+ and then Prim_Pos <= CPP_Nb_Prims
+ and then Find_Dispatching_Type (E) = Typ
+ then
+ -- Remember that this slot is used
+
+ pragma Assert (CPP_Table (Prim_Pos) = False);
+ CPP_Table (Prim_Pos) := True;
+
+ Append_To (Result,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To
+ (Node (Last_Elmt (Access_Disp_Table (Typ))),
+ New_Reference_To (Typ_Tag, Loc))),
+ Expressions =>
+ New_List (Make_Integer_Literal (Loc, Prim_Pos))),
+
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (E, Loc),
+ Attribute_Name => Name_Unrestricted_Access))));
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ -- If all primitives have been overridden then there is no need to copy
+ -- from Typ's parent its dispatch table. Otherwise, if some primitive is
+ -- inherited from the parent we copy only the C++ part of the dispatch
+ -- table from the parent before the assignments that initialize the
+ -- overridden primitives.
+
+ -- Generate:
+
+ -- type CPP_TypG is array (1 .. CPP_Nb_Prims) ofd Prim_Ptr;
+ -- type CPP_TypH is access CPP_TypG;
+ -- CPP_TypG!(Typ_Tag).all := CPP_TypG!(Parent_Tag).all;
+
+ -- Note: There is no need to duplicate the declarations of CPP_TypG and
+ -- CPP_TypH because, for expansion of dispatching calls, these
+ -- entities are stored in the last elements of Access_Disp_Table.
+
+ for J in CPP_Table'Range loop
+ if not CPP_Table (J) then
+ Prepend_To (Result,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To
+ (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))),
+ New_Reference_To (Typ_Tag, Loc))),
+ Expression =>
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To
+ (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))),
+ New_Reference_To (Parent_Tag, Loc)))));
+ exit;
+ end if;
+ end loop;
+
+ -- Stage 2: Inherit and override C++ slots of secondary dispatch tables
+
+ declare
+ Iface : Entity_Id;
+ Iface_Nb_Prims : Nat;
+ Parent_Ifaces_List : Elist_Id;
+ Parent_Ifaces_Comp_List : Elist_Id;
+ Parent_Ifaces_Tag_List : Elist_Id;
+ Parent_Iface_Tag_Elmt : Elmt_Id;
+ Typ_Ifaces_List : Elist_Id;
+ Typ_Ifaces_Comp_List : Elist_Id;
+ Typ_Ifaces_Tag_List : Elist_Id;
+ Typ_Iface_Tag_Elmt : Elmt_Id;
+
+ begin
+ Collect_Interfaces_Info
+ (T => Parent_Typ,
+ Ifaces_List => Parent_Ifaces_List,
+ Components_List => Parent_Ifaces_Comp_List,
+ Tags_List => Parent_Ifaces_Tag_List);
+
+ Collect_Interfaces_Info
+ (T => Typ,
+ Ifaces_List => Typ_Ifaces_List,
+ Components_List => Typ_Ifaces_Comp_List,
+ Tags_List => Typ_Ifaces_Tag_List);
+
+ Parent_Iface_Tag_Elmt := First_Elmt (Parent_Ifaces_Tag_List);
+ Typ_Iface_Tag_Elmt := First_Elmt (Typ_Ifaces_Tag_List);
+ while Present (Parent_Iface_Tag_Elmt) loop
+ Parent_Tag := Node (Parent_Iface_Tag_Elmt);
+ Typ_Tag := Node (Typ_Iface_Tag_Elmt);
+
+ pragma Assert
+ (Related_Type (Parent_Tag) = Related_Type (Typ_Tag));
+ Iface := Related_Type (Parent_Tag);
+
+ Iface_Nb_Prims :=
+ UI_To_Int (DT_Entry_Count (First_Tag_Component (Iface)));
+
+ if Iface_Nb_Prims > 0 then
+
+ -- Update slots of overridden primitives
+
+ declare
+ Last_Nod : constant Node_Id := Last (Result);
+ Nb_Prims : constant Nat := UI_To_Int
+ (DT_Entry_Count
+ (First_Tag_Component (Iface)));
+ Elmt : Elmt_Id;
+ Prim : Entity_Id;
+ E : Entity_Id;
+ Prim_Pos : Nat;
+
+ Prims_Table : array (1 .. Nb_Prims) of Boolean;
+
+ begin
+ Prims_Table := (others => False);
+
+ Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Elmt) loop
+ Prim := Node (Elmt);
+ E := Ultimate_Alias (Prim);
+
+ if not Is_Predefined_Dispatching_Operation (Prim)
+ and then Present (Interface_Alias (Prim))
+ and then Find_Dispatching_Type (Interface_Alias (Prim))
+ = Iface
+ and then not Is_Abstract_Subprogram (E)
+ and then not Is_Eliminated (E)
+ and then Find_Dispatching_Type (E) = Typ
+ then
+ Prim_Pos := UI_To_Int (DT_Position (Prim));
+
+ -- Remember that this slot is already initialized
+
+ pragma Assert (Prims_Table (Prim_Pos) = False);
+ Prims_Table (Prim_Pos) := True;
+
+ Append_To (Result,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To
+ (Node
+ (Last_Elmt
+ (Access_Disp_Table (Iface))),
+ New_Reference_To (Typ_Tag, Loc))),
+ Expressions =>
+ New_List
+ (Make_Integer_Literal (Loc, Prim_Pos))),
+
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (E, Loc),
+ Attribute_Name =>
+ Name_Unrestricted_Access))));
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ -- Check if all primitives from the parent have been
+ -- overridden (to avoid copying the whole secondary
+ -- table from the parent).
+
+ -- IfaceG!(Typ_Sec_Tag).all := IfaceG!(Parent_Sec_Tag).all;
+
+ for J in Prims_Table'Range loop
+ if not Prims_Table (J) then
+ Insert_After (Last_Nod,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To
+ (Node (Last_Elmt (Access_Disp_Table (Iface))),
+ New_Reference_To (Typ_Tag, Loc))),
+ Expression =>
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To
+ (Node (Last_Elmt (Access_Disp_Table (Iface))),
+ New_Reference_To (Parent_Tag, Loc)))));
+ exit;
+ end if;
+ end loop;
+ end;
+ end if;
+
+ Next_Elmt (Typ_Iface_Tag_Elmt);
+ Next_Elmt (Parent_Iface_Tag_Elmt);
+ end loop;
+ end;
+
+ return Result;
+ end Build_Inherit_CPP_Prims;
+
-------------------------
-- Build_Inherit_Prims --
-------------------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 2006-2010, 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- --
@@ -97,6 +97,11 @@ package Exp_Atag is
--
-- Generates: TSD (Tag).Transportable;
+ function Build_Inherit_CPP_Prims (Typ : Entity_Id) return List_Id;
+ -- Build code that copies from Typ's parent the dispatch table slots of
+ -- inherited primitives and updates slots of overridden primitives. The
+ -- generated code handles primary and secondary dispatch tables of Typ.
+
function Build_Inherit_Predefined_Prims
(Loc : Source_Ptr;
Old_Tag_Node : Node_Id;
===================================================================
@@ -214,6 +214,9 @@ package body Exp_Ch3 is
-- Check if E is defined in the RTL (in a child of Ada or System). Used
-- to avoid to bring in the overhead of _Input, _Output for tagged types.
+ function Is_Variable_Size_Array (E : Entity_Id) return Boolean;
+ -- Returns true if E has variable size components
+
function Is_Variable_Size_Record (E : Entity_Id) return Boolean;
-- Returns true if E has variable size components
@@ -1777,6 +1780,12 @@ package body Exp_Ch3 is
--
-- This function builds the call statement in this _init_proc.
+ procedure Build_CPP_Init_Procedure;
+ -- Build the tree corresponding to the procedure specification and body
+ -- of the IC procedure that initializes the C++ part of the dispatch
+ -- table of an Ada tagged type that is a derivation of a CPP type.
+ -- Install it as the CPP_Init TSS.
+
procedure Build_Init_Procedure;
-- Build the tree corresponding to the procedure specification and body
-- of the initialization procedure (by calling all the preceding
@@ -2209,6 +2218,104 @@ package body Exp_Ch3 is
end loop;
end Build_Offset_To_Top_Functions;
+ ------------------------------
+ -- Build_CPP_Init_Procedure --
+ ------------------------------
+
+ procedure Build_CPP_Init_Procedure is
+ Body_Node : Node_Id;
+ Body_Stmts : List_Id;
+ Flag_Id : Entity_Id;
+ Flag_Decl : Node_Id;
+ Handled_Stmt_Node : Node_Id;
+ Init_Tags_List : List_Id;
+ Proc_Id : Entity_Id;
+ Proc_Spec_Node : Node_Id;
+
+ begin
+ -- Check cases requiring no IC routine
+
+ if not Is_CPP_Class (Root_Type (Rec_Type))
+ or else Is_CPP_Class (Rec_Type)
+ or else CPP_Num_Prims (Rec_Type) = 0
+ or else not Tagged_Type_Expansion
+ or else No_Run_Time_Mode
+ then
+ return;
+ end if;
+
+ -- Generate:
+
+ -- Flag : Boolean := False;
+ --
+ -- procedure Typ_IC is
+ -- begin
+ -- if not Flag then
+ -- Copy C++ dispatch table slots from parent
+ -- Update C++ slots of overridden primitives
+ -- end if;
+ -- end;
+
+ Flag_Id := Make_Temporary (Loc, 'F');
+
+ Flag_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Flag_Id,
+ Object_Definition =>
+ New_Reference_To (Standard_Boolean, Loc),
+ Expression =>
+ New_Reference_To (Standard_True, Loc));
+
+ Analyze (Flag_Decl);
+ Append_Freeze_Action (Rec_Type, Flag_Decl);
+
+ Body_Stmts := New_List;
+ Body_Node := New_Node (N_Subprogram_Body, Loc);
+
+ Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
+
+ Proc_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Make_TSS_Name (Rec_Type, TSS_CPP_Init_Proc));
+
+ Set_Ekind (Proc_Id, E_Procedure);
+ Set_Is_Internal (Proc_Id);
+
+ Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
+
+ Set_Parameter_Specifications (Proc_Spec_Node, New_List);
+ Set_Specification (Body_Node, Proc_Spec_Node);
+ Set_Declarations (Body_Node, New_List);
+
+ Init_Tags_List := Build_Inherit_CPP_Prims (Rec_Type);
+
+ Append_To (Init_Tags_List,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Reference_To (Flag_Id, Loc),
+ Expression =>
+ New_Reference_To (Standard_False, Loc)));
+
+ Append_To (Body_Stmts,
+ Make_If_Statement (Loc,
+ Condition => New_Occurrence_Of (Flag_Id, Loc),
+ Then_Statements => Init_Tags_List));
+
+ Handled_Stmt_Node :=
+ New_Node (N_Handled_Sequence_Of_Statements, Loc);
+ Set_Statements (Handled_Stmt_Node, Body_Stmts);
+ Set_Exception_Handlers (Handled_Stmt_Node, No_List);
+ Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
+
+ if not Debug_Generated_Code then
+ Set_Debug_Info_Off (Proc_Id);
+ end if;
+
+ -- Associate CPP_Init_Proc with type
+
+ Set_Init_Proc (Rec_Type, Proc_Id);
+ end Build_CPP_Init_Procedure;
+
--------------------------
-- Build_Init_Procedure --
--------------------------
@@ -2239,9 +2346,7 @@ package body Exp_Ch3 is
-- a type extension. If the flag is false, we do not set the tag
-- because it has been set already in the extension.
- if Is_Tagged_Type (Rec_Type)
- and then not Is_CPP_Class (Rec_Type)
- then
+ if Is_Tagged_Type (Rec_Type) then
Set_Tag := Make_Temporary (Loc, 'P');
Append_To (Parameters,
@@ -2312,133 +2417,154 @@ package body Exp_Ch3 is
-- the C++ side.
if Is_Tagged_Type (Rec_Type)
- and then not Is_CPP_Class (Rec_Type)
and then Tagged_Type_Expansion
and then not No_Run_Time_Mode
then
- -- Initialize the primary tag
+ -- Case 1: Ada tagged types with no CPP ancestor. Set the tags of
+ -- the actual object and invoke the IP of the parent (in this
+ -- order). The tag must be initialized before the call to the IP
+ -- of the parent and the assignments to other components because
+ -- the initial value of the components may depend on the tag (eg.
+ -- through a dispatching operation on an access to the current
+ -- type). The tag assignment is not done when initializing the
+ -- parent component of a type extension, because in that case the
+ -- tag is set in the extension.
- Init_Tags_List := New_List (
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name =>
- New_Reference_To (First_Tag_Component (Rec_Type), Loc)),
-
- Expression =>
- New_Reference_To
- (Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
+ if not Is_CPP_Class (Root_Type (Rec_Type)) then
- -- Ada 2005 (AI-251): Initialize the secondary tags components
- -- located at fixed positions (tags whose position depends on
- -- variable size components are initialized later ---see below).
+ -- Initialize the primary tag component
- if Ada_Version >= Ada_05
- and then not Is_Interface (Rec_Type)
- and then Has_Interfaces (Rec_Type)
- then
- Init_Secondary_Tags
- (Typ => Rec_Type,
- Target => Make_Identifier (Loc, Name_uInit),
- Stmts_List => Init_Tags_List,
- Fixed_Comps => True,
- Variable_Comps => False);
- end if;
+ Init_Tags_List := New_List (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name =>
+ New_Reference_To
+ (First_Tag_Component (Rec_Type), Loc)),
+ Expression =>
+ New_Reference_To
+ (Node
+ (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
- -- The tag must be inserted before the assignments to other
- -- components, because the initial value of the component may
- -- depend on the tag (eg. through a dispatching operation on
- -- an access to the current type). The tag assignment is not done
- -- when initializing the parent component of a type extension,
- -- because in that case the tag is set in the extension.
-
- -- Extensions of imported C++ classes add a final complication,
- -- because we cannot inhibit tag setting in the constructor for
- -- the parent. In that case we insert the tag initialization
- -- after the calls to initialize the parent.
+ -- Ada 2005 (AI-251): Initialize the secondary tags components
+ -- located at fixed positions (tags whose position depends on
+ -- variable size components are initialized later ---see below)
+
+ if Ada_Version >= Ada_05
+ and then not Is_Interface (Rec_Type)
+ and then Has_Interfaces (Rec_Type)
+ then
+ Init_Secondary_Tags
+ (Typ => Rec_Type,
+ Target => Make_Identifier (Loc, Name_uInit),
+ Stmts_List => Init_Tags_List,
+ Fixed_Comps => True,
+ Variable_Comps => False);
+ end if;
- if not Is_CPP_Class (Root_Type (Rec_Type)) then
Prepend_To (Body_Stmts,
Make_If_Statement (Loc,
Condition => New_Occurrence_Of (Set_Tag, Loc),
Then_Statements => Init_Tags_List));
- -- CPP_Class derivation: In this case the dispatch table of the
- -- parent was built in the C++ side and we copy the table of the
- -- parent to initialize the new dispatch table.
+ -- Case 2: CPP type. The imported C++ constructor takes care of
+ -- tags initialization. No action needed here because the IP
+ -- is built by Set_CPP_Constructors; in this case the IP is a
+ -- wrapper that invokes the C++ constructor and copies the C++
+ -- tags locally. Done to inherit the C++ slots in Ada derivations
+ -- (see case 3).
+
+ elsif Is_CPP_Class (Rec_Type) then
+ pragma Assert (False);
+ null;
+
+ -- Case 3: Combined hierarchy containing C++ types and Ada tagged
+ -- type derivations. Derivations of imported C++ classes add a
+ -- complication, because we cannot inhibit tag setting in the
+ -- constructor for the parent. Hence we initialize the tag after
+ -- the call to the parent IP (that is, in reverse order compared
+ -- with pure Ada hierarchies ---see comment on case 1).
else
+ -- Initialize the primary tag
+
+ Init_Tags_List := New_List (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name =>
+ New_Reference_To
+ (First_Tag_Component (Rec_Type), Loc)),
+ Expression =>
+ New_Reference_To
+ (Node
+ (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
+
+ -- Ada 2005 (AI-251): Initialize the secondary tags components
+ -- located at fixed positions (tags whose position depends on
+ -- variable size components are initialized later ---see below)
+
+ if Ada_Version >= Ada_05
+ and then not Is_Interface (Rec_Type)
+ and then Has_Interfaces (Rec_Type)
+ then
+ Init_Secondary_Tags
+ (Typ => Rec_Type,
+ Target => Make_Identifier (Loc, Name_uInit),
+ Stmts_List => Init_Tags_List,
+ Fixed_Comps => True,
+ Variable_Comps => False);
+ end if;
+
+ -- Initialize the tag component after invocation of parent IP.
+
+ -- Generate:
+ -- parent_IP(_init.parent); // Invokes the C++ constructor
+ -- [ typIC; ] // Inherit C++ slots from parent
+ -- init_tags
+
declare
- Nod : Node_Id;
+ Ins_Nod : Node_Id;
begin
- -- We assume the first init_proc call is for the parent
+ -- Search for the call to the IP of the parent. We assume
+ -- that the first init_proc call is for the parent.
- Nod := First (Body_Stmts);
- while Present (Next (Nod))
- and then (Nkind (Nod) /= N_Procedure_Call_Statement
- or else not Is_Init_Proc (Name (Nod)))
+ Ins_Nod := First (Body_Stmts);
+ while Present (Next (Ins_Nod))
+ and then (Nkind (Ins_Nod) /= N_Procedure_Call_Statement
+ or else not Is_Init_Proc (Name (Ins_Nod)))
loop
- Nod := Next (Nod);
+ Next (Ins_Nod);
end loop;
- -- Generate:
- -- ancestor_constructor (_init.parent);
- -- if Arg2 then
- -- inherit_prim_ops (_init._tag, new_dt, num_prims);
- -- _init._tag := new_dt;
- -- end if;
-
- Prepend_To (Init_Tags_List,
- Build_Inherit_Prims (Loc,
- Typ => Rec_Type,
- Old_Tag_Node =>
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc,
- Chars => Name_uInit),
- Selector_Name =>
- New_Reference_To
- (First_Tag_Component (Rec_Type), Loc)),
- New_Tag_Node =>
- New_Reference_To
- (Node (First_Elmt (Access_Disp_Table (Rec_Type))),
- Loc),
- Num_Prims =>
- UI_To_Int
- (DT_Entry_Count (First_Tag_Component (Rec_Type)))));
-
- Insert_After (Nod,
- Make_If_Statement (Loc,
- Condition => New_Occurrence_Of (Set_Tag, Loc),
- Then_Statements => Init_Tags_List));
-
- -- We have inherited table of the parent from the CPP side.
- -- Now we fill the slots associated with Ada primitives.
- -- This needs more work to avoid its execution each time
- -- an object is initialized???
+ -- The IC routine copies the inherited slots of the C+ part
+ -- of the dispatch table from the parent and updates the
+ -- overridden C++ slots.
+
+ if CPP_Num_Prims (Rec_Type) > 0 then
+ declare
+ Init_DT : Entity_Id;
+ New_Nod : Node_Id;
+
+ begin
+ Init_DT := CPP_Init_Proc (Rec_Type);
+ pragma Assert (Present (Init_DT));
+
+ New_Nod :=
+ Make_Procedure_Call_Statement (Loc,
+ New_Reference_To (Init_DT, Loc));
+ Insert_After (Ins_Nod, New_Nod);
- declare
- E : Elmt_Id;
- Prim : Node_Id;
+ -- Update location of init tag statements
- begin
- E := First_Elmt (Primitive_Operations (Rec_Type));
- while Present (E) loop
- Prim := Node (E);
-
- if not Is_Imported (Prim)
- and then Convention (Prim) = Convention_CPP
- and then not Present (Interface_Alias (Prim))
- then
- Append_List_To (Init_Tags_List,
- Register_Primitive (Loc, Prim => Prim));
- end if;
+ Ins_Nod := New_Nod;
+ end;
+ end if;
- Next_Elmt (E);
- end loop;
- end;
+ Insert_List_After (Ins_Nod, Init_Tags_List);
end;
end if;
@@ -3116,7 +3242,8 @@ package body Exp_Ch3 is
-- at the other end of the call, even if it does nothing!)
-- Note: the reason we exclude the CPP_Class case is because in this
- -- case the initialization is performed in the C++ side.
+ -- case the initialization is performed by the C++ constructors, and
+ -- the IP is built by Set_CPP_Constructors.
if Is_CPP_Class (Rec_Id) then
return False;
@@ -3243,6 +3370,7 @@ package body Exp_Ch3 is
end if;
Build_Offset_To_Top_Functions;
+ Build_CPP_Init_Procedure;
Build_Init_Procedure;
Set_Is_Public (Proc_Id, Is_Public (Pe));
@@ -5720,7 +5848,6 @@ package body Exp_Ch3 is
if Is_CPP_Class (Def_Id) then
Set_All_DT_Position (Def_Id);
- Set_CPP_Constructors (Def_Id);
-- Create the tag entities with a minimum decoration
@@ -5728,6 +5855,8 @@ package body Exp_Ch3 is
Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id));
end if;
+ Set_CPP_Constructors (Def_Id);
+
else
if not Has_Static_DT then
@@ -6930,11 +7059,6 @@ package body Exp_Ch3 is
is
Loc : constant Source_Ptr := Sloc (Target);
- procedure Inherit_CPP_Tag
- (Typ : Entity_Id;
- Iface : Entity_Id;
- Tag_Comp : Entity_Id;
- Iface_Tag : Node_Id);
-- Inherit the C++ tag of the secondary dispatch table of Typ associated
-- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
@@ -6949,32 +7073,6 @@ package body Exp_Ch3 is
-- of Typ CPP tagged type we generate code to inherit the contents of
-- the dispatch table directly from the ancestor.
- ---------------------
- -- Inherit_CPP_Tag --
- ---------------------
-
- procedure Inherit_CPP_Tag
- (Typ : Entity_Id;
- Iface : Entity_Id;
- Tag_Comp : Entity_Id;
- Iface_Tag : Node_Id)
- is
- begin
- pragma Assert (Is_CPP_Class (Etype (Typ)));
-
- Append_To (Stmts_List,
- Build_Inherit_Prims (Loc,
- Typ => Iface,
- Old_Tag_Node =>
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Target),
- Selector_Name => New_Reference_To (Tag_Comp, Loc)),
- New_Tag_Node =>
- New_Reference_To (Iface_Tag, Loc),
- Num_Prims =>
- UI_To_Int (DT_Entry_Count (First_Tag_Component (Iface)))));
- end Inherit_CPP_Tag;
-
--------------------
-- Initialize_Tag --
--------------------
@@ -7175,26 +7273,85 @@ package body Exp_Ch3 is
while Present (Iface_Elmt) loop
Tag_Comp := Node (Iface_Comp_Elmt);
+ -- Check if parent of record type has variable size components
+
+ In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp))
+ and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp)));
+
-- If we are compiling under the CPP full ABI compatibility mode and
-- the ancestor is a CPP_Pragma tagged type then we generate code to
- -- inherit the contents of the dispatch table directly from the
- -- ancestor.
+ -- initialize the secondary tag components from tags that reference
+ -- secondary tables filled with copy of parent slots.
- if Is_CPP_Class (Etype (Full_Typ)) then
- Inherit_CPP_Tag (Full_Typ,
- Iface => Node (Iface_Elmt),
- Tag_Comp => Tag_Comp,
- Iface_Tag => Node (Iface_Tag_Elmt));
+ if Is_CPP_Class (Root_Type (Full_Typ)) then
- -- Otherwise generate code to initialize the tag
+ -- Reject interface components located at variable offset in
+ -- C++ derivations. This is currently unsupported.
- else
- -- Check if the parent of the record type has variable size
- -- components.
+ if not Fixed_Comps and then In_Variable_Pos then
+
+ -- Locate the first dynamic component of the record. Done to
+ -- improve the text of the warning.
+
+ declare
+ Comp : Entity_Id;
+ Comp_Typ : Entity_Id;
+
+ begin
+ Comp := First_Entity (Typ);
+ while Present (Comp) loop
+ Comp_Typ := Etype (Comp);
+
+ if Ekind (Comp) /= E_Discriminant
+ and then not Is_Tag (Comp)
+ then
+ exit when
+ (Is_Record_Type (Comp_Typ)
+ and then Is_Variable_Size_Record
+ (Base_Type (Comp_Typ)))
+ or else
+ (Is_Array_Type (Comp_Typ)
+ and then Is_Variable_Size_Array (Comp_Typ));
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+
+ pragma Assert (Present (Comp));
+ Error_Msg_Node_2 := Comp;
+ Error_Msg_NE
+ ("parent type & with dynamic component & cannot be parent"
+ & " of 'C'P'P derivation if new interfaces are present",
+ Typ, Scope (Original_Record_Component (Comp)));
+
+ Error_Msg_Sloc :=
+ Sloc (Scope (Original_Record_Component (Comp)));
+ Error_Msg_NE
+ ("type derived from 'C'P'P type & defined #",
+ Typ, Scope (Original_Record_Component (Comp)));
+
+ -- Avoid duplicated warnings
+
+ exit;
+ end;
+
+ -- Initialize secondary tags
+
+ else
+ Append_To (Stmts_List,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name =>
+ New_Reference_To (Node (Iface_Comp_Elmt), Loc)),
+ Expression =>
+ New_Reference_To (Node (Iface_Tag_Elmt), Loc)));
+ end if;
- In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp))
- and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp)));
+ -- Otherwise generate code to initialize the tag
+ else
if (In_Variable_Pos and then Variable_Comps)
or else (not In_Variable_Pos and then Fixed_Comps)
then
@@ -7211,14 +7368,11 @@ package body Exp_Ch3 is
end loop;
end Init_Secondary_Tags;
- -----------------------------
- -- Is_Variable_Size_Record --
- -----------------------------
+ ----------------------------
+ -- Is_Variable_Size_Array --
+ ----------------------------
- function Is_Variable_Size_Record (E : Entity_Id) return Boolean is
- Comp : Entity_Id;
- Comp_Typ : Entity_Id;
- Idx : Node_Id;
+ function Is_Variable_Size_Array (E : Entity_Id) return Boolean is
function Is_Constant_Bound (Exp : Node_Id) return Boolean;
-- To simplify handling of array components. Determines whether the
@@ -7244,42 +7398,60 @@ package body Exp_Ch3 is
end if;
end Is_Constant_Bound;
- -- Start of processing for Is_Variable_Sized_Record
+ -- Local variables
- begin
- pragma Assert (Is_Record_Type (E));
+ Idx : Node_Id;
- Comp := First_Entity (E);
- while Present (Comp) loop
- Comp_Typ := Etype (Comp);
+ -- Start of processing for Is_Variable_Sized_Array
- if Is_Record_Type (Comp_Typ) then
+ begin
+ pragma Assert (Is_Array_Type (E));
- -- Recursive call if the record type has discriminants
+ -- Check if some index is initialized with a non-constant value
- if Has_Discriminants (Comp_Typ)
- and then Is_Variable_Size_Record (Comp_Typ)
+ Idx := First_Index (E);
+ while Present (Idx) loop
+ if Nkind (Idx) = N_Range then
+ if not Is_Constant_Bound (Low_Bound (Idx))
+ or else not Is_Constant_Bound (High_Bound (Idx))
then
return True;
end if;
+ end if;
- elsif Is_Array_Type (Comp_Typ) then
+ Idx := Next_Index (Idx);
+ end loop;
- -- Check if some index is initialized with a non-constant value
+ return False;
+ end Is_Variable_Size_Array;
- Idx := First_Index (Comp_Typ);
- while Present (Idx) loop
- if Nkind (Idx) = N_Range then
- if not Is_Constant_Bound (Low_Bound (Idx))
- or else
- not Is_Constant_Bound (High_Bound (Idx))
- then
- return True;
- end if;
- end if;
+ -----------------------------
+ -- Is_Variable_Size_Record --
+ -----------------------------
- Idx := Next_Index (Idx);
- end loop;
+ function Is_Variable_Size_Record (E : Entity_Id) return Boolean is
+ Comp : Entity_Id;
+ Comp_Typ : Entity_Id;
+
+ begin
+ pragma Assert (Is_Record_Type (E));
+
+ Comp := First_Entity (E);
+ while Present (Comp) loop
+ Comp_Typ := Etype (Comp);
+
+ -- Recursive call if the record type has discriminants
+
+ if Is_Record_Type (Comp_Typ)
+ and then Has_Discriminants (Comp_Typ)
+ and then Is_Variable_Size_Record (Comp_Typ)
+ then
+ return True;
+
+ elsif Is_Array_Type (Comp_Typ)
+ and then Is_Variable_Size_Array (Comp_Typ)
+ then
+ return True;
end if;
Next_Entity (Comp);
===================================================================
@@ -464,6 +464,52 @@ package body Exp_Disp is
end if;
end Build_Static_Dispatch_Tables;
+ -------------------
+ -- CPP_Num_Prims --
+ -------------------
+
+ function CPP_Num_Prims (Typ : Entity_Id) return Nat is
+ CPP_Typ : Entity_Id;
+ Tag_Comp : Entity_Id;
+
+ begin
+ if not Is_Tagged_Type (Typ)
+ or else not Is_CPP_Class (Root_Type (Typ))
+ then
+ return 0;
+
+ else
+ CPP_Typ := Enclosing_CPP_Parent (Typ);
+ Tag_Comp := First_Tag_Component (CPP_Typ);
+
+ -- If the number of primitives is already set in the tag component
+ -- then use it
+
+ if Present (Tag_Comp)
+ and then DT_Entry_Count (Tag_Comp) /= No_Uint
+ then
+ return UI_To_Int (DT_Entry_Count (Tag_Comp));
+
+ -- Otherwise, count the primitives of the enclosing CPP type
+
+ else
+ declare
+ Count : Nat := 0;
+ Elmt : Elmt_Id;
+
+ begin
+ Elmt := First_Elmt (Primitive_Operations (CPP_Typ));
+ while Present (Elmt) loop
+ Count := Count + 1;
+ Next_Elmt (Elmt);
+ end loop;
+
+ return Count;
+ end;
+ end if;
+ end if;
+ end CPP_Num_Prims;
+
------------------------------
-- Default_Prim_Op_Position --
------------------------------
@@ -1733,6 +1779,30 @@ package body Exp_Disp is
end if;
end Expand_Interface_Thunk;
+ --------------------------
+ -- Has_CPP_Constructors --
+ --------------------------
+
+ function Has_CPP_Constructors (Typ : Entity_Id) return Boolean is
+ E : Entity_Id;
+
+ begin
+ -- Look for the constructor entities
+
+ E := Next_Entity (Typ);
+ while Present (E) loop
+ if Ekind (E) = E_Function
+ and then Is_Constructor (E)
+ then
+ return True;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ return False;
+ end Has_CPP_Constructors;
+
------------
-- Has_DT --
------------
@@ -3936,7 +4006,8 @@ package body Exp_Disp is
Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
elsif Is_Abstract_Type (Typ)
- or else not Building_Static_DT (Typ)
+ or else not Static_Dispatch_Tables
+ or else not Is_Library_Level_Tagged_Type (Typ)
then
for J in 1 .. Nb_Prim loop
Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
@@ -3944,48 +4015,57 @@ package body Exp_Disp is
else
declare
- Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
- Pos : Nat;
- Thunk_Code : Node_Id;
- Thunk_Id : Entity_Id;
+ CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
+ E : Entity_Id;
+ Prim_Pos : Nat;
+ Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
+ Thunk_Code : Node_Id;
+ Thunk_Id : Entity_Id;
begin
Prim_Table := (others => Empty);
Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Prim_Elmt) loop
- Prim := Node (Prim_Elmt);
+ Prim := Node (Prim_Elmt);
+ E := Ultimate_Alias (Prim);
+ Prim_Pos := UI_To_Int (DT_Position (E));
- -- Do not reference predefined primitives because they
- -- are located in a separate dispatch table; skip also
- -- abstract and eliminated primitives.
+ -- Do not reference predefined primitives because they are
+ -- located in a separate dispatch table; skip abstract and
+ -- eliminated primitives; skip primitives located in the C++
+ -- part of the dispatch table because their slot is set by
+ -- the IC routine.
if not Is_Predefined_Dispatching_Operation (Prim)
and then Present (Interface_Alias (Prim))
and then not Is_Abstract_Subprogram (Alias (Prim))
and then not Is_Eliminated (Alias (Prim))
+ and then (not Is_CPP_Class (Root_Type (Typ))
+ or else Prim_Pos > CPP_Nb_Prims)
and then Find_Dispatching_Type
(Interface_Alias (Prim)) = Iface
-- Generate the code of the thunk only if the abstract
-- interface type is not an immediate ancestor of
- -- Tagged_Type; otherwise the DT associated with the
+ -- Tagged_Type. Otherwise the DT associated with the
-- interface is the primary DT.
and then not Is_Ancestor (Iface, Typ)
then
if not Build_Thunks then
- Pos :=
+ Prim_Pos :=
UI_To_Int (DT_Position (Interface_Alias (Prim)));
- Prim_Table (Pos) := Alias (Prim);
+ Prim_Table (Prim_Pos) := Alias (Prim);
+
else
Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
if Present (Thunk_Id) then
- Pos :=
+ Prim_Pos :=
UI_To_Int (DT_Position (Interface_Alias (Prim)));
- Prim_Table (Pos) := Thunk_Id;
+ Prim_Table (Prim_Pos) := Thunk_Id;
Append_To (Result, Thunk_Code);
end if;
end if;
@@ -4001,6 +4081,7 @@ package body Exp_Disp is
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim_Table (J), Loc),
Attribute_Name => Name_Unrestricted_Access));
+
else
New_Node := Make_Null (Loc);
end if;
@@ -4238,9 +4319,7 @@ package body Exp_Disp is
-- register the primitives in the slots will be generated later --- when
-- each primitive is frozen (see Freeze_Subprogram).
- if Building_Static_DT (Typ)
- and then not Is_CPP_Class (Typ)
- then
+ if Building_Static_DT (Typ) then
declare
Save : constant Boolean := Freezing_Library_Level_Tagged_Type;
Prim : Entity_Id;
@@ -4297,6 +4376,7 @@ package body Exp_Disp is
AI_Tag_Comp := First_Elmt (Typ_Comps);
while Present (AI_Tag_Comp) loop
+ pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'P'));
-- Build the secondary table containing pointers to thunks
@@ -4311,33 +4391,40 @@ package body Exp_Disp is
Build_Thunks => True,
Result => Result);
- -- Skip secondary dispatch table and secondary dispatch table of
- -- predefined primitives
+ -- Skip secondary dispatch table referencing thunks to predefined
+ -- primitives.
Next_Elmt (AI_Tag_Elmt);
+ pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Y'));
+
+ -- Secondary dispatch table referencing user-defined primitives
+ -- covered by this interface.
+
Next_Elmt (AI_Tag_Elmt);
+ pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'D'));
-- Build the secondary table containing pointers to primitives
-- (used to give support to Generic Dispatching Constructors).
Make_Secondary_DT
- (Typ => Typ,
- Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))),
- Suffix_Index => -1,
- Num_Iface_Prims => UI_To_Int
- (DT_Entry_Count (Node (AI_Tag_Comp))),
- Iface_DT_Ptr => Node (AI_Tag_Elmt),
- Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
- Build_Thunks => False,
- Result => Result);
+ (Typ => Typ,
+ Iface => Base_Type
+ (Related_Type (Node (AI_Tag_Comp))),
+ Suffix_Index => -1,
+ Num_Iface_Prims => UI_To_Int
+ (DT_Entry_Count (Node (AI_Tag_Comp))),
+ Iface_DT_Ptr => Node (AI_Tag_Elmt),
+ Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
+ Build_Thunks => False,
+ Result => Result);
- -- Skip secondary dispatch table and secondary dispatch table of
- -- predefined primitives
+ -- Skip secondary dispatch table referencing predefined primitives
Next_Elmt (AI_Tag_Elmt);
- Next_Elmt (AI_Tag_Elmt);
+ pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Z'));
Suffix_Index := Suffix_Index + 1;
+ Next_Elmt (AI_Tag_Elmt);
Next_Elmt (AI_Tag_Comp);
end loop;
end if;
@@ -4942,7 +5029,7 @@ package body Exp_Disp is
(Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
pragma Assert (Has_Thunks (Node (Elmt)));
- while Ekind (Node (Elmt)) = E_Constant
+ while Is_Tag (Node (Elmt))
and then not
Is_Ancestor (Node (AI), Related_Type (Node (Elmt)))
loop
@@ -5447,17 +5534,21 @@ package body Exp_Disp is
if Nb_Prim = 0 then
Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
- elsif not Building_Static_DT (Typ) then
+ elsif not Static_Dispatch_Tables
+ or else not Is_Library_Level_Tagged_Type (Typ)
+ then
for J in 1 .. Nb_Prim loop
Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
end loop;
else
declare
- Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
- E : Entity_Id;
- Prim : Entity_Id;
- Prim_Elmt : Elmt_Id;
+ CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
+ E : Entity_Id;
+ Prim : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+ Prim_Pos : Nat;
+ Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
begin
Prim_Table := (others => Empty);
@@ -5469,19 +5560,24 @@ package body Exp_Disp is
-- Retrieve the ultimate alias of the primitive for proper
-- handling of renamings and eliminated primitives.
- E := Ultimate_Alias (Prim);
+ E := Ultimate_Alias (Prim);
+ Prim_Pos := UI_To_Int (DT_Position (E));
-- Do not reference predefined primitives because they are
-- located in a separate dispatch table; skip entities with
-- attribute Interface_Alias because they are only required
- -- to build secondary dispatch tables; skip also abstract
- -- and eliminated primitives.
+ -- to build secondary dispatch tables; skip abstract and
+ -- eliminated primitives; for derivations of CPP types skip
+ -- primitives located in the C++ part of the dispatch table
+ -- because their slot is initialized by the IC routine.
if not Is_Predefined_Dispatching_Operation (Prim)
and then not Is_Predefined_Dispatching_Operation (E)
and then not Present (Interface_Alias (Prim))
and then not Is_Abstract_Subprogram (E)
and then not Is_Eliminated (E)
+ and then (not Is_CPP_Class (Root_Type (Typ))
+ or else Prim_Pos > CPP_Nb_Prims)
then
pragma Assert
(UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
@@ -5592,7 +5688,9 @@ package body Exp_Disp is
-- because the whole dispatch table (including inherited primitives) has
-- been already built.
- if Building_Static_DT (Typ) then
+ if Static_Dispatch_Tables
+ and then Is_Library_Level_Tagged_Type (Typ)
+ then
null;
-- If the ancestor is a CPP_Class type we inherit the dispatch tables
@@ -6190,234 +6288,296 @@ package body Exp_Disp is
-- Start of processing for Make_Tags
begin
- -- 1) Generate the primary and secondary tag entities
-
- -- Collect the components associated with secondary dispatch tables
-
- if Has_Interfaces (Typ) then
- Collect_Interface_Components (Typ, Typ_Comps);
- end if;
+ pragma Assert (No (Access_Disp_Table (Typ)));
+ Set_Access_Disp_Table (Typ, New_Elmt_List);
-- 1) Generate the primary tag entities
-- Primary dispatch table containing user-defined primitives
- DT_Ptr := Make_Defining_Identifier (Loc,
- New_External_Name (Tname, 'P'));
- Set_Etype (DT_Ptr, RTE (RE_Tag));
-
- -- Primary dispatch table containing predefined primitives
-
- Predef_Prims_Ptr :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Tname, 'Y'));
- Set_Etype (Predef_Prims_Ptr, RTE (RE_Address));
-
- -- Import the forward declaration of the Dispatch Table wrapper record
- -- (Make_DT will take care of its exportation)
+ DT_Ptr := Make_Defining_Identifier (Loc, New_External_Name (Tname, 'P'));
+ Set_Etype (DT_Ptr, RTE (RE_Tag));
+ Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
- if Building_Static_DT (Typ) then
- Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List);
+ -- Minimum decoration
- DT :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Tname, 'T'));
+ Set_Ekind (DT_Ptr, E_Variable);
+ Set_Related_Type (DT_Ptr, Typ);
- Import_DT (Typ, DT, Is_Secondary_DT => False);
+ -- For CPP types there is no need to build the dispatch tables since
+ -- they are imported from the C++ side. If the CPP type has an IP
+ -- then we declare now the variable that will store the copy of the
+ -- C++ tag.
- if Has_DT (Typ) then
+ if Is_CPP_Class (Typ) then
+ if Has_CPP_Constructors (Typ) then
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => DT_Ptr,
- Constant_Present => True,
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => New_Reference_To (DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Prims_Ptr), Loc)),
- Attribute_Name => Name_Address))));
+ New_Reference_To (RTE (RE_Null_Address), Loc))));
- -- Generate the SCIL node for the previous object declaration
- -- because it has a tag initialization.
+ Set_Is_Statically_Allocated (DT_Ptr,
+ Is_Library_Level_Tagged_Type (Typ));
+ end if;
- if Generate_SCIL then
- New_Node :=
- Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
- Set_SCIL_Entity (New_Node, Typ);
- Set_SCIL_Node (Last (Result), New_Node);
- end if;
+ -- Ada types
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Predef_Prims_Ptr,
- Constant_Present => True,
- Object_Definition => New_Reference_To
- (RTE (RE_Address), Loc),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => New_Reference_To (DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Predef_Prims), Loc)),
- Attribute_Name => Name_Address)));
+ else
+ -- Primary dispatch table containing predefined primitives
- -- No dispatch table required
+ Predef_Prims_Ptr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Tname, 'Y'));
+ Set_Etype (Predef_Prims_Ptr, RTE (RE_Address));
+ Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
- else
- Append_To (Result,
- Make_Object_Declaration (Loc,
- Defining_Identifier => DT_Ptr,
- Constant_Present => True,
- Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => New_Reference_To (DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
- Attribute_Name => Name_Address))));
- end if;
+ -- Import the forward declaration of the Dispatch Table wrapper
+ -- record (Make_DT will take care of its exportation)
- Set_Is_True_Constant (DT_Ptr);
- Set_Is_Statically_Allocated (DT_Ptr);
- end if;
+ if Building_Static_DT (Typ) then
+ Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List);
- pragma Assert (No (Access_Disp_Table (Typ)));
- Set_Access_Disp_Table (Typ, New_Elmt_List);
- Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
- Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
+ DT :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Tname, 'T'));
+
+ Import_DT (Typ, DT, Is_Secondary_DT => False);
+
+ if Has_DT (Typ) then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT_Ptr,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+ Attribute_Name => Name_Address))));
+
+ -- Generate the SCIL node for the previous object declaration
+ -- because it has a tag initialization.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
+ Set_SCIL_Entity (New_Node, Typ);
+ Set_SCIL_Node (Last (Result), New_Node);
+ end if;
+
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Predef_Prims_Ptr,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To
+ (RTE (RE_Address), Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Predef_Prims), Loc)),
+ Attribute_Name => Name_Address)));
+
+ -- No dispatch table required
+
+ else
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => DT_Ptr,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
+ Attribute_Name => Name_Address))));
+ end if;
+
+ Set_Is_True_Constant (DT_Ptr);
+ Set_Is_Statically_Allocated (DT_Ptr);
+ end if;
+ end if;
-- 2) Generate the secondary tag entities
+ -- Collect the components associated with secondary dispatch tables
+
if Has_Interfaces (Typ) then
+ Collect_Interface_Components (Typ, Typ_Comps);
- -- Note: The following value of Suffix_Index must be in sync with
- -- the Suffix_Index values of secondary dispatch tables generated
- -- by Make_DT.
+ -- For each interface type we build an unique external name
+ -- associated with its secondary dispatch table. This name is used to
+ -- declare an object that references this secondary dispatch table,
+ -- value that will be used for the elaboration of Typ's objects and
+ -- also for the elaboration of objects of derivations of Typ that do
+ -- not override the primitives of this interface type.
Suffix_Index := 1;
- -- For each interface type we build an unique external name
- -- associated with its corresponding secondary dispatch table.
- -- This external name will be used to declare an object that
- -- references this secondary dispatch table, value that will be
- -- used for the elaboration of Typ's objects and also for the
- -- elaboration of objects of derivations of Typ that do not
- -- override the primitive operation of this interface type.
-
- AI_Tag_Comp := First_Elmt (Typ_Comps);
- while Present (AI_Tag_Comp) loop
- Get_Secondary_DT_External_Name
- (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
- Typ_Name := Name_Find;
+ -- Note: The value of Suffix_Index must be in sync with the
+ -- Suffix_Index values of secondary dispatch tables generated
+ -- by Make_DT.
- if Building_Static_DT (Typ) then
- Iface_DT :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name
- (Typ_Name, 'T', Suffix_Index => -1));
- Import_DT
- (Tag_Typ => Related_Type (Node (AI_Tag_Comp)),
- DT => Iface_DT,
- Is_Secondary_DT => True);
- end if;
+ if Is_CPP_Class (Typ) then
+ AI_Tag_Comp := First_Elmt (Typ_Comps);
+ while Present (AI_Tag_Comp) loop
+ Get_Secondary_DT_External_Name
+ (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
+ Typ_Name := Name_Find;
- -- Secondary dispatch table referencing thunks to user-defined
- -- primitives covered by this interface.
+ -- Declare variables that will store the copy of the C++
+ -- secondary tags
- Iface_DT_Ptr :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Typ_Name, 'P'));
- Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
- Set_Ekind (Iface_DT_Ptr, E_Constant);
- Set_Is_Tag (Iface_DT_Ptr);
- Set_Has_Thunks (Iface_DT_Ptr);
- Set_Is_Statically_Allocated (Iface_DT_Ptr,
- Is_Library_Level_Tagged_Type (Typ));
- Set_Is_True_Constant (Iface_DT_Ptr);
- Set_Related_Type
- (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
- Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+ Iface_DT_Ptr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Typ_Name, 'P'));
+ Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
+ Set_Ekind (Iface_DT_Ptr, E_Variable);
+ Set_Is_Tag (Iface_DT_Ptr);
+
+ Set_Has_Thunks (Iface_DT_Ptr);
+ Set_Related_Type
+ (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+ Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
- if Building_Static_DT (Typ) then
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Iface_DT_Ptr,
- Constant_Present => True,
Object_Definition => New_Reference_To
(RTE (RE_Interface_Tag), Loc),
Expression =>
Unchecked_Convert_To (RTE (RE_Interface_Tag),
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => New_Reference_To (Iface_DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Prims_Ptr), Loc)),
- Attribute_Name => Name_Address))));
- end if;
+ New_Reference_To (RTE (RE_Null_Address), Loc))));
- -- Secondary dispatch table referencing thunks to predefined
- -- primitives.
+ Set_Is_Statically_Allocated (Iface_DT_Ptr,
+ Is_Library_Level_Tagged_Type (Typ));
- Iface_DT_Ptr :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Typ_Name, 'Y'));
- Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
- Set_Ekind (Iface_DT_Ptr, E_Constant);
- Set_Is_Tag (Iface_DT_Ptr);
- Set_Has_Thunks (Iface_DT_Ptr);
- Set_Is_Statically_Allocated (Iface_DT_Ptr,
- Is_Library_Level_Tagged_Type (Typ));
- Set_Is_True_Constant (Iface_DT_Ptr);
- Set_Related_Type
- (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
- Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+ Next_Elmt (AI_Tag_Comp);
+ end loop;
- -- Secondary dispatch table referencing user-defined primitives
- -- covered by this interface.
+ -- This is not a CPP_Class type
- Iface_DT_Ptr :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Typ_Name, 'D'));
- Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
- Set_Ekind (Iface_DT_Ptr, E_Constant);
- Set_Is_Tag (Iface_DT_Ptr);
- Set_Is_Statically_Allocated (Iface_DT_Ptr,
- Is_Library_Level_Tagged_Type (Typ));
- Set_Is_True_Constant (Iface_DT_Ptr);
- Set_Related_Type
- (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
- Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+ else
+ AI_Tag_Comp := First_Elmt (Typ_Comps);
+ while Present (AI_Tag_Comp) loop
+ Get_Secondary_DT_External_Name
+ (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
+ Typ_Name := Name_Find;
- -- Secondary dispatch table referencing predefined primitives
+ if Building_Static_DT (Typ) then
+ Iface_DT :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name
+ (Typ_Name, 'T', Suffix_Index => -1));
+ Import_DT
+ (Tag_Typ => Related_Type (Node (AI_Tag_Comp)),
+ DT => Iface_DT,
+ Is_Secondary_DT => True);
+ end if;
- Iface_DT_Ptr :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Typ_Name, 'Z'));
- Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
- Set_Ekind (Iface_DT_Ptr, E_Constant);
- Set_Is_Tag (Iface_DT_Ptr);
- Set_Is_Statically_Allocated (Iface_DT_Ptr,
- Is_Library_Level_Tagged_Type (Typ));
- Set_Is_True_Constant (Iface_DT_Ptr);
- Set_Related_Type
- (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
- Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+ -- Secondary dispatch table referencing thunks to user-defined
+ -- primitives covered by this interface.
- Next_Elmt (AI_Tag_Comp);
- end loop;
+ Iface_DT_Ptr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Typ_Name, 'P'));
+ Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
+ Set_Ekind (Iface_DT_Ptr, E_Constant);
+ Set_Is_Tag (Iface_DT_Ptr);
+ Set_Has_Thunks (Iface_DT_Ptr);
+ Set_Is_Statically_Allocated (Iface_DT_Ptr,
+ Is_Library_Level_Tagged_Type (Typ));
+ Set_Is_True_Constant (Iface_DT_Ptr);
+ Set_Related_Type
+ (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+ Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+
+ if Building_Static_DT (Typ) then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Iface_DT_Ptr,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To
+ (RTE (RE_Interface_Tag), Loc),
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Interface_Tag),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (Iface_DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+ Attribute_Name => Name_Address))));
+ end if;
+
+ -- Secondary dispatch table referencing thunks to predefined
+ -- primitives.
+
+ Iface_DT_Ptr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Typ_Name, 'Y'));
+ Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
+ Set_Ekind (Iface_DT_Ptr, E_Constant);
+ Set_Is_Tag (Iface_DT_Ptr);
+ Set_Has_Thunks (Iface_DT_Ptr);
+ Set_Is_Statically_Allocated (Iface_DT_Ptr,
+ Is_Library_Level_Tagged_Type (Typ));
+ Set_Is_True_Constant (Iface_DT_Ptr);
+ Set_Related_Type
+ (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+ Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+
+ -- Secondary dispatch table referencing user-defined primitives
+ -- covered by this interface.
+
+ Iface_DT_Ptr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Typ_Name, 'D'));
+ Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
+ Set_Ekind (Iface_DT_Ptr, E_Constant);
+ Set_Is_Tag (Iface_DT_Ptr);
+ Set_Is_Statically_Allocated (Iface_DT_Ptr,
+ Is_Library_Level_Tagged_Type (Typ));
+ Set_Is_True_Constant (Iface_DT_Ptr);
+ Set_Related_Type
+ (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+ Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+
+ -- Secondary dispatch table referencing predefined primitives
+
+ Iface_DT_Ptr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Typ_Name, 'Z'));
+ Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
+ Set_Ekind (Iface_DT_Ptr, E_Constant);
+ Set_Is_Tag (Iface_DT_Ptr);
+ Set_Is_Statically_Allocated (Iface_DT_Ptr,
+ Is_Library_Level_Tagged_Type (Typ));
+ Set_Is_True_Constant (Iface_DT_Ptr);
+ Set_Related_Type
+ (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+ Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+
+ Next_Elmt (AI_Tag_Comp);
+ end loop;
+ end if;
end if;
-- 3) At the end of Access_Disp_Table, if the type has user-defined
@@ -6479,6 +6639,13 @@ package body Exp_Disp is
Analyze_List (Result);
Set_Suppress_Init_Proc (Base_Type (DT_Prims));
+ -- Add the freezing nodes of these declarations; required to avoid
+ -- generating these freezing nodes in wrong scopes (for example in
+ -- the IC routine of a derivation of Typ).
+
+ Append_List_To (Result, Freeze_Entity (DT_Prims, Loc));
+ Append_List_To (Result, Freeze_Entity (DT_Prims_Acc, Loc));
+
-- Mark entity of dispatch table. Required by the back end to
-- handle them properly.
@@ -6499,7 +6666,12 @@ package body Exp_Disp is
Set_Is_Dispatch_Table_Entity (Etype (Iface_DT));
end if;
- Set_Ekind (DT_Ptr, E_Constant);
+ if Is_CPP_Class (Root_Type (Typ)) then
+ Set_Ekind (DT_Ptr, E_Variable);
+ else
+ Set_Ekind (DT_Ptr, E_Constant);
+ end if;
+
Set_Is_Tag (DT_Ptr);
Set_Related_Type (DT_Ptr, Typ);
@@ -6704,17 +6876,24 @@ package body Exp_Disp is
else
pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
- Append_To (L,
- Build_Set_Prim_Op_Address (Loc,
- Typ => Tag_Typ,
- Tag_Node => New_Reference_To (DT_Ptr, Loc),
- Position => Pos,
- Address_Node =>
- Unchecked_Convert_To (RTE (RE_Prim_Ptr),
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Prim, Loc),
- Attribute_Name => Name_Unrestricted_Access))));
+ -- Skip registration of primitives located in the C++ part of the
+ -- dispatch table. Their slot is set by the IC routine.
+
+ if not Is_CPP_Class (Root_Type (Tag_Typ))
+ or else Pos > CPP_Num_Prims (Tag_Typ)
+ then
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
+ Append_To (L,
+ Build_Set_Prim_Op_Address (Loc,
+ Typ => Tag_Typ,
+ Tag_Node => New_Reference_To (DT_Ptr, Loc),
+ Position => Pos,
+ Address_Node =>
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Prim, Loc),
+ Attribute_Name => Name_Unrestricted_Access))));
+ end if;
end if;
-- Ada 2005 (AI-251): Primitive associated with an interface type
@@ -6734,6 +6913,16 @@ package body Exp_Disp is
if Is_Ancestor (Iface_Typ, Tag_Typ) then
return L;
+
+ -- No action needed for primitives located in the C++ part of the
+ -- dispatch table. Their slot is set by the IC routine.
+
+ elsif Is_CPP_Class (Root_Type (Tag_Typ))
+ and then DT_Position (Alias (Prim)) <= CPP_Num_Prims (Tag_Typ)
+ and then not Is_Predefined_Dispatching_Operation (Prim)
+ and then not Is_Predefined_Dispatching_Alias (Prim)
+ then
+ return L;
end if;
Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
@@ -7327,14 +7516,115 @@ package body Exp_Disp is
--------------------------
procedure Set_CPP_Constructors (Typ : Entity_Id) is
+
+ procedure Set_CPP_Constructors_Old (Typ : Entity_Id);
+ -- For backward compatibility this routine handles CPP constructors
+ -- of non-tagged types.
+
+ procedure Set_CPP_Constructors_Old (Typ : Entity_Id) is
+ Loc : Source_Ptr;
+ Init : Entity_Id;
+ E : Entity_Id;
+ Found : Boolean := False;
+ P : Node_Id;
+ Parms : List_Id;
+
+ begin
+ -- Look for the constructor entities
+
+ E := Next_Entity (Typ);
+ while Present (E) loop
+ if Ekind (E) = E_Function
+ and then Is_Constructor (E)
+ then
+ -- Create the init procedure
+
+ Found := True;
+ Loc := Sloc (E);
+ Init := Make_Defining_Identifier (Loc,
+ Make_Init_Proc_Name (Typ));
+ Parms :=
+ New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_X),
+ Parameter_Type =>
+ New_Reference_To (Typ, Loc)));
+
+ if Present (Parameter_Specifications (Parent (E))) then
+ P := First (Parameter_Specifications (Parent (E)));
+ while Present (P) loop
+ Append_To (Parms,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars (Defining_Identifier (P))),
+ Parameter_Type =>
+ New_Copy_Tree (Parameter_Type (P))));
+ Next (P);
+ end loop;
+ end if;
+
+ Discard_Node (
+ Make_Subprogram_Declaration (Loc,
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Init,
+ Parameter_Specifications => Parms)));
+
+ Set_Init_Proc (Typ, Init);
+ Set_Is_Imported (Init);
+ Set_Interface_Name (Init, Interface_Name (E));
+ Set_Convention (Init, Convention_C);
+ Set_Is_Public (Init);
+ Set_Has_Completion (Init);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ -- If there are no constructors, mark the type as abstract since we
+ -- won't be able to declare objects of that type.
+
+ if not Found then
+ Set_Is_Abstract_Type (Typ);
+ end if;
+ end Set_CPP_Constructors_Old;
+
+ -- Local variables
+
Loc : Source_Ptr;
- Init : Entity_Id;
E : Entity_Id;
Found : Boolean := False;
P : Node_Id;
Parms : List_Id;
+ Constructor_Decl_Node : Node_Id;
+ Constructor_Id : Entity_Id;
+ Wrapper_Id : Entity_Id;
+ Wrapper_Body_Node : Node_Id;
+ Actuals : List_Id;
+ Body_Stmts : List_Id;
+ Init_Tags_List : List_Id;
+
begin
+ pragma Assert (Is_CPP_Class (Typ));
+
+ -- For backward compatibility the compiler accepts C++ classes
+ -- imported through non-tagged record types. In such case the
+ -- wrapper of the C++ constructor is useless because the _tag
+ -- component is not available.
+
+ -- Example:
+ -- type Root is limited record ...
+ -- pragma Import (CPP, Root);
+ -- function New_Root return Root;
+ -- pragma CPP_Constructor (New_Root, ... );
+
+ if not Is_Tagged_Type (Typ) then
+ Set_CPP_Constructors_Old (Typ);
+ return;
+ end if;
+
-- Look for the constructor entities
E := Next_Entity (Typ);
@@ -7342,16 +7632,16 @@ package body Exp_Disp is
if Ekind (E) = E_Function
and then Is_Constructor (E)
then
- -- Create the init procedure
-
Found := True;
Loc := Sloc (E);
- Init := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
+
+ -- Generate the declaration of the imported C++ constructor
+
Parms :=
New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_X),
+ Make_Defining_Identifier (Loc, Name_uInit),
Parameter_Type =>
New_Reference_To (Typ, Loc)));
@@ -7368,18 +7658,128 @@ package body Exp_Disp is
end loop;
end if;
- Discard_Node (
+ Constructor_Id := Make_Temporary (Loc, 'P');
+
+ Constructor_Decl_Node :=
Make_Subprogram_Declaration (Loc,
Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Init,
- Parameter_Specifications => Parms)));
+ Defining_Unit_Name => Constructor_Id,
+ Parameter_Specifications => Parms));
- Set_Init_Proc (Typ, Init);
- Set_Is_Imported (Init);
- Set_Interface_Name (Init, Interface_Name (E));
- Set_Convention (Init, Convention_C);
- Set_Is_Public (Init);
- Set_Has_Completion (Init);
+ Set_Is_Imported (Constructor_Id);
+ Set_Interface_Name (Constructor_Id, Interface_Name (E));
+ Set_Convention (Constructor_Id, Convention_C);
+ Set_Is_Public (Constructor_Id);
+ Set_Has_Completion (Constructor_Id);
+
+ -- Build the wrapper of this constructor
+
+ Parms :=
+ New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uInit),
+ Parameter_Type =>
+ New_Reference_To (Typ, Loc)));
+
+ if Present (Parameter_Specifications (Parent (E))) then
+ P := First (Parameter_Specifications (Parent (E)));
+ while Present (P) loop
+ Append_To (Parms,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars (Defining_Identifier (P))),
+ Parameter_Type => New_Copy_Tree (Parameter_Type (P))));
+ Next (P);
+ end loop;
+ end if;
+
+ Body_Stmts := New_List;
+
+ -- Invoke the C++ constructor
+
+ Actuals := New_List;
+
+ P := First (Parms);
+ while Present (P) loop
+ Append_To (Actuals,
+ New_Reference_To (Defining_Identifier (P), Loc));
+ Next (P);
+ end loop;
+
+ Append_To (Body_Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (Constructor_Id, Loc),
+ Parameter_Associations => Actuals));
+
+ -- Initialize copies of C++ primary and secondary tags
+
+ Init_Tags_List := New_List;
+
+ declare
+ Tag_Elmt : Elmt_Id;
+ Tag_Comp : Node_Id;
+
+ begin
+ Tag_Elmt := First_Elmt (Access_Disp_Table (Typ));
+ Tag_Comp := First_Tag_Component (Typ);
+
+ while Present (Tag_Elmt)
+ and then Is_Tag (Node (Tag_Elmt))
+ loop
+ -- Skip the following assertion with primary tags because
+ -- Related_Type is not set on primary tag components
+
+ pragma Assert (Tag_Comp = First_Tag_Component (Typ)
+ or else Related_Type (Node (Tag_Elmt))
+ = Related_Type (Tag_Comp));
+
+ Append_To (Init_Tags_List,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Reference_To (Node (Tag_Elmt), Loc),
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name =>
+ New_Reference_To (Tag_Comp, Loc))));
+
+ Tag_Comp := Next_Tag_Component (Tag_Comp);
+ Next_Elmt (Tag_Elmt);
+ end loop;
+ end;
+
+ Append_To (Body_Stmts,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Typ))),
+ Loc),
+ Right_Opnd =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (RTE (RE_Null_Address), Loc))),
+ Then_Statements => Init_Tags_List));
+
+ Wrapper_Id := Make_Defining_Identifier (Loc,
+ Make_Init_Proc_Name (Typ));
+
+ Wrapper_Body_Node :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Wrapper_Id,
+ Parameter_Specifications => Parms),
+ Declarations => New_List (Constructor_Decl_Node),
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Body_Stmts,
+ Exception_Handlers => No_List));
+
+ Discard_Node (Wrapper_Body_Node);
+ Set_Init_Proc (Typ, Wrapper_Id);
end if;
Next_Entity (E);
@@ -7391,6 +7791,17 @@ package body Exp_Disp is
if not Found then
Set_Is_Abstract_Type (Typ);
end if;
+
+ -- If the CPP type has constructors then it must import also the default
+ -- C++ constructor. It is required for default initialization of objects
+ -- of the type. It is also required to elaborate objects of Ada types
+ -- that are defined as derivations of this CPP type.
+
+ if Has_CPP_Constructors (Typ)
+ and then No (Init_Proc (Typ))
+ then
+ Error_Msg_N ("?default constructor must be imported from C++", Typ);
+ end if;
end Set_CPP_Constructors;
--------------------------
@@ -7586,6 +7997,12 @@ package body Exp_Disp is
Write_Str (" (eliminated)");
end if;
+ if Is_Imported (Prim)
+ and then Convention (Prim) = Convention_CPP
+ then
+ Write_Str (" (C++)");
+ end if;
+
Write_Eol;
Next_Elmt (Elmt);
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2010, 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- --
@@ -186,6 +186,10 @@ package Exp_Disp is
-- bodies they are added to the end of the list of declarations of the
-- package body.
+ function CPP_Num_Prims (Typ : Entity_Id) return Nat;
+ -- Return the number of primitives of the C++ part of the dispatch table.
+ -- For types that are not derivations of CPP types return 0.
+
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 tag checks are
@@ -215,6 +219,9 @@ package Exp_Disp is
-- Otherwise they are set to the defining identifier and the subprogram
-- body of the generated thunk.
+ function Has_CPP_Constructors (Typ : Entity_Id) return Boolean;
+ -- Returns true if the type has CPP constructors
+
function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean;
-- Ada 2005 (AI-251): Determines if E is a predefined primitive operation
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2010, 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- --
@@ -109,6 +109,35 @@ package body Exp_Tss is
Prepend_Elmt (TSS, TSS_Elist (FN));
end Copy_TSS;
+ -------------------
+ -- CPP_Init_Proc --
+ -------------------
+
+ function CPP_Init_Proc (Typ : Entity_Id) return Entity_Id is
+ FN : constant Node_Id := Freeze_Node (Typ);
+ Elmt : Elmt_Id;
+
+ begin
+ if not Is_CPP_Class (Root_Type (Typ))
+ or else No (FN)
+ or else No (TSS_Elist (FN))
+ then
+ return Empty;
+
+ else
+ Elmt := First_Elmt (TSS_Elist (FN));
+ while Present (Elmt) loop
+ if Is_CPP_Init_Proc (Node (Elmt)) then
+ return Node (Elmt);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+
+ return Empty;
+ end CPP_Init_Proc;
+
------------------------
-- Find_Inherited_TSS --
------------------------
@@ -276,6 +305,18 @@ package body Exp_Tss is
return Empty;
end Init_Proc;
+ ----------------------
+ -- Is_CPP_Init_Proc --
+ ----------------------
+
+ function Is_CPP_Init_Proc (E : Entity_Id) return Boolean is
+ C1 : Character;
+ C2 : Character;
+ begin
+ Get_Last_Two_Chars (Chars (E), C1, C2);
+ return C1 = TSS_CPP_Init_Proc (1) and then C2 = TSS_CPP_Init_Proc (2);
+ end Is_CPP_Init_Proc;
+
------------------
-- Is_Init_Proc --
------------------
@@ -393,7 +434,7 @@ package body Exp_Tss is
-- Skip this for Init_Proc with No_Default_Initialization, since the
-- Init proc is a dummy void entity in this case to be ignored.
- if Is_Init_Proc (TSS)
+ if (Is_Init_Proc (TSS) or else Is_CPP_Init_Proc (TSS))
and then Restriction_Active (No_Default_Initialization)
then
null;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2010, 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- --
@@ -84,6 +84,7 @@ package Exp_Tss is
TSS_Composite_Equality : constant TNT := "EQ"; -- Composite Equality
TSS_From_Any : constant TNT := "FA"; -- PolyORB/DSA From_Any
TSS_Init_Proc : constant TNT := "IP"; -- Initialization Procedure
+ TSS_CPP_Init_Proc : constant TNT := "IC"; -- Init C++ dispatch tables
TSS_RAS_Access : constant TNT := "RA"; -- RAS type access
TSS_RAS_Dereference : constant TNT := "RD"; -- RAS type dereference
TSS_Rep_To_Pos : constant TNT := "RP"; -- Rep to Pos conversion
@@ -104,6 +105,7 @@ package Exp_Tss is
TSS_Composite_Equality,
TSS_From_Any,
TSS_Init_Proc,
+ TSS_CPP_Init_Proc,
TSS_RAS_Access,
TSS_RAS_Dereference,
TSS_Rep_To_Pos,
@@ -140,15 +142,18 @@ package Exp_Tss is
function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id;
-- Version for init procs, same as Make_TSS_Name (Typ, TSS_Init_Proc)
+ function Is_CPP_Init_Proc (E : Entity_Id) return Boolean;
+ -- Version for CPP init procs, same as Is_TSS (E, TSS_CPP_Init_Proc);
+
+ function Is_Init_Proc (E : Entity_Id) return Boolean;
+ -- Version for init procs, same as Is_TSS (E, TSS_Init_Proc);
+
function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean;
-- Determines if given entity (E) is the name of a TSS identified by Nam
function Is_TSS (N : Name_Id; Nam : TSS_Name_Type) return Boolean;
-- Same test applied directly to a Name_Id value
- function Is_Init_Proc (E : Entity_Id) return Boolean;
- -- Version for init procs, same as Is_TSS (E, TSS_Init_Proc);
-
-----------------------------------------
-- TSS Data structures and Subprograms --
-----------------------------------------
@@ -188,6 +193,11 @@ package Exp_Tss is
-- used to initially install a TSS in the case where the subprogram for the
-- TSS has already been created and its declaration processed.
+ function CPP_Init_Proc (Typ : Entity_Id) return Entity_Id;
+ -- Obtains the CPP_Init TSS entity the given type. The CPP_Init TSS is a
+ -- procedure used to initialize the C++ part of the primary and secondary
+ -- dispatch tables of a tagged type derived from CPP types.
+
function Init_Proc
(Typ : Entity_Id;
Ref : Entity_Id := Empty) return Entity_Id;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2010, 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- --
@@ -175,7 +175,7 @@ package Freeze is
-- do not allow a size clause if the size would not otherwise be known at
-- compile time in any case.
- function Is_Atomic_Aggregate
+ function Is_Atomic_Aggregate
(E : Entity_Id;
Typ : Entity_Id) return Boolean;
===================================================================
@@ -2417,6 +2417,36 @@ package body Sem_Aggr is
Error_Msg_N
("type of limited ancestor part must be constrained", A);
+ -- Reject the use of CPP constructors that leave objects partially
+ -- initialized. For example:
+
+ -- type CPP_Root is tagged limited record ...
+ -- pragma Import (CPP, CPP_Root);
+
+ -- type CPP_DT is new CPP_Root and Iface ...
+ -- pragma Import (CPP, CPP_DT);
+
+ -- type Ada_DT is new CPP_DT with ...
+
+ -- Obj : Ada_DT := Ada_DT'(New_CPP_Root with others => <>);
+
+ -- Using the constructor of CPP_Root the slots of the dispatch
+ -- table of CPP_DT cannot be set, and the secondary tag of
+ -- CPP_DT is unknown.
+
+ elsif Nkind (A) = N_Function_Call
+ and then Is_CPP_Constructor_Call (A)
+ and then Enclosing_CPP_Parent (Typ) /= A_Type
+ then
+ Error_Msg_NE
+ ("?must use 'C'P'P constructor for type &", A,
+ Enclosing_CPP_Parent (Typ));
+
+ -- The following call is not needed if the previous warning
+ -- is promoted to an error.
+
+ Resolve_Record_Aggregate (N, Typ);
+
elsif Is_Class_Wide_Type (Etype (A))
and then Nkind (Original_Node (A)) = N_Function_Call
then
===================================================================
@@ -697,6 +697,12 @@ package body Sem_Attr is
("current instance attribute must appear alone", N);
end if;
+ if Is_CPP_Class (Root_Type (Typ)) then
+ Error_Msg_N
+ ("?current instance unsupported for derivations of "
+ & "'C'P'P types", N);
+ end if;
+
-- OK if we are in initialization procedure for the type
-- in question, in which case the reference to the type
-- is rewritten as a reference to the current object.
===================================================================
@@ -26,7 +26,9 @@
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
+with Elists; use Elists;
with Errout; use Errout;
+with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Lib; use Lib;
@@ -2385,6 +2387,70 @@ package body Sem_Ch13 is
Add_Internal_Interface_Entities (E);
end if;
+
+ -- Check CPP types
+
+ if Ekind (E) = E_Record_Type
+ and then Is_CPP_Class (E)
+ and then Is_Tagged_Type (E)
+ and then Tagged_Type_Expansion
+ and then Expander_Active
+ then
+ if CPP_Num_Prims (E) = 0 then
+
+ -- If the CPP type has user defined components then it must import
+ -- primitives from C++. This is required because if the C++ class
+ -- has no primitives then the C++ compiler does not added the _tag
+ -- component to the type.
+
+ pragma Assert (Chars (First_Entity (E)) = Name_uTag);
+
+ if First_Entity (E) /= Last_Entity (E) then
+ Error_Msg_N
+ ("?'C'P'P type must import at least one primitive from C++",
+ E);
+ end if;
+ end if;
+
+ -- Check that all its primitives are abstract or imported from C++.
+ -- Check also availability of the C++ constructor.
+
+ declare
+ Has_Constructors : constant Boolean := Has_CPP_Constructors (E);
+ Elmt : Elmt_Id;
+ Error_Reported : Boolean := False;
+ Prim : Node_Id;
+
+ begin
+ Elmt := First_Elmt (Primitive_Operations (E));
+ while Present (Elmt) loop
+ Prim := Node (Elmt);
+
+ if Comes_From_Source (Prim) then
+ if Is_Abstract_Subprogram (Prim) then
+ null;
+
+ elsif not Is_Imported (Prim)
+ or else Convention (Prim) /= Convention_CPP
+ then
+ Error_Msg_N
+ ("?primitives of 'C'P'P types must be imported from C++"
+ & " or abstract", Prim);
+
+ elsif not Has_Constructors
+ and then not Error_Reported
+ then
+ Error_Msg_Name_1 := Chars (E);
+ Error_Msg_N
+ ("?'C'P'P constructor required for type %", Prim);
+ Error_Reported := True;
+ end if;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end;
+ end if;
end Analyze_Freeze_Entity;
------------------------------------------
===================================================================
@@ -513,6 +513,7 @@ package body Sem_Ch8 is
procedure Write_Scopes;
pragma Warnings (Off, Write_Scopes);
+ pragma Export (Ada, Write_Scopes);
-- Debugging information: dump all entities on scope stack
--------------------------------
===================================================================
@@ -6554,6 +6554,14 @@ package body Sem_Prag is
Def_Id := Entity (Id);
+ -- Check if already defined as constructor
+
+ if Is_Constructor (Def_Id) then
+ Error_Msg_N
+ ("?duplicate argument for pragma 'C'P'P_Constructor", Arg1);
+ return;
+ end if;
+
if Ekind (Def_Id) = E_Function
and then (Is_CPP_Class (Etype (Def_Id))
or else (Is_Class_Wide_Type (Etype (Def_Id))
===================================================================
@@ -1564,22 +1564,48 @@ package body Sem_Util is
function Search_Tag (Iface : Entity_Id) return Entity_Id is
ADT : Elmt_Id;
-
begin
- ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
+ if not Is_CPP_Class (T) then
+ ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
+ else
+ ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
+ end if;
+
while Present (ADT)
- and then Ekind (Node (ADT)) = E_Constant
+ and then Is_Tag (Node (ADT))
and then Related_Type (Node (ADT)) /= Iface
loop
- -- Skip the secondary dispatch tables of Iface
+ -- Skip secondary dispatch table referencing thunks to user
+ -- defined primitives covered by this interface.
+ pragma Assert (Has_Suffix (Node (ADT), 'P'));
Next_Elmt (ADT);
- Next_Elmt (ADT);
- Next_Elmt (ADT);
- Next_Elmt (ADT);
+
+ -- Skip secondary dispatch tables of Ada types
+
+ if not Is_CPP_Class (T) then
+
+ -- Skip secondary dispatch table referencing thunks to
+ -- predefined primitives.
+
+ pragma Assert (Has_Suffix (Node (ADT), 'Y'));
+ Next_Elmt (ADT);
+
+ -- Skip secondary dispatch table referencing user-defined
+ -- primitives covered by this interface.
+
+ pragma Assert (Has_Suffix (Node (ADT), 'D'));
+ Next_Elmt (ADT);
+
+ -- Skip secondary dispatch table referencing predefined
+ -- primitives
+
+ pragma Assert (Has_Suffix (Node (ADT), 'Z'));
+ Next_Elmt (ADT);
+ end if;
end loop;
- pragma Assert (Ekind (Node (ADT)) = E_Constant);
+ pragma Assert (Is_Tag (Node (ADT)));
return Node (ADT);
end Search_Tag;
@@ -2499,6 +2525,28 @@ package body Sem_Util is
end if;
end Designate_Same_Unit;
+ --------------------------
+ -- Enclosing_CPP_Parent --
+ --------------------------
+
+ function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is
+ Parent_Typ : Entity_Id := Typ;
+
+ begin
+ while not Is_CPP_Class (Parent_Typ)
+ and then Etype (Parent_Typ) /= Parent_Typ
+ loop
+ Parent_Typ := Etype (Parent_Typ);
+
+ if Is_Private_Type (Parent_Typ) then
+ Parent_Typ := Full_View (Base_Type (Parent_Typ));
+ end if;
+ end loop;
+
+ pragma Assert (Is_CPP_Class (Parent_Typ));
+ return Parent_Typ;
+ end Enclosing_CPP_Parent;
+
----------------------------
-- Enclosing_Generic_Body --
----------------------------
@@ -5208,6 +5256,16 @@ package body Sem_Util is
end if;
end Has_Stream;
+ ----------------
+ -- Has_Suffix --
+ ----------------
+
+ function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
+ begin
+ Get_Name_String (Chars (E));
+ return Name_Buffer (Name_Len) = Suffix;
+ end Has_Suffix;
+
--------------------------
-- Has_Tagged_Component --
--------------------------
===================================================================
@@ -279,6 +279,9 @@ package Sem_Util is
-- these names is supposed to be a selected component name, an expanded
-- name, a defining program unit name or an identifier.
+ function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id;
+ -- Returns the closest ancestor of Typ that is a CPP type.
+
function Enclosing_Generic_Body
(N : Node_Id) return Node_Id;
-- Returns the Node_Id associated with the innermost enclosing generic
@@ -578,6 +581,9 @@ package Sem_Util is
-- applied to the underlying type (or returns False if there is no
-- underlying type).
+ function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean;
+ -- Returns true if the last character of E is Suffix. Used in Assertions.
+
function Has_Tagged_Component (Typ : Entity_Id) return Boolean;
-- Returns True if Typ is a composite type (array or record) which is
-- either itself a tagged type, or has a component (recursively) which is
===================================================================
@@ -1765,11 +1765,11 @@ ada/exp_ch11.o : ada/ada.ads ada/a-excep
ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \
ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \
ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \
- ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \
- ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
- ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \
- ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
+ ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \
+ ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \
+ ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads
ada/exp_ch12.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
@@ -1845,13 +1845,13 @@ ada/exp_ch3.o : ada/ada.ads ada/a-except
ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \
ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \
ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \
- ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \
- ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \
- ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
- ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads ada/validsw.ads
+ ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
+ ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
+ ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
ada/exp_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
@@ -1973,12 +1973,13 @@ ada/exp_ch7.o : ada/ada.ads ada/a-except
ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \
ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \
ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \
- ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \
- ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
- ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \
- ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
+ ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \
+ ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \
+ ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
+ ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads ada/validsw.ads
ada/exp_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
@@ -2249,11 +2250,11 @@ ada/exp_prag.o : ada/ada.ads ada/a-excep
ada/sinput.adb ada/snames.ads ada/snames.adb ada/stand.ads \
ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \
ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \
- ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \
- ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \
- ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
+ ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
+ ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads
ada/exp_sel.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
@@ -2476,13 +2477,13 @@ ada/frontend.o : ada/ada.ads ada/a-excep
ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \
ada/system.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \
ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \
- ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \
- ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
- ada/tbuild.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
- ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads ada/widechar.ads
+ ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
+ ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/types.ads \
+ ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads ada/widechar.ads
ada/g-byorma.o : ada/gnat.ads ada/g-byorma.ads ada/g-byorma.adb \
ada/system.ads
@@ -2996,18 +2997,19 @@ ada/restrict.o : ada/ada.ads ada/a-excep
ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \
ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \
ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \
- ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \
- ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \
- ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \
- ada/rident.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
- ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \
- ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \
- ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
- ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads
+ ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \
+ ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/namet.adb \
+ ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \
+ ada/restrict.ads ada/restrict.adb ada/rident.ads ada/sinfo.ads \
+ ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \
+ ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \
+ ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
+ ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads ada/widechar.ads
ada/rident.o : ada/rident.ads ada/system.ads ada/s-rident.ads
@@ -3302,33 +3304,33 @@ ada/sem_attr.o : ada/ada.ads ada/a-chara
ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads ada/exp_ch6.ads \
ada/exp_ch7.ads ada/exp_disp.ads ada/exp_dist.ads ada/exp_pakd.ads \
ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/expander.ads \
- ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
- ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \
- ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib-xref.ads \
- ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \
- ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
- ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \
- ada/scng.adb ada/sdefault.ads ada/sem.ads ada/sem_aggr.ads \
- ada/sem_attr.ads ada/sem_attr.adb ada/sem_aux.ads ada/sem_aux.adb \
- ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch13.ads ada/sem_ch3.ads \
- ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \
- ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \
- ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb \
- ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \
- ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \
- ada/snames.ads ada/snames.adb ada/sprint.ads ada/stand.ads \
- ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \
- ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \
- ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \
- ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \
- ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \
- ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
- ada/tbuild.adb ada/tree_io.ads ada/ttypef.ads ada/ttypes.ads \
- ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \
- ada/validsw.ads ada/widechar.ads
+ ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \
+ ada/gnat.ads ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/inline.ads ada/interfac.ads ada/itypes.ads ada/lib.ads \
+ ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \
+ ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \
+ ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \
+ ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sdefault.ads \
+ ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads ada/sem_attr.adb \
+ ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch10.ads \
+ ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads \
+ ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \
+ ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads \
+ ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \
+ ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \
+ ada/sinput.ads ada/sinput.adb ada/snames.ads ada/snames.adb \
+ ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \
+ ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \
+ ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads \
+ ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \
+ ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \
+ ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \
+ ada/ttypef.ads ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads \
+ ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads ada/urealp.adb ada/validsw.ads ada/widechar.ads
ada/sem_aux.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
@@ -3399,23 +3401,24 @@ ada/sem_ch10.o : ada/ada.ads ada/a-excep
ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \
ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
ada/opt.ads ada/output.ads ada/par_sco.ads ada/restrict.ads \
- ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \
- ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \
- ada/sem_ch10.ads ada/sem_ch10.adb ada/sem_ch3.ads ada/sem_ch6.ads \
- ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \
- ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads \
- ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \
- ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb \
- ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \
- ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \
- ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \
- ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \
- ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \
- ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \
- ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads
+ ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \
+ ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \
+ ada/sem_aux.ads ada/sem_ch10.ads ada/sem_ch10.adb ada/sem_ch3.ads \
+ ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \
+ ada/sem_dist.ads ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads \
+ ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \
+ ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \
+ ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \
+ ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \
+ ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \
+ ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \
+ ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \
+ ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
+ ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
+ ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads ada/widechar.ads
ada/sem_ch11.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \