diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2010-08-10 14:29:36 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2010-08-10 14:29:36 +0000 |
| commit | d00681a7ca5e51b8628582c7b041400ecc7e38db (patch) | |
| tree | c31c3b8d10a4d714d2f074e0150cd4419e5b882a /gcc/ada | |
| parent | f4d02eb01a952d8a397c8b022d4b125f7e906376 (diff) | |
| download | gcc-d00681a7ca5e51b8628582c7b041400ecc7e38db.tar.gz | |
2010-08-10 Javier Miranda <miranda@adacore.com>
* sem_aggr.adb (Resolve_Extension_Aggregate): Warn on the use of C++
constructors that leave the object partially initialized.
* exp_atag.ads, exp_atags.adb (Build_Inherit_CPP_Prims): New subprogram
that copies from parent of Typ the dispatch table slots of inherited
C++ primitives. It handles primary and secondary dispatch tables.
* einfo.adb (Related_Type): Moved from Node26 to Node27. Required to
use this attribute with E_Variable entities.
(Set_Is_Tag): Relax assertion to allow its use with variables that
store tags.
(Set_Related_Type): Relax assertion to allow its use with variables
that store the tag of a C++ class.
(Write_26_Field_Name): Remove Related_Type.
(Write_27_Field_Name): Add Related_Type.
* einfo.ads (Related_Type): Moved from Node26 to Node27. Available also
with E_Variable entities.
* sem_prag.adb (CPP_Constructor): Warn on duplicated occurrence of this
pragma.
* sem_util.adb (Search_Tag): Add missing support for CPP types.
(Enclosing_CPP_Parent): New subprogram.
(Has_Suffix): New subprogram.
* sem_util.ads (Enclosing_CPP_Parent): New subprogram that returns the
closest ancestor of a type that is a C++ type.
(Has_Suffix): New subprogram. Used in assertions to check the suffix of
internal entities.
* sem_attr.adb (Analyze_Access_Attribute): Check wrong use of current
instance in derivations of C++ types.
* exp_tss.adb (CPP_Init_Proc): New subprogram.
(Is_CPP_Init_Proc): New subprogram.
(Set_TSS): Handle new C++ init routines.
* exp_tss.ads (TSS_CPP_Init): New TSS name. For initialization of C++
dispatch tables.
(CPP_Init_Proc): New subprogram.
(Is_CPP_Init_Proc): New subprogram.
* exp_disp.adb (CPP_Num_Prims): New subprogram.
(Has_CPP_Constructors): New subprogram.
(Make_Secondary_DT, Make_DT): For derivations of CPP types, do not
initialize slots located in the C++ part of the dispatch table.
(Make_Tags): For CPP types declare variables used by the IP routine to
store the C++ tag values after the first invocation of the C++
constructor.
(Build_CPP_Init_DT): New subprogram.
(Set_CPP_Constructors): New implementation that builds an IP for each
CPP constructor. These IP are wrappers of the C++ constructors that,
after the first invocation of the constructor, read the C++ tags from
the object and save them locally. These copies of the C++ tags are used
by the IC routines to initialize tables of Ada derivations of CPP types.
(Write_DT): Indicate what primitives are imported from C++
* exp_disp.ads (CPP_Num_Prims): New subprogram.
(Has_CPP_Constructors): New subprogram.
* exp_aggr.adb (Build_Record_Aggr_Code): For derivations of C++ types
invoke the IC routine to inherit the slots of the parents.
* sem_ch13.adb (Analyze_Freeze_Entity): Add new warnings on CPP types.
* exp_ch3.adb (Is_Variable_Size_Array): New subprogram.
(Is_Variable_Size_Record): Factorize code calling
Is_Variable_Size_Array.
(Build_CPP_Init_Procedure): New subprogram that builds the tree
corresponding to the procedure that initializes the C++ part of the
dispatch table of an Ada tagged type that is a derivation of a CPP type.
(Build_Init_Procedure): Adding documentation plus code reorganization to
leave more clear the construction of the IP with C++ types.
(Expand_Freeze_Record_Type): Delay call to Set_CPP_Constructors because
it cannot be called after Make_Tags has been invoked.
(Inherit_CPP_Tag): Removed.
(Init_Secondary_Tags): For derivations of CPP types, warn on tags
located at variable offset.
* freeze.ads: Minor reformating.
* sem_ch8.adb (Write_Scopes): Add pragma export. Required to have it
available in gdb.
* gcc-interface/Make-lang.in: Update dependencies.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@163065 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 72 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 25 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 13 | ||||
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 62 | ||||
| -rw-r--r-- | gcc/ada/exp_atag.adb | 256 | ||||
| -rw-r--r-- | gcc/ada/exp_atag.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 532 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 913 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.ads | 9 | ||||
| -rw-r--r-- | gcc/ada/exp_tss.adb | 45 | ||||
| -rw-r--r-- | gcc/ada/exp_tss.ads | 18 | ||||
| -rw-r--r-- | gcc/ada/freeze.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/Make-lang.in | 175 | ||||
| -rw-r--r-- | gcc/ada/sem_aggr.adb | 30 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 66 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 74 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 6 |
20 files changed, 1764 insertions, 558 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0b379f6c3ec..56fdcb682e3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,75 @@ +2010-08-10 Javier Miranda <miranda@adacore.com> + + * sem_aggr.adb (Resolve_Extension_Aggregate): Warn on the use of C++ + constructors that leave the object partially initialized. + * exp_atag.ads, exp_atags.adb (Build_Inherit_CPP_Prims): New subprogram + that copies from parent of Typ the dispatch table slots of inherited + C++ primitives. It handles primary and secondary dispatch tables. + * einfo.adb (Related_Type): Moved from Node26 to Node27. Required to + use this attribute with E_Variable entities. + (Set_Is_Tag): Relax assertion to allow its use with variables that + store tags. + (Set_Related_Type): Relax assertion to allow its use with variables + that store the tag of a C++ class. + (Write_26_Field_Name): Remove Related_Type. + (Write_27_Field_Name): Add Related_Type. + * einfo.ads (Related_Type): Moved from Node26 to Node27. Available also + with E_Variable entities. + * sem_prag.adb (CPP_Constructor): Warn on duplicated occurrence of this + pragma. + * sem_util.adb (Search_Tag): Add missing support for CPP types. + (Enclosing_CPP_Parent): New subprogram. + (Has_Suffix): New subprogram. + * sem_util.ads (Enclosing_CPP_Parent): New subprogram that returns the + closest ancestor of a type that is a C++ type. + (Has_Suffix): New subprogram. Used in assertions to check the suffix of + internal entities. + * sem_attr.adb (Analyze_Access_Attribute): Check wrong use of current + instance in derivations of C++ types. + * exp_tss.adb (CPP_Init_Proc): New subprogram. + (Is_CPP_Init_Proc): New subprogram. + (Set_TSS): Handle new C++ init routines. + * exp_tss.ads (TSS_CPP_Init): New TSS name. For initialization of C++ + dispatch tables. + (CPP_Init_Proc): New subprogram. + (Is_CPP_Init_Proc): New subprogram. + * exp_disp.adb (CPP_Num_Prims): New subprogram. + (Has_CPP_Constructors): New subprogram. + (Make_Secondary_DT, Make_DT): For derivations of CPP types, do not + initialize slots located in the C++ part of the dispatch table. + (Make_Tags): For CPP types declare variables used by the IP routine to + store the C++ tag values after the first invocation of the C++ + constructor. + (Build_CPP_Init_DT): New subprogram. + (Set_CPP_Constructors): New implementation that builds an IP for each + CPP constructor. These IP are wrappers of the C++ constructors that, + after the first invocation of the constructor, read the C++ tags from + the object and save them locally. These copies of the C++ tags are used + by the IC routines to initialize tables of Ada derivations of CPP types. + (Write_DT): Indicate what primitives are imported from C++ + * exp_disp.ads (CPP_Num_Prims): New subprogram. + (Has_CPP_Constructors): New subprogram. + * exp_aggr.adb (Build_Record_Aggr_Code): For derivations of C++ types + invoke the IC routine to inherit the slots of the parents. + * sem_ch13.adb (Analyze_Freeze_Entity): Add new warnings on CPP types. + * exp_ch3.adb (Is_Variable_Size_Array): New subprogram. + (Is_Variable_Size_Record): Factorize code calling + Is_Variable_Size_Array. + (Build_CPP_Init_Procedure): New subprogram that builds the tree + corresponding to the procedure that initializes the C++ part of the + dispatch table of an Ada tagged type that is a derivation of a CPP type. + (Build_Init_Procedure): Adding documentation plus code reorganization to + leave more clear the construction of the IP with C++ types. + (Expand_Freeze_Record_Type): Delay call to Set_CPP_Constructors because + it cannot be called after Make_Tags has been invoked. + (Inherit_CPP_Tag): Removed. + (Init_Secondary_Tags): For derivations of CPP types, warn on tags + located at variable offset. + * freeze.ads: Minor reformating. + * sem_ch8.adb (Write_Scopes): Add pragma export. Required to have it + available in gdb. + * gcc-interface/Make-lang.in: Update dependencies. + 2010-08-10 Robert Dewar <dewar@adacore.com> * a-chahan.ads: Add comments on handling of obsolescent entries. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 2186428b122..4a9e3173075 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index b1cf28c91c5..de742cd46d4 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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 (Node26) --- Present in components and constants associated with dispatch tables. --- Set to point to the entity of the associated tagged type or interface --- type. +-- 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) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 36045190d53..e2bd125399f 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -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 diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb index 23a9202c372..a3270c84a6e 100644 --- a/gcc/ada/exp_atag.adb +++ b/gcc/ada/exp_atag.adb @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- +-- 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 -- ------------------------- diff --git a/gcc/ada/exp_atag.ads b/gcc/ada/exp_atag.ads index 1fa243cf91f..384a2d0baa3 100644 --- a/gcc/ada/exp_atag.ads +++ b/gcc/ada/exp_atag.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- +-- 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; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index e2263f3ab8f..1bfa9f2de67 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -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. + -- 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) - -- 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. + 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. - declare - E : Elmt_Id; - Prim : Node_Id; + if CPP_Num_Prims (Rec_Type) > 0 then + declare + Init_DT : Entity_Id; + New_Nod : Node_Id; - begin - E := First_Elmt (Primitive_Operations (Rec_Type)); - while Present (E) loop - Prim := Node (E); + begin + Init_DT := CPP_Init_Proc (Rec_Type); + pragma Assert (Present (Init_DT)); - 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; + New_Nod := + Make_Procedure_Call_Statement (Loc, + New_Reference_To (Init_DT, Loc)); + Insert_After (Ins_Nod, New_Nod); - Next_Elmt (E); - end loop; - end; + -- Update location of init tag statements + + Ins_Nod := New_Nod; + end; + end if; + + 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. - In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp)) - and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp))); + 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; + + -- 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); diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 7599a25dc73..5411f04d05d 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -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); - - -- Skip secondary dispatch table and secondary dispatch table of - -- predefined primitives + (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 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)); + 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)); - -- Import the forward declaration of the Dispatch Table wrapper record - -- (Make_DT will take care of its exportation) + -- Minimum decoration - if Building_Static_DT (Typ) then - Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List); - - 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. + -- Note: The value of Suffix_Index must be in sync with the + -- Suffix_Index values of secondary dispatch tables generated + -- by Make_DT. - 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; + 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; - 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; + -- Declare variables that will store the copy of the C++ + -- secondary tags - -- Secondary dispatch table referencing thunks to user-defined - -- primitives covered by this interface. + 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); - 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)); + 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))); - - 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); + Defining_Unit_Name => Constructor_Id, + Parameter_Specifications => Parms)); + + 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); diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 4aea2ca1e65..5c3796ba410 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- 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 diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb index 8d27395ddde..8b19f9190db 100644 --- a/gcc/ada/exp_tss.adb +++ b/gcc/ada/exp_tss.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- 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; diff --git a/gcc/ada/exp_tss.ads b/gcc/ada/exp_tss.ads index 07415fcf71f..d6a18fb1bfe 100644 --- a/gcc/ada/exp_tss.ads +++ b/gcc/ada/exp_tss.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- 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; diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads index f78321057c9..81dab28d30e 100644 --- a/gcc/ada/freeze.ads +++ b/gcc/ada/freeze.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- 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; diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index a8ce09fc51c..1cb612d2a7a 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -1765,11 +1765,11 @@ ada/exp_ch11.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ 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.ads ada/a-unccon.ads \ 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.ads ada/a-unccon.ads \ 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-except.ads ada/a-unccon.ads \ 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-except.ads ada/a-unccon.ads \ 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-except.ads ada/a-unccon.ads \ 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-charac.ads ada/a-chlat1.ads \ 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-except.ads ada/a-unccon.ads \ 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 \ diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 5ff55cec1b2..35f5717b3cc 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -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 diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index bbb6a274967..93473732d8d 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -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. diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 8b1d60aa153..67a913919e3 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -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; ------------------------------------------ diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 5ddd96ac655..15995b8f416 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -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 -------------------------------- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index c49a2016538..08b0087a6cd 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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)) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index e846845ca70..156d24762d6 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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 -- -------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 54878f326a1..80eaf9c62b1 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -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 |