diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2007-08-14 08:39:00 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2007-08-14 08:39:00 +0000 |
| commit | 17e1445149e4bef8ee8dd04359823d3dd3661aa3 (patch) | |
| tree | d4efd163d6df2c16952d272ae73419ac96fdf0e2 | |
| parent | 0d62118c727650669b97dda9090bcb3cfc03d749 (diff) | |
| download | gcc-17e1445149e4bef8ee8dd04359823d3dd3661aa3.tar.gz | |
2007-08-14 Ed Schonberg <schonberg@adacore.com>
Javier Miranda <miranda@adacore.com>
* exp_disp.ads, exp_disp.adb (Build_Dispatch_Tables): Handle tagged
types declared in the declarative part of a nested package body or in
the proper body of a stub.
(Set_All_DT_Position): Add missing check to avoid wrong assignation
of the same dispatch table slot to renamed primitives.
(Make_Select_Specific_Data_Table): Handle private types.
(Tagged_Kind): Handle private types.
(Make_Tags, Make_DT): Set tag entity as internal to ensure proper dg
output of implicit importation and exportation.
(Expand_Interface_Thunk): Fix bug in the expansion assuming that the
first formal of the thunk is always associated with the controlling
type. In addition perform the following code cleanup: remove formal
Thunk_Alias which is no longer required, cleanup evaluation of the
the controlling type, and update the documentation.
Replace occurrence of Default_Prim_Op_Count by
Max_Predef_Prims. Addition of compile-time check to verify
that the value of Max_Predef_Prims is correct.
(Check_Premature_Freezing): Apply check in Ada95 mode as well.
(Make_DT): Add parameter to indicate when type has been frozen by an
object declaration, for diagnostic purposes.
(Build_Static_Dispatch_Tables): New subprogram that takes care of the
construction of statically allocated dispatch tables.
(Make_DT): In case of library-level tagged types export the declaration
of the primary tag. Remove generation of tags (now done by Make_Tags).
Additional modifications to handle non-static generation of dispatch
tables. Take care of building tables for asynchronous interface types
(Make_Tags): New subprogram that generates the entities associated with
the primary and secondary tags of Typ and fills the contents of Access_
Disp_Table. In case of library-level tagged types imports the forward
declaration of the primary tag that will be declared later by Make_DT.
(Expand_Interface_Conversion): In case of access types to interfaces
replace an itype declaration by an explicit type declaration to avoid
problems associated with the scope of such itype in transient blocks.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127418 138bc75d-0d04-0410-961f-82ee72b054a4
| -rw-r--r-- | gcc/ada/exp_disp.adb | 1610 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.ads | 64 |
2 files changed, 1028 insertions, 646 deletions
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 1c079893d5d..1eb0624c287 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -37,7 +37,6 @@ with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Itypes; use Itypes; -with Lib; use Lib; with Nlists; use Nlists; with Nmake; use Nmake; with Namet; use Namet; @@ -91,6 +90,148 @@ package body Exp_Disp is -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference -- to an RE_Tagged_Kind enumeration value. + ---------------------------------- + -- Build_Static_Dispatch_Tables -- + ---------------------------------- + + procedure Build_Static_Dispatch_Tables (N : Entity_Id) is + Target_List : List_Id; + + procedure Build_Dispatch_Tables (List : List_Id); + -- Build the static dispatch table of tagged types found in the list of + -- declarations. The generated nodes are added at the end of Target_List + + procedure Build_Package_Dispatch_Tables (N : Node_Id); + -- Build static dispatch tables associated with package declaration N + + --------------------------- + -- Build_Dispatch_Tables -- + --------------------------- + + procedure Build_Dispatch_Tables (List : List_Id) is + D : Node_Id; + + begin + D := First (List); + while Present (D) loop + + -- Handle nested packages and package bodies recursively. The + -- generated code is placed on the Target_List established for + -- the enclosing compilation unit. + + if Nkind (D) = N_Package_Declaration then + Build_Package_Dispatch_Tables (D); + + elsif Nkind (D) = N_Package_Body then + Build_Dispatch_Tables (Declarations (D)); + + elsif Nkind (D) = N_Package_Body_Stub + and then Present (Library_Unit (D)) + then + Build_Dispatch_Tables + (Declarations (Proper_Body (Unit (Library_Unit (D))))); + + -- Handle full type declarations and derivations of library + -- level tagged types + + elsif (Nkind (D) = N_Full_Type_Declaration + or else Nkind (D) = N_Derived_Type_Definition) + and then Is_Library_Level_Tagged_Type (Defining_Entity (D)) + and then Ekind (Defining_Entity (D)) /= E_Record_Subtype + and then not Is_Private_Type (Defining_Entity (D)) + then + Insert_List_After_And_Analyze (Last (Target_List), + Make_DT (Defining_Entity (D))); + + -- Handle private types of library level tagged types. We must + -- exchange the private and full-view to ensure the correct + -- expansion. + + elsif (Nkind (D) = N_Private_Type_Declaration + or else Nkind (D) = N_Private_Extension_Declaration) + and then Present (Full_View (Defining_Entity (D))) + and then Is_Library_Level_Tagged_Type + (Full_View (Defining_Entity (D))) + and then Ekind (Full_View (Defining_Entity (D))) + /= E_Record_Subtype + then + declare + E1, E2 : Entity_Id; + begin + E1 := Defining_Entity (D); + E2 := Full_View (Defining_Entity (D)); + Exchange_Entities (E1, E2); + Insert_List_After_And_Analyze (Last (Target_List), + Make_DT (E1)); + Exchange_Entities (E1, E2); + end; + end if; + + Next (D); + end loop; + end Build_Dispatch_Tables; + + ----------------------------------- + -- Build_Package_Dispatch_Tables -- + ----------------------------------- + + procedure Build_Package_Dispatch_Tables (N : Node_Id) is + Spec : constant Node_Id := Specification (N); + Id : constant Entity_Id := Defining_Entity (N); + Vis_Decls : constant List_Id := Visible_Declarations (Spec); + Priv_Decls : constant List_Id := Private_Declarations (Spec); + + begin + Push_Scope (Id); + + if Present (Priv_Decls) then + Build_Dispatch_Tables (Vis_Decls); + Build_Dispatch_Tables (Priv_Decls); + + elsif Present (Vis_Decls) then + Build_Dispatch_Tables (Vis_Decls); + end if; + + Pop_Scope; + end Build_Package_Dispatch_Tables; + + -- Start of processing for Build_Static_Dispatch_Tables + + begin + if not Expander_Active + or else VM_Target /= No_VM + then + return; + end if; + + if Nkind (N) = N_Package_Declaration then + declare + Spec : constant Node_Id := Specification (N); + Vis_Decls : constant List_Id := Visible_Declarations (Spec); + Priv_Decls : constant List_Id := Private_Declarations (Spec); + + begin + if Present (Priv_Decls) + and then Is_Non_Empty_List (Priv_Decls) + then + Target_List := Priv_Decls; + + elsif not Present (Vis_Decls) then + Target_List := New_List; + Set_Private_Declarations (Spec, Target_List); + else + Target_List := Vis_Decls; + end if; + + Build_Package_Dispatch_Tables (N); + end; + + else pragma Assert (Nkind (N) = N_Package_Body); + Target_List := Declarations (N); + Build_Dispatch_Tables (Target_List); + end if; + end Build_Static_Dispatch_Tables; + ------------------------------ -- Default_Prim_Op_Position -- ------------------------------ @@ -573,12 +714,9 @@ package body Exp_Disp is Etyp : constant Entity_Id := Etype (N); Operand : constant Node_Id := Expression (N); Operand_Typ : Entity_Id := Etype (Operand); - Fent : Entity_Id; Func : Node_Id; Iface_Typ : Entity_Id := Etype (N); Iface_Tag : Entity_Id; - New_Itype : Entity_Id; - Stats : List_Id; begin -- Ada 2005 (AI-345): Handle synchronized interface type derivations @@ -672,19 +810,25 @@ package body Exp_Disp is -- data returned by IW_Convert to indicate that this is a dispatching -- call. - New_Itype := Create_Itype (E_Anonymous_Access_Type, N); - Set_Etype (New_Itype, New_Itype); - Init_Esize (New_Itype); - Init_Size_Align (New_Itype); - Set_Directly_Designated_Type (New_Itype, Etyp); + declare + New_Itype : Entity_Id; - Rewrite (N, Make_Explicit_Dereference (Loc, - Unchecked_Convert_To (New_Itype, - Relocate_Node (N)))); - Analyze (N); - Freeze_Itype (New_Itype, N); + begin + New_Itype := Create_Itype (E_Anonymous_Access_Type, N); + Set_Etype (New_Itype, New_Itype); + Init_Esize (New_Itype); + Init_Size_Align (New_Itype); + Set_Directly_Designated_Type (New_Itype, Etyp); - return; + Rewrite (N, + Make_Explicit_Dereference (Loc, + Prefix => + Unchecked_Convert_To (New_Itype, Relocate_Node (N)))); + Analyze (N); + Freeze_Itype (New_Itype, N); + + return; + end; end if; Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ); @@ -709,18 +853,24 @@ package body Exp_Disp is -- the value of the displaced actual. That is: -- function Func (O : Address) return Iface_Typ is + -- type Op_Typ is access all Operand_Typ; + -- Aux : Op_Typ := To_Op_Typ (O); -- begin -- if O = Null_Address then -- return null; -- else - -- return Iface_Typ!(Operand_Typ!(O).Iface_Tag'Address); + -- return Iface_Typ!(Aux.Iface_Tag'Address); -- end if; -- end Func; - Fent := Make_Defining_Identifier (Loc, New_Internal_Name ('F')); - declare - Desig_Typ : Entity_Id; + Decls : List_Id; + Desig_Typ : Entity_Id; + Fent : Entity_Id; + New_Typ_Decl : Node_Id; + New_Obj_Decl : Node_Id; + Stats : List_Id; + begin Desig_Typ := Etype (Expression (N)); @@ -728,99 +878,127 @@ package body Exp_Disp is Desig_Typ := Directly_Designated_Type (Desig_Typ); end if; - New_Itype := Create_Itype (E_Anonymous_Access_Type, N); - Set_Etype (New_Itype, New_Itype); - Set_Scope (New_Itype, Fent); - Init_Size_Align (New_Itype); - Set_Directly_Designated_Type (New_Itype, Desig_Typ); - end; + New_Typ_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, New_Internal_Name ('T')), + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Null_Exclusion_Present => False, + Constant_Present => False, + Subtype_Indication => + New_Reference_To (Desig_Typ, Loc))); - Stats := New_List ( - Make_Return_Statement (Loc, - Unchecked_Convert_To (Etype (N), - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => Unchecked_Convert_To (New_Itype, - Make_Identifier (Loc, Name_uO)), - Selector_Name => - New_Occurrence_Of (Iface_Tag, Loc)), - Attribute_Name => Name_Address)))); + New_Obj_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('S')), + Constant_Present => True, + Object_Definition => + New_Reference_To (Defining_Identifier (New_Typ_Decl), Loc), + Expression => + Unchecked_Convert_To (Defining_Identifier (New_Typ_Decl), + Make_Identifier (Loc, Name_uO))); - -- If the type is null-excluding, no need for the null branch. - -- Otherwise we need to check for it and return null. + Decls := New_List ( + New_Typ_Decl, + New_Obj_Decl); - if not Can_Never_Be_Null (Etype (N)) then Stats := New_List ( - Make_If_Statement (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => Make_Identifier (Loc, Name_uO), - Right_Opnd => New_Reference_To - (RTE (RE_Null_Address), Loc)), - - Then_Statements => New_List ( - Make_Return_Statement (Loc, - Make_Null (Loc))), - Else_Statements => Stats)); - end if; + Make_Simple_Return_Statement (Loc, + Unchecked_Convert_To (Etype (N), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + New_Reference_To + (Defining_Identifier (New_Obj_Decl), + Loc), + Selector_Name => + New_Occurrence_Of (Iface_Tag, Loc)), + Attribute_Name => Name_Address)))); - Func := - Make_Subprogram_Body (Loc, - Specification => - Make_Function_Specification (Loc, - Defining_Unit_Name => Fent, + -- If the type is null-excluding, no need for the null branch. + -- Otherwise we need to check for it and return null. + + if not Can_Never_Be_Null (Etype (N)) then + Stats := New_List ( + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => Make_Identifier (Loc, Name_uO), + Right_Opnd => New_Reference_To + (RTE (RE_Null_Address), Loc)), + + Then_Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Make_Null (Loc))), + Else_Statements => Stats)); + end if; - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uO), - Parameter_Type => - New_Reference_To (RTE (RE_Address), Loc))), + Fent := + Make_Defining_Identifier (Loc, + New_Internal_Name ('F')); - Result_Definition => - New_Reference_To (Etype (N), Loc)), + Func := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Fent, - Declarations => Empty_List, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uO), + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc))), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, Stats)); + Result_Definition => + New_Reference_To (Etype (N), Loc)), - -- Place function body before the expression containing the - -- conversion. We suppress all checks because the body of the - -- internally generated function already takes care of the case - -- in which the actual is null; therefore there is no need to - -- double check that the pointer is not null when the program - -- executes the alternative that performs the type conversion). + Declarations => Decls, - Insert_Action (N, Func, Suppress => All_Checks); + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stats)); - if Is_Access_Type (Etype (Expression (N))) then + -- Place function body before the expression containing the + -- conversion. We suppress all checks because the body of the + -- internally generated function already takes care of the case + -- in which the actual is null; therefore there is no need to + -- double check that the pointer is not null when the program + -- executes the alternative that performs the type conversion). - -- Generate: Operand_Typ!(Expression.all)'Address + Insert_Action (N, Func, Suppress => All_Checks); - Rewrite (N, - Make_Function_Call (Loc, - Name => New_Reference_To (Fent, Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => Unchecked_Convert_To (Operand_Typ, - Make_Explicit_Dereference (Loc, - Relocate_Node (Expression (N)))), - Attribute_Name => Name_Address)))); + if Is_Access_Type (Etype (Expression (N))) then - else - -- Generate: Operand_Typ!(Expression)'Address + -- Generate: Operand_Typ!(Expression.all)'Address - Rewrite (N, - Make_Function_Call (Loc, - Name => New_Reference_To (Fent, Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => Unchecked_Convert_To (Operand_Typ, - Relocate_Node (Expression (N))), - Attribute_Name => Name_Address)))); - end if; + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (Fent, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Unchecked_Convert_To (Operand_Typ, + Make_Explicit_Dereference (Loc, + Relocate_Node (Expression (N)))), + Attribute_Name => Name_Address)))); + + else + -- Generate: Operand_Typ!(Expression)'Address + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (Fent, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Unchecked_Convert_To (Operand_Typ, + Relocate_Node (Expression (N))), + Attribute_Name => Name_Address)))); + end if; + end; end if; Analyze (N); @@ -1014,12 +1192,11 @@ package body Exp_Disp is ---------------------------- procedure Expand_Interface_Thunk - (N : Node_Id; - Thunk_Alias : Entity_Id; - Thunk_Id : out Entity_Id; - Thunk_Code : out Node_Id) + (Prim : Node_Id; + Thunk_Id : out Entity_Id; + Thunk_Code : out Node_Id) is - Loc : constant Source_Ptr := Sloc (N); + Loc : constant Source_Ptr := Sloc (Prim); Actuals : constant List_Id := New_List; Decl : constant List_Id := New_List; Formals : constant List_Id := New_List; @@ -1038,13 +1215,13 @@ package body Exp_Disp is -- Give message if configurable run-time and Offset_To_Top unavailable if not RTE_Available (RE_Offset_To_Top) then - Error_Msg_CRT ("abstract interface types", N); + Error_Msg_CRT ("abstract interface types", Prim); return; end if; -- Traverse the list of alias to find the final target - Target := Thunk_Alias; + Target := Prim; while Present (Alias (Target)) loop Target := Alias (Target); end loop; @@ -1076,15 +1253,7 @@ package body Exp_Disp is Next_Formal (Formal); end loop; - if Ekind (First_Formal (Target)) = E_In_Parameter - and then Ekind (Etype (First_Formal (Target))) - = E_Anonymous_Access_Type - then - Controlling_Typ := - Directly_Designated_Type (Etype (First_Formal (Target))); - else - Controlling_Typ := Etype (First_Formal (Target)); - end if; + Controlling_Typ := Find_Dispatching_Type (Target); Target_Formal := First_Formal (Target); Formal := First (Formals); @@ -1096,11 +1265,9 @@ package body Exp_Disp is then -- Generate: - -- type T is access all <<type of the first formal>> - -- S1 := Storage_Offset!(formal) - -- - Offset_To_Top (Formal.Tag) - - -- ... and the first actual of the call is generated as T!(S1) + -- type T is access all <<type of the target formal>> + -- S : Storage_Offset := Storage_Offset!(Formal) + -- - Offset_To_Top (address!(Formal)) Decl_2 := Make_Full_Type_Declaration (Loc, @@ -1144,7 +1311,8 @@ package body Exp_Disp is Append_To (Decl, Decl_2); Append_To (Decl, Decl_1); - -- Reference the new first actual + -- Reference the new actual. Generate: + -- T!(S) Append_To (Actuals, Unchecked_Convert_To @@ -1154,9 +1322,9 @@ package body Exp_Disp is elsif Etype (Target_Formal) = Controlling_Typ then -- Generate: - -- S1 := Storage_Offset!(Formal'Address) - -- - Offset_To_Top (Formal.Tag) - -- S2 := Tag_Ptr!(S3) + -- S1 : Storage_Offset := Storage_Offset!(Formal'Address) + -- - Offset_To_Top (Formal'Address) + -- S2 : Addr_Ptr := Addr_Ptr!(S1) Decl_1 := Make_Object_Declaration (Loc, @@ -1200,11 +1368,12 @@ package body Exp_Disp is Append_To (Decl, Decl_1); Append_To (Decl, Decl_2); - -- Reference the new first actual + -- Reference the new actual. Generate: + -- Target_Formal (S2.all) Append_To (Actuals, Unchecked_Convert_To - (Etype (First_Entity (Target)), + (Etype (Target_Formal), Make_Explicit_Dereference (Loc, New_Reference_To (Defining_Identifier (Decl_2), Loc)))); @@ -1252,7 +1421,7 @@ package body Exp_Disp is Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Make_Function_Call (Loc, Name => New_Occurrence_Of (Target, Loc), Parameter_Associations => Actuals))))); @@ -1919,7 +2088,7 @@ package body Exp_Disp is -- return To_Address (_T._task_id); Ret := - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => @@ -1938,7 +2107,7 @@ package body Exp_Disp is -- return Null_Address; Ret := - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => New_Reference_To (RTE (RE_Null_Address), Loc)); end if; @@ -2262,23 +2431,41 @@ package body Exp_Disp is -- ... -- end; - function Make_DT (Typ : Entity_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (Typ); - Is_Local_DT : constant Boolean := - Ekind (Cunit_Entity (Get_Source_Unit (Typ))) - /= E_Package; + function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is + Loc : constant Source_Ptr := Sloc (Typ); + + Has_DT : constant Boolean := + not Is_Interface (Typ) + and then not Restriction_Active (No_Dispatching_Calls); + + Build_Static_DT : constant Boolean := + Static_Dispatch_Tables + and then Is_Library_Level_Tagged_Type (Typ); + Max_Predef_Prims : constant Int := UI_To_Int (Intval (Expression - (Parent (RTE (RE_Default_Prim_Op_Count))))); + (Parent (RTE (RE_Max_Predef_Prims))))); + + procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id); + -- Verify that all non-tagged types in the profile of a subprogram + -- are frozen at the point the subprogram is frozen. This enforces + -- the rule on RM 13.14 (14) as modified by AI05-019. At the point a + -- subprogram is frozen, enough must be known about it to build the + -- activation record for it, which requires at least that the size of + -- all parameters be known. Controlling arguments are by-reference, + -- and therefore the rule only applies to non-tagged types. + -- Typical violation of the rule involves an object declaration that + -- freezes a tagged type, when one of its primitive operations has a + -- type in its profile whose full view has not been analyzed yet. procedure Make_Secondary_DT - (Typ : Entity_Id; - Iface : Entity_Id; - AI_Tag : Entity_Id; - Iface_DT_Ptr : Entity_Id; - Result : List_Id); + (Typ : Entity_Id; + Iface : Entity_Id; + AI_Tag : Entity_Id; + Iface_DT_Ptr : Entity_Id; + Result : List_Id); -- Ada 2005 (AI-251): Expand the declarations for the Secondary Dispatch -- Table of Typ associated with Iface (each abstract interface of Typ -- has a secondary dispatch table). The arguments Typ, Ancestor_Typ @@ -2286,6 +2473,29 @@ package body Exp_Disp is -- is added at the end of Acc_Disp_Tables; this external name will be -- used later by the subprogram Exp_Ch3.Build_Init_Procedure. + ------------------------------ + -- Check_Premature_Freezing -- + ------------------------------ + + procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id) is + begin + if Present (N) + and then Is_Private_Type (Typ) + and then No (Full_View (Typ)) + and then not Is_Generic_Type (Typ) + and then not Is_Tagged_Type (Typ) + and then not Is_Frozen (Typ) + then + Error_Msg_Sloc := Sloc (Subp); + Error_Msg_NE + ("declaration must appear after completion of type &", N, Typ); + Error_Msg_NE + ("\which is an untagged type in the profile of" + & " primitive operation & declared#", + N, Subp); + end if; + end Check_Premature_Freezing; + ----------------------- -- Make_Secondary_DT -- ----------------------- @@ -2299,7 +2509,6 @@ package body Exp_Disp is is Loc : constant Source_Ptr := Sloc (Typ); Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag); - Name_DT : constant Name_Id := New_Internal_Name ('T'); Iface_DT : constant Entity_Id := Make_Defining_Identifier (Loc, Name_DT); @@ -2321,12 +2530,10 @@ package body Exp_Disp is Prim_Ops_Aggr_List : List_Id; begin - -- Handle the case where the backend does not support statically - -- allocated dispatch tables. + -- Handle cases in which we do not generate statically allocated + -- dispatch tables. - if not Static_Dispatch_Tables - or else Is_Local_DT - then + if not Build_Static_DT then Set_Ekind (Predef_Prims, E_Variable); Set_Is_Statically_Allocated (Predef_Prims); @@ -2369,7 +2576,7 @@ package body Exp_Disp is -- Stage 1: Calculate the number of predefined primitives - if not Static_Dispatch_Tables then + if not Build_Static_DT then Nb_Predef_Prims := Max_Predef_Prims; else Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); @@ -2415,11 +2622,7 @@ package body Exp_Disp is Prim := Alias (Prim); end loop; - Expand_Interface_Thunk - (N => Prim, - Thunk_Alias => Prim, - Thunk_Id => Thunk_Id, - Thunk_Code => Thunk_Code); + Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); if Present (Thunk_Id) then Append_To (Result, Thunk_Code); @@ -2447,7 +2650,7 @@ package body Exp_Disp is Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => Predef_Prims, - Constant_Present => Static_Dispatch_Tables, + Constant_Present => Build_Static_DT, Aliased_Present => True, Object_Definition => New_Reference_To (RTE (RE_Address_Array), Loc), @@ -2627,6 +2830,16 @@ package body Exp_Disp is Expression => Make_Aggregate (Loc, Component_Associations => OSD_Aggr_List)))))); + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (OSD, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + -- In secondary dispatch tables the Typeinfo component contains -- the address of the Object Specific Data (see a-tags.ads) @@ -2645,7 +2858,7 @@ package body Exp_Disp is New_Reference_To (RTE (RE_Null_Address), Loc)); elsif Is_Abstract_Type (Typ) - or else not Static_Dispatch_Tables + or else not Build_Static_DT then for J in 1 .. Nb_Prim loop Append_To (Prim_Ops_Aggr_List, @@ -2680,11 +2893,7 @@ package body Exp_Disp is and then not Is_Parent (Iface, Typ) then - Expand_Interface_Thunk - (N => Prim, - Thunk_Alias => Alias (Prim), - Thunk_Id => Thunk_Id, - Thunk_Code => Thunk_Code); + Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); if Present (Thunk_Id) then Pos := @@ -2733,6 +2942,16 @@ package body Exp_Disp is Expression => Make_Aggregate (Loc, Expressions => DT_Aggr_List))); + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (Iface_DT, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + -- Generate code to create the pointer to the dispatch table -- Iface_DT_Ptr : Tag := Tag!(DT'Address); @@ -2758,35 +2977,16 @@ package body Exp_Disp is -- Local variables - -- Seems a huge list, shouldn't some of these be commented??? - -- Seems like we are counting too much on guessing from names here??? - Elab_Code : constant List_Id := New_List; Generalized_Tag : constant Entity_Id := RTE (RE_Tag); - Result : constant List_Id := New_List; - Tname : constant Name_Id := Chars (Typ); - Name_DT : constant Name_Id := New_External_Name (Tname, 'T'); - Name_Exname : constant Name_Id := New_External_Name (Tname, 'E'); - Name_Predef_Prims : constant Name_Id := New_External_Name (Tname, 'R'); - Name_SSD : constant Name_Id := New_External_Name (Tname, 'S'); - Name_TSD : constant Name_Id := New_External_Name (Tname, 'B'); - DT : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_DT); - Exname : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_Exname); - Predef_Prims : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_Predef_Prims); - SSD : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_SSD); - TSD : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_TSD); + Result : constant List_Id := New_List; + Tname : constant Name_Id := Chars (Typ); AI : Elmt_Id; AI_Tag_Comp : Elmt_Id; AI_Ptr_Elmt : Elmt_Id; DT_Constr_List : List_Id; DT_Aggr_List : List_Id; DT_Ptr : Entity_Id; - Has_Dispatch_Table : Boolean := True; ITable : Node_Id; I_Depth : Nat := 0; Iface_Table_Node : Node_Id; @@ -2803,165 +3003,188 @@ package body Exp_Disp is Prim : Entity_Id; Prim_Elmt : Elmt_Id; Prim_Ops_Aggr_List : List_Id; - Transportable : Entity_Id; - RC_Offset_Node : Node_Id; Suffix_Index : Int; Typ_Comps : Elist_Id; Typ_Ifaces : Elist_Id; TSD_Aggr_List : List_Id; TSD_Tags_List : List_Id; - TSD_Ifaces_List : List_Id; + + -- The following name entries are used by Make_DT to generate a number + -- of entities related to a tagged type. These entities may be generated + -- in a scope other than that of the tagged type declaration, and if + -- the entities for two tagged types with the same name happen to be + -- generated in the same scope, we have to take care to use different + -- names. This is achieved by means of a unique serial number appended + -- to each generated entity name. + + Name_DT : constant Name_Id := + New_External_Name (Tname, 'T', Suffix_Index => -1); + Name_Exname : constant Name_Id := + New_External_Name (Tname, 'E', Suffix_Index => -1); + Name_Predef_Prims : constant Name_Id := + New_External_Name (Tname, 'R', Suffix_Index => -1); + Name_SSD : constant Name_Id := + New_External_Name (Tname, 'S', Suffix_Index => -1); + Name_TSD : constant Name_Id := + New_External_Name (Tname, 'B', Suffix_Index => -1); + + -- Entities built with above names + + DT : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_DT); + Exname : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_Exname); + Predef_Prims : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_Predef_Prims); + SSD : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_SSD); + TSD : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_TSD); -- Start of processing for Make_DT begin - -- Fill the contents of Access_Disp_Table + pragma Assert (Is_Frozen (Typ)); - -- 1) Generate the primary and secondary tag entities - - declare - DT_Ptr : Node_Id; - Name_DT_Ptr : Name_Id; - Typ_Name : Name_Id; - Iface_DT_Ptr : Node_Id; - Suffix_Index : Int; - AI_Tag_Comp : Elmt_Id; + -- Handle cases in which there is no need to build the dispatch table - begin - -- Collect the components associated with secondary dispatch tables + if Has_Dispatch_Table (Typ) + or else No (Access_Disp_Table (Typ)) + or else Is_CPP_Class (Typ) + then + return Result; - if Has_Abstract_Interfaces (Typ) then - Collect_Interface_Components (Typ, Typ_Comps); - end if; + elsif No_Run_Time_Mode then + Error_Msg_CRT ("tagged types", Typ); + return Result; - -- Generate the primary tag entity + elsif not RTE_Available (RE_Tag) then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Node (First_Elmt + (Access_Disp_Table (Typ))), + Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), + Constant_Present => True, + Expression => + Unchecked_Convert_To (Generalized_Tag, + New_Reference_To (RTE (RE_Null_Address), Loc)))); - Name_DT_Ptr := New_External_Name (Tname, 'P'); - DT_Ptr := Make_Defining_Identifier (Loc, Name_DT_Ptr); - Set_Ekind (DT_Ptr, E_Constant); - Set_Is_Statically_Allocated (DT_Ptr); - Set_Is_True_Constant (DT_Ptr); + Analyze_List (Result, Suppress => All_Checks); + Error_Msg_CRT ("tagged types", Typ); + return Result; + end if; - pragma Assert (No (Access_Disp_Table (Typ))); - Set_Access_Disp_Table (Typ, New_Elmt_List); - Append_Elmt (DT_Ptr, Access_Disp_Table (Typ)); + -- Ensure that the value of Max_Predef_Prims defined in a-tags is + -- correct. Valid values are 10 under configurable runtime or 15 + -- with full runtime. - -- Generate the secondary tag entities + if RTE_Available (RE_Interface_Data) then + if Max_Predef_Prims /= 15 then + Error_Msg_N ("run-time library configuration error", Typ); + return Result; + end if; + else + if Max_Predef_Prims /= 10 then + Error_Msg_N ("run-time library configuration error", Typ); + Error_Msg_CRT ("tagged types", Typ); + return Result; + end if; + end if; - if Has_Abstract_Interfaces (Typ) then - Suffix_Index := 0; + -- Ensure that all the primitives are frozen. This is only required when + -- building static dispatch tables --- the primitives must be frozen to + -- be referenced (otherwise we have problems with the backend). It is + -- not a requirement with nonstatic dispatch tables because in this case + -- we generate now an empty dispatch table; the extra code required to + -- register the primitive in the slot will be generated later --- when + -- each primitive is frozen (see Freeze_Subprogram). - -- 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. + if Build_Static_DT + and then not Is_CPP_Class (Typ) + then + declare + Save : constant Boolean := Freezing_Library_Level_Tagged_Type; + Prim_Elmt : Elmt_Id; + Frnodes : List_Id; - AI_Tag_Comp := First_Elmt (Typ_Comps); - while Present (AI_Tag_Comp) loop - Get_Secondary_DT_External_Name - (Typ, Related_Interface (Node (AI_Tag_Comp)), Suffix_Index); + begin + Freezing_Library_Level_Tagged_Type := True; + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Frnodes := Freeze_Entity (Node (Prim_Elmt), Loc); - Typ_Name := Name_Find; - Name_DT_Ptr := New_External_Name (Typ_Name, "P"); - Iface_DT_Ptr := Make_Defining_Identifier (Loc, Name_DT_Ptr); + declare + Subp : constant Entity_Id := Node (Prim_Elmt); + F : Entity_Id; - Set_Ekind (Iface_DT_Ptr, E_Constant); - Set_Is_Statically_Allocated (Iface_DT_Ptr); - Set_Is_True_Constant (Iface_DT_Ptr); - Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); + begin + F := First_Formal (Subp); + while Present (F) loop + Check_Premature_Freezing (Subp, Etype (F)); + Next_Formal (F); + end loop; - Next_Elmt (AI_Tag_Comp); - end loop; - end if; - end; + Check_Premature_Freezing (Subp, Etype (Subp)); + end; - -- 2) At the end of Access_Disp_Table we add the entity of an access - -- type declaration. It is used by Build_Get_Prim_Op_Address to - -- expand dispatching calls through the primary dispatch table. + if Present (Frnodes) then + Append_List_To (Result, Frnodes); + end if; - -- Generate: - -- type Typ_DT is array (1 .. Nb_Prims) of Address; - -- type Typ_DT_Acc is access Typ_DT; + Next_Elmt (Prim_Elmt); + end loop; + Freezing_Library_Level_Tagged_Type := Save; + end; + end if; - declare - Name_DT_Prims : constant Name_Id := - New_External_Name (Tname, 'G'); - Name_DT_Prims_Acc : constant Name_Id := - New_External_Name (Tname, 'H'); - DT_Prims : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_DT_Prims); - DT_Prims_Acc : constant Entity_Id := - Make_Defining_Identifier (Loc, - Name_DT_Prims_Acc); - begin - Append_To (Result, - Make_Full_Type_Declaration (Loc, - Defining_Identifier => DT_Prims, - Type_Definition => - Make_Constrained_Array_Definition (Loc, - Discrete_Subtype_Definitions => New_List ( - Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), - High_Bound => Make_Integer_Literal (Loc, - DT_Entry_Count - (First_Tag_Component (Typ))))), - Component_Definition => - Make_Component_Definition (Loc, - Subtype_Indication => - New_Reference_To (RTE (RE_Address), Loc))))); + -- In case of locally defined tagged type we declare the object + -- contanining the dispatch table by means of a variable. Its + -- initialization is done later by means of an assignment. This is + -- required to generate its External_Tag. - Append_To (Result, - Make_Full_Type_Declaration (Loc, - Defining_Identifier => DT_Prims_Acc, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (DT_Prims, Loc)))); + if not Build_Static_DT then + DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); + Set_Ekind (DT, E_Variable); - Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ)); - end; + -- Export the declaration of the tag previously generated and imported + -- by Make_Tags. - if Is_CPP_Class (Typ) then - return Result; - end if; + else + DT_Ptr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Tname, 'C', Suffix_Index => -1)); + Set_Ekind (DT_Ptr, E_Constant); + Set_Is_Statically_Allocated (DT_Ptr); + Set_Is_True_Constant (DT_Ptr); - if No_Run_Time_Mode or else not RTE_Available (RE_Tag) then - DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); + Set_Is_Exported (DT_Ptr); + Get_External_Name (Node (First_Elmt (Access_Disp_Table (Typ))), True); + Set_Interface_Name (DT_Ptr, + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer)); - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => DT_Ptr, - Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), - Constant_Present => True, - Expression => - Unchecked_Convert_To (Generalized_Tag, - New_Reference_To (RTE (RE_Null_Address), Loc)))); + -- Set tag as internal to ensure proper Sprint output of its implicit + -- exportation. - Analyze_List (Result, Suppress => All_Checks); - Error_Msg_CRT ("tagged types", Typ); - return Result; - end if; + Set_Is_Internal (DT_Ptr); - if not Static_Dispatch_Tables - or else Is_Local_DT - then - Set_Ekind (DT, E_Variable); - Set_Is_Statically_Allocated (DT); - else Set_Ekind (DT, E_Constant); - Set_Is_Statically_Allocated (DT); Set_Is_True_Constant (DT); + + -- The tag is made public to ensure its availability to the linker + -- (to handle the forward reference). This is required to handle + -- tagged types defined in library level package bodies. + + Set_Is_Public (DT_Ptr); end if; - pragma Assert (Present (Access_Disp_Table (Typ))); - DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); + Set_Is_Statically_Allocated (DT); -- Ada 2005 (AI-251): Build the secondary dispatch tables if Has_Abstract_Interfaces (Typ) then + Collect_Interface_Components (Typ, Typ_Comps); + Suffix_Index := 0; AI_Ptr_Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); @@ -2981,28 +3204,13 @@ package body Exp_Disp is end loop; end if; - -- Evaluate if we generate the dispatch table - - Has_Dispatch_Table := - not Is_Interface (Typ) - and then not Restriction_Active (No_Dispatching_Calls); - -- Calculate the number of primitives of the dispatch table and the -- size of the Type_Specific_Data record. - if Has_Dispatch_Table then + if Has_DT then Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); end if; - if not Static_Dispatch_Tables then - Set_Ekind (Predef_Prims, E_Variable); - Set_Is_Statically_Allocated (Predef_Prims); - else - Set_Ekind (Predef_Prims, E_Constant); - Set_Is_Statically_Allocated (Predef_Prims); - Set_Is_True_Constant (Predef_Prims); - end if; - Set_Ekind (SSD, E_Constant); Set_Is_Statically_Allocated (SSD); Set_Is_True_Constant (SSD); @@ -3020,7 +3228,7 @@ package body Exp_Disp is -- multiple-called scopes. if not Is_Interface (Typ) then - Name_No_Reg := New_External_Name (Tname, 'F'); + Name_No_Reg := New_External_Name (Tname, 'F', Suffix_Index => -1); No_Reg := Make_Defining_Identifier (Loc, Name_No_Reg); Set_Ekind (No_Reg, E_Variable); @@ -3038,13 +3246,14 @@ package body Exp_Disp is -- initialization is done later by means of an assignment. This is -- required to generate its External_Tag. - if Is_Local_DT then + if not Build_Static_DT then -- Generate: -- DT : No_Dispatch_Table_Wrapper; + -- for DT'Alignment use Address'Alignment; -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address); - if not Has_Dispatch_Table then + if not Has_DT then Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT, @@ -3055,6 +3264,16 @@ package body Exp_Disp is (RTE (RE_No_Dispatch_Table_Wrapper), Loc))); Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (DT, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT_Ptr, Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), @@ -3187,36 +3406,24 @@ package body Exp_Disp is end; Append_To (TSD_Aggr_List, - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of (RTE_Record_Component (RE_Idepth), Loc)), - Expression => - Make_Integer_Literal (Loc, I_Depth))); + Make_Integer_Literal (Loc, I_Depth)); -- Access_Level Append_To (TSD_Aggr_List, - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of (RTE_Record_Component (RE_Access_Level), Loc)), - Expression => - Make_Integer_Literal (Loc, Type_Access_Level (Typ)))); + Make_Integer_Literal (Loc, Type_Access_Level (Typ))); -- Expanded_Name Append_To (TSD_Aggr_List, - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of (RTE_Record_Component (RE_Expanded_Name), Loc)), - Expression => - Unchecked_Convert_To (RTE (RE_Cstring_Ptr), - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Exname, Loc), - Attribute_Name => Name_Address)))); + Unchecked_Convert_To (RTE (RE_Cstring_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Exname, Loc), + Attribute_Name => Name_Address))); -- External_Tag of a local tagged type - -- Exname : constant String := + -- <typ>A : constant String := -- "Internal tag at 16#tag-addr#: <full-name-of-typ>"; -- The reason we generate this strange name is that we do not want to @@ -3237,63 +3444,42 @@ package body Exp_Disp is -- in scope, but it clearly must be erroneous to compute the internal -- tag of a tagged type that is out of scope! - if Is_Local_DT then + -- We don't do this processing if an explicit external tag has been + -- specified. That's an odd case for which we have already issued a + -- warning, where we will not be able to compute the internal tag. + + if not Is_Library_Level_Entity (Typ) + and then not Has_External_Tag_Rep_Clause (Typ) + then declare - Name_Exname : constant Name_Id := New_External_Name (Tname, 'L'); - Name_Str1 : constant Name_Id := New_Internal_Name ('I'); - Name_Str2 : constant Name_Id := New_Internal_Name ('I'); - Name_Str3 : constant Name_Id := New_Internal_Name ('I'); Exname : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_Exname); - Str1 : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_Str1); - Str2 : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_Str2); - Str3 : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_Str3); + Make_Defining_Identifier (Loc, + New_External_Name (Tname, 'A')); + Full_Name : constant String_Id := Full_Qualified_Name (First_Subtype (Typ)); Str1_Id : String_Id; Str2_Id : String_Id; - Str3_Id : String_Id; begin -- Generate: - -- Str1 : constant String := "Internal tag at 16#"; - - Set_Ekind (Str1, E_Constant); - Set_Is_Statically_Allocated (Str1); - Set_Is_True_Constant (Str1); + -- Str1 = "Internal tag at 16#"; Start_String; Store_String_Chars ("Internal tag at 16#"); Str1_Id := End_String; -- Generate: - -- Str2 : constant String := "#: "; - - Set_Ekind (Str2, E_Constant); - Set_Is_Statically_Allocated (Str2); - Set_Is_True_Constant (Str2); + -- Str2 = "#: <type-full-name>"; Start_String; Store_String_Chars ("#: "); - Str2_Id := End_String; - - -- Generate: - -- Str3 : constant String := <full-name-of-typ>; - - Set_Ekind (Str3, E_Constant); - Set_Is_Statically_Allocated (Str3); - Set_Is_True_Constant (Str3); - - Start_String; Store_String_Chars (Full_Name); - Str3_Id := End_String; + Str2_Id := End_String; -- Generate: -- Exname : constant String := - -- Str1 & Address_Image (Tag) & Str2 & Str3; + -- Str1 & Address_Image (Tag) & Str2; if RTE_Available (RE_Address_Image) then Append_To (Result, @@ -3317,11 +3503,8 @@ package body Exp_Disp is Unchecked_Convert_To (RTE (RE_Address), New_Reference_To (DT_Ptr, Loc)))), Right_Opnd => - Make_Op_Concat (Loc, - Left_Opnd => - Make_String_Literal (Loc, Str2_Id), - Right_Opnd => - Make_String_Literal (Loc, Str3_Id)))))); + Make_String_Literal (Loc, Str2_Id))))); + else Append_To (Result, Make_Object_Declaration (Loc, @@ -3334,11 +3517,7 @@ package body Exp_Disp is Left_Opnd => Make_String_Literal (Loc, Str1_Id), Right_Opnd => - Make_Op_Concat (Loc, - Left_Opnd => - Make_String_Literal (Loc, Str2_Id), - Right_Opnd => - Make_String_Literal (Loc, Str3_Id))))); + Make_String_Literal (Loc, Str2_Id)))); end if; New_Node := @@ -3372,11 +3551,12 @@ package body Exp_Disp is else Old_Val := Strval (Expr_Value_S (Expression (Def))); - -- For the rep clause "for x'external_tag use y" generate: + -- For the rep clause "for <typ>'external_tag use y" generate: - -- xV : constant string := y; - -- Set_External_Tag (x'tag, xV'Address); - -- Register_Tag (x'tag); + -- <typ>A : constant string := y; + -- + -- <typ>A'Address is used to set the External_Tag component + -- of the TSD -- Create a new nul terminated string if it is not already @@ -3412,43 +3592,34 @@ package body Exp_Disp is end; end if; - Append_To (TSD_Aggr_List, - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_External_Tag), Loc)), - Expression => New_Node)); + Append_To (TSD_Aggr_List, New_Node); -- HT_Link Append_To (TSD_Aggr_List, - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_HT_Link), Loc)), - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (RTE (RE_Null_Address), Loc)))); + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (RTE (RE_Null_Address), Loc))); -- Transportable: Set for types that can be used in remote calls -- with respect to E.4(18) legality rules. - Transportable := - Boolean_Literals - (Is_Pure (Typ) - or else Is_Shared_Passive (Typ) - or else - ((Is_Remote_Types (Typ) - or else Is_Remote_Call_Interface (Typ)) - and then Original_View_In_Visible_Part (Typ)) - or else not Comes_From_Source (Typ)); + declare + Transportable : Entity_Id; - Append_To (TSD_Aggr_List, - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_Transportable), Loc)), - Expression => New_Occurrence_Of (Transportable, Loc))); + begin + Transportable := + Boolean_Literals + (Is_Pure (Typ) + or else Is_Shared_Passive (Typ) + or else + ((Is_Remote_Types (Typ) + or else Is_Remote_Call_Interface (Typ)) + and then Original_View_In_Visible_Part (Typ)) + or else not Comes_From_Source (Typ)); + + Append_To (TSD_Aggr_List, + New_Occurrence_Of (Transportable, Loc)); + end; -- RC_Offset: These are the valid values and their meaning: @@ -3465,47 +3636,48 @@ package body Exp_Disp is -- -2: There are no controlled components at this level. We need to -- get the position from the parent. - if not Has_Controlled_Component (Typ) then - RC_Offset_Node := Make_Integer_Literal (Loc, 0); + declare + RC_Offset_Node : Node_Id; - elsif Etype (Typ) /= Typ - and then Has_Discriminants (Etype (Typ)) - then - if Has_New_Controlled_Component (Typ) then - RC_Offset_Node := Make_Integer_Literal (Loc, -1); + begin + if not Has_Controlled_Component (Typ) then + RC_Offset_Node := Make_Integer_Literal (Loc, 0); + + elsif Etype (Typ) /= Typ + and then Has_Discriminants (Etype (Typ)) + then + if Has_New_Controlled_Component (Typ) then + RC_Offset_Node := Make_Integer_Literal (Loc, -1); + else + RC_Offset_Node := Make_Integer_Literal (Loc, -2); + end if; else - RC_Offset_Node := Make_Integer_Literal (Loc, -2); + RC_Offset_Node := + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Typ, Loc), + Selector_Name => + New_Reference_To (Controller_Component (Typ), Loc)), + Attribute_Name => Name_Position); + + -- This is not proper Ada code to use the attribute 'Position + -- on something else than an object but this is supported by + -- the back end (see comment on the Bit_Component attribute in + -- sem_attr). So we avoid semantic checking here. + + -- Is this documented in sinfo.ads??? it should be! + + Set_Analyzed (RC_Offset_Node); + Set_Etype (Prefix (RC_Offset_Node), RTE (RE_Record_Controller)); + Set_Etype (Prefix (Prefix (RC_Offset_Node)), Typ); + Set_Etype (Selector_Name (Prefix (RC_Offset_Node)), + RTE (RE_Record_Controller)); + Set_Etype (RC_Offset_Node, RTE (RE_Storage_Offset)); end if; - else - RC_Offset_Node := - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => New_Reference_To (Typ, Loc), - Selector_Name => - New_Reference_To (Controller_Component (Typ), Loc)), - Attribute_Name => Name_Position); - - -- This is not proper Ada code to use the attribute 'Position - -- on something else than an object but this is supported by - -- the back end (see comment on the Bit_Component attribute in - -- sem_attr). So we avoid semantic checking here. - - -- Is this documented in sinfo.ads??? it should be! - - Set_Analyzed (RC_Offset_Node); - Set_Etype (Prefix (RC_Offset_Node), RTE (RE_Record_Controller)); - Set_Etype (Prefix (Prefix (RC_Offset_Node)), Typ); - Set_Etype (Selector_Name (Prefix (RC_Offset_Node)), - RTE (RE_Record_Controller)); - Set_Etype (RC_Offset_Node, RTE (RE_Storage_Offset)); - end if; - Append_To (TSD_Aggr_List, - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of (RTE_Record_Component (RE_RC_Offset), Loc)), - Expression => RC_Offset_Node)); + Append_To (TSD_Aggr_List, RC_Offset_Node); + end; -- Interfaces_Table (required for AI-405) @@ -3527,98 +3699,86 @@ package body Exp_Disp is -- Generate the Interface_Table object else - TSD_Ifaces_List := New_List; - declare - Pos : Nat := 1; - Aggr_List : List_Id; + TSD_Ifaces_List : constant List_Id := New_List; begin AI := First_Elmt (Typ_Ifaces); while Present (AI) loop - Aggr_List := New_List ( - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_Iface_Tag), Loc)), - Expression => + Append_To (TSD_Ifaces_List, + Make_Aggregate (Loc, + Expressions => New_List ( + + -- Iface_Tag + Unchecked_Convert_To (Generalized_Tag, New_Reference_To (Node (First_Elmt (Access_Disp_Table (Node (AI)))), - Loc))), + Loc)), - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_Static_Offset_To_Top), - Loc)), - Expression => - New_Reference_To (Standard_True, Loc)), + -- Static_Offset_To_Top - Make_Component_Association (Loc, - Choices => New_List (Make_Others_Choice (Loc)), - Expression => Empty, - Box_Present => True)); + New_Reference_To (Standard_True, Loc), - Append_To (TSD_Ifaces_List, - Make_Component_Association (Loc, - Choices => New_List ( - Make_Integer_Literal (Loc, Pos)), - Expression => Make_Aggregate (Loc, - Component_Associations => Aggr_List))); + -- Offset_To_Top_Value + + Make_Integer_Literal (Loc, 0), + + -- Offset_To_Top_Func + + Make_Null (Loc)))); - Pos := Pos + 1; Next_Elmt (AI); end loop; - end; - Name_ITable := New_External_Name (Tname, 'I'); - ITable := Make_Defining_Identifier (Loc, Name_ITable); + Name_ITable := New_External_Name (Tname, 'I'); + ITable := Make_Defining_Identifier (Loc, Name_ITable); + Set_Is_Statically_Allocated (ITable); - Set_Ekind (ITable, E_Constant); - Set_Is_Statically_Allocated (ITable); - Set_Is_True_Constant (ITable); + -- The table of interfaces is not constant; its slots are + -- filled at run-time by the IP routine using attribute + -- 'Position to know the location of the tag components + -- (and this attribute cannot be safely used before the + -- object is initialized). - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => ITable, - Aliased_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Reference_To (RTE (RE_Interface_Data), Loc), - Constraint => Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Integer_Literal (Loc, Num_Ifaces)))), + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => ITable, + Aliased_Present => True, + Constant_Present => False, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Interface_Data), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint + (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, Num_Ifaces)))), - Expression => Make_Aggregate (Loc, - Component_Associations => New_List ( - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_Nb_Ifaces), Loc)), - Expression => - Make_Integer_Literal (Loc, Num_Ifaces)), + Expression => Make_Aggregate (Loc, + Expressions => New_List ( + Make_Integer_Literal (Loc, Num_Ifaces), + Make_Aggregate (Loc, + Expressions => TSD_Ifaces_List))))); - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_Ifaces_Table), Loc)), - Expression => Make_Aggregate (Loc, - Component_Associations => TSD_Ifaces_List)))))); + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (ITable, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); - Iface_Table_Node := - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (ITable, Loc), - Attribute_Name => Name_Unchecked_Access); + Iface_Table_Node := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (ITable, Loc), + Attribute_Name => Name_Unchecked_Access); + end; end if; - Append_To (TSD_Aggr_List, - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_Interfaces_Table), Loc)), - Expression => Iface_Table_Node)); + Append_To (TSD_Aggr_List, Iface_Table_Node); end if; -- Generate the Select Specific Data table for synchronized types that @@ -3627,7 +3787,7 @@ package body Exp_Disp is if RTE_Record_Component_Available (RE_SSD) then if Ada_Version >= Ada_05 - and then Has_Dispatch_Table + and then Has_DT and then Is_Concurrent_Record_Type (Typ) and then Has_Abstract_Interfaces (Typ) and then Nb_Prim > 0 @@ -3648,110 +3808,127 @@ package body Exp_Disp is Constraints => New_List ( Make_Integer_Literal (Loc, Nb_Prim)))))); + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (SSD, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + -- This table is initialized by Make_Select_Specific_Data_Table, -- which calls Set_Entry_Index and Set_Prim_Op_Kind. Append_To (TSD_Aggr_List, - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_SSD), Loc)), - Expression => - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (SSD, Loc), - Attribute_Name => Name_Unchecked_Access))); + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (SSD, Loc), + Attribute_Name => Name_Unchecked_Access)); else - Append_To (TSD_Aggr_List, - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_SSD), Loc)), - Expression => Make_Null (Loc))); + Append_To (TSD_Aggr_List, Make_Null (Loc)); end if; end if; -- Initialize the table of ancestor tags. In case of interface types -- this table is not needed. - if Is_Interface (Typ) then - Append_To (TSD_Aggr_List, - Make_Component_Association (Loc, - Choices => New_List (Make_Others_Choice (Loc)), - Expression => Empty, - Box_Present => True)); - else - declare - Current_Typ : Entity_Id; - Parent_Typ : Entity_Id; - Pos : Nat; + declare + Current_Typ : Entity_Id; + Parent_Typ : Entity_Id; + Pos : Nat; - begin - TSD_Tags_List := New_List; + begin + TSD_Tags_List := New_List; - -- Fill position 0 with null because we still have not generated - -- the tag of Typ. + -- If we are not statically allocating the dispatch table then we + -- must fill position 0 with null because we still have not + -- generated the tag of Typ. + if not Build_Static_DT + or else Is_Interface (Typ) + then Append_To (TSD_Tags_List, - Make_Component_Association (Loc, - Choices => New_List ( - Make_Integer_Literal (Loc, 0)), - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (RTE (RE_Null_Address), Loc)))); + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (RTE (RE_Null_Address), Loc))); - -- Fill the rest of the table with the tags of the ancestors + -- Otherwise we can safely import the tag. The name must be unique + -- over the compilation unit, to avoid conflicts when types of the + -- same name appear in different nested packages. We don't need to + -- use an external name because this name is only locally used. - Pos := 1; - Current_Typ := Typ; + else + declare + Imported_DT_Ptr : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('D')); - loop - Parent_Typ := Etype (Current_Typ); + begin + Set_Is_Imported (Imported_DT_Ptr); + Set_Is_Statically_Allocated (Imported_DT_Ptr); + Set_Is_True_Constant (Imported_DT_Ptr); + Get_External_Name + (Node (First_Elmt (Access_Disp_Table (Typ))), True); + Set_Interface_Name (Imported_DT_Ptr, + Make_String_Literal (Loc, String_From_Name_Buffer)); - if Is_Private_Type (Parent_Typ) then - Parent_Typ := Full_View (Base_Type (Parent_Typ)); - end if; + -- Set tag as internal to ensure proper Sprint output of its + -- implicit importation. - exit when Parent_Typ = Current_Typ; + Set_Is_Internal (Imported_DT_Ptr); - if Is_CPP_Class (Parent_Typ) then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Imported_DT_Ptr, + Constant_Present => True, + Object_Definition => New_Reference_To (RTE (RE_Tag), + Loc))); - -- The tags defined in the C++ side will be inherited when - -- the object is constructed. - -- (see Exp_Ch3.Build_Init_Procedure) + Append_To (TSD_Tags_List, + New_Reference_To (Imported_DT_Ptr, Loc)); + end; + end if; - Append_To (TSD_Tags_List, - Make_Component_Association (Loc, - Choices => New_List ( - Make_Integer_Literal (Loc, Pos)), - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (RTE (RE_Null_Address), Loc)))); - else - Append_To (TSD_Tags_List, - Make_Component_Association (Loc, - Choices => New_List ( - Make_Integer_Literal (Loc, Pos)), - Expression => - New_Reference_To - (Node (First_Elmt (Access_Disp_Table (Parent_Typ))), - Loc))); - end if; + -- Fill the rest of the table with the tags of the ancestors - Pos := Pos + 1; - Current_Typ := Parent_Typ; - end loop; + Pos := 1; + Current_Typ := Typ; - pragma Assert (Pos = I_Depth + 1); - end; + loop + Parent_Typ := Etype (Current_Typ); - Append_To (TSD_Aggr_List, - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_Tags_Table), Loc)), - Expression => Make_Aggregate (Loc, - Component_Associations => TSD_Tags_List))); - end if; + if Is_Private_Type (Parent_Typ) then + Parent_Typ := Full_View (Base_Type (Parent_Typ)); + end if; + + exit when Parent_Typ = Current_Typ; + + if Is_CPP_Class (Parent_Typ) + or else Is_Interface (Typ) + then + -- The tags defined in the C++ side will be inherited when + -- the object is constructed (Exp_Ch3.Build_Init_Procedure) + + Append_To (TSD_Tags_List, + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (RTE (RE_Null_Address), Loc))); + else + Append_To (TSD_Tags_List, + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Parent_Typ))), + Loc)); + end if; + + Pos := Pos + 1; + Current_Typ := Parent_Typ; + end loop; + + pragma Assert (Pos = I_Depth + 1); + end; + + Append_To (TSD_Aggr_List, + Make_Aggregate (Loc, + Expressions => TSD_Tags_List)); -- Build the TSD object @@ -3759,6 +3936,7 @@ package body Exp_Disp is Make_Object_Declaration (Loc, Defining_Identifier => TSD, Aliased_Present => True, + Constant_Present => Build_Static_DT, Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To ( @@ -3769,7 +3947,7 @@ package body Exp_Disp is Make_Integer_Literal (Loc, I_Depth)))), Expression => Make_Aggregate (Loc, - Component_Associations => TSD_Aggr_List))); + Expressions => TSD_Aggr_List))); Append_To (Result, Make_Attribute_Definition_Clause (Loc, @@ -3786,8 +3964,9 @@ package body Exp_Disp is -- DT : No_Dispatch_Table := -- (NDT_TSD => TSD'Address; -- NDT_Prims_Ptr => 0); + -- for DT'Alignment use Address'Alignment - if not Has_Dispatch_Table then + if not Has_DT then DT_Constr_List := New_List; DT_Aggr_List := New_List; @@ -3806,7 +3985,7 @@ package body Exp_Disp is -- and uninitialized object for the dispatch table, which is now -- initialized by means of an assignment. - if Is_Local_DT then + if not Build_Static_DT then Append_To (Result, Make_Assignment_Statement (Loc, Name => New_Reference_To (DT, Loc), @@ -3821,13 +4000,23 @@ package body Exp_Disp is Make_Object_Declaration (Loc, Defining_Identifier => DT, Aliased_Present => True, - Constant_Present => Static_Dispatch_Tables, + Constant_Present => True, Object_Definition => New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc), Expression => Make_Aggregate (Loc, Expressions => DT_Aggr_List))); Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (DT, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => DT_Ptr, Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), @@ -3865,13 +4054,14 @@ package body Exp_Disp is -- prim-op-2'address, -- ... -- prim-op-n'address)); + -- for DT'Alignment use Address'Alignment else declare Pos : Nat; begin - if not Static_Dispatch_Tables then + if not Build_Static_DT then Nb_Predef_Prims := Max_Predef_Prims; else @@ -3902,11 +4092,12 @@ package body Exp_Disp is Prim_Ops_Aggr_List := New_List; Prim_Table := (others => Empty); + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); - if Static_Dispatch_Tables + if Build_Static_DT and then Is_Predefined_Dispatching_Operation (Prim) and then not Is_Abstract_Subprogram (Prim) and then not Present (Prim_Table @@ -3941,7 +4132,7 @@ package body Exp_Disp is Make_Object_Declaration (Loc, Defining_Identifier => Predef_Prims, Aliased_Present => True, - Constant_Present => Static_Dispatch_Tables, + Constant_Present => Build_Static_DT, Object_Definition => New_Reference_To (RTE (RE_Address_Array), Loc), Expression => Make_Aggregate (Loc, @@ -4017,7 +4208,7 @@ package body Exp_Disp is Append_To (Prim_Ops_Aggr_List, New_Reference_To (RTE (RE_Null_Address), Loc)); - elsif not Static_Dispatch_Tables then + elsif not Build_Static_DT then for J in 1 .. Nb_Prim loop Append_To (Prim_Ops_Aggr_List, New_Reference_To (RTE (RE_Null_Address), Loc)); @@ -4059,10 +4250,6 @@ package body Exp_Disp is (UI_To_Int (DT_Position (Prim)) <= Nb_Prim); Prim_Table (UI_To_Int (DT_Position (Prim))) := E; - - -- There is no need to set Has_Delayed_Freeze here - -- because the analysis of 'Address and 'Code_Address - -- takes care of it. end if; end if; @@ -4092,7 +4279,7 @@ package body Exp_Disp is -- and uninitialized object for the dispatch table, which is now -- initialized by means of an assignment. - if Is_Local_DT then + if not Build_Static_DT then Append_To (Result, Make_Assignment_Statement (Loc, Name => New_Reference_To (DT, Loc), @@ -4107,7 +4294,7 @@ package body Exp_Disp is Make_Object_Declaration (Loc, Defining_Identifier => DT, Aliased_Present => True, - Constant_Present => Static_Dispatch_Tables, + Constant_Present => True, Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To @@ -4147,7 +4334,8 @@ package body Exp_Disp is -- Initialize the table of ancestor tags - if not Is_Interface (Typ) + if not Build_Static_DT + and then not Is_Interface (Typ) and then not Is_CPP_Class (Typ) then Append_To (Result, @@ -4169,7 +4357,7 @@ package body Exp_Disp is (Node (First_Elmt (Access_Disp_Table (Typ))), Loc))); end if; - if Static_Dispatch_Tables then + if Build_Static_DT then null; -- If the ancestor is a CPP_Class type we inherit the dispatch tables @@ -4225,6 +4413,7 @@ package body Exp_Disp is if Nb_Prims /= 0 then Append_To (Elab_Code, Build_Inherit_Prims (Loc, + Typ => Typ, Old_Tag_Node => Old_Tag2, New_Tag_Node => New_Reference_To (DT_Ptr, Loc), Num_Prims => Nb_Prims)); @@ -4304,6 +4493,7 @@ package body Exp_Disp is if Num_Prims /= 0 then Append_To (Elab_Code, Build_Inherit_Prims (Loc, + Typ => Node (Iface), Old_Tag_Node => Unchecked_Convert_To (RTE (RE_Tag), @@ -4315,7 +4505,7 @@ package body Exp_Disp is (RTE (RE_Tag), New_Reference_To (Node (Sec_DT_Typ), Loc)), - Num_Prims => Num_Prims)); + Num_Prims => Num_Prims)); end if; end; end if; @@ -4370,7 +4560,7 @@ package body Exp_Disp is if not Is_Interface (Typ) then if not No_Run_Time_Mode - and then not Is_Local_DT + and then Is_Library_Level_Entity (Typ) and then RTE_Available (RE_Register_Tag) then Append_To (Elab_Code, @@ -4391,7 +4581,21 @@ package body Exp_Disp is Then_Statements => Elab_Code)); end if; + -- Populate the two auxiliary tables used for dispatching + -- asynchronous, conditional and timed selects for synchronized + -- types that implement a limited interface. + + if Ada_Version >= Ada_05 + and then Is_Concurrent_Record_Type (Typ) + and then Has_Abstract_Interfaces (Typ) + then + Append_List_To (Result, + Make_Select_Specific_Data_Table (Typ)); + end if; + Analyze_List (Result, Suppress => All_Checks); + Set_Has_Dispatch_Table (Typ); + return Result; end Make_DT; @@ -4459,6 +4663,10 @@ package body Exp_Disp is if Present (Corresponding_Concurrent_Type (Typ)) then Conc_Typ := Corresponding_Concurrent_Type (Typ); + if Present (Full_View (Conc_Typ)) then + Conc_Typ := Full_View (Conc_Typ); + end if; + if Ekind (Conc_Typ) = E_Protected_Type then Decls := Visible_Declarations (Protected_Definition ( Parent (Conc_Typ))); @@ -4549,6 +4757,159 @@ package body Exp_Disp is return Assignments; end Make_Select_Specific_Data_Table; + --------------- + -- Make_Tags -- + --------------- + + function Make_Tags (Typ : Entity_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (Typ); + Build_Static_DT : constant Boolean := + Static_Dispatch_Tables + and then Is_Library_Level_Tagged_Type (Typ); + Tname : constant Name_Id := Chars (Typ); + Result : constant List_Id := New_List; + AI_Tag_Comp : Elmt_Id; + DT_Ptr : Node_Id; + Iface_DT_Ptr : Node_Id; + Suffix_Index : Int; + Typ_Name : Name_Id; + Typ_Comps : Elist_Id; + + begin + -- 1) Generate the primary and secondary tag entities + + -- Collect the components associated with secondary dispatch tables + + if Has_Abstract_Interfaces (Typ) then + Collect_Interface_Components (Typ, Typ_Comps); + end if; + + -- 1) Generate the primary tag entity + + DT_Ptr := Make_Defining_Identifier (Loc, + New_External_Name (Tname, 'P')); + Set_Etype (DT_Ptr, RTE (RE_Tag)); + Set_Ekind (DT_Ptr, E_Variable); + + -- Import the forward declaration of the tag (Make_DT will take care of + -- its exportation) + + if Build_Static_DT then + Set_Is_Imported (DT_Ptr); + Set_Is_True_Constant (DT_Ptr); + Set_Scope (DT_Ptr, Current_Scope); + Get_External_Name (DT_Ptr, True); + Set_Interface_Name (DT_Ptr, + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer)); + + -- Set tag entity as internal to ensure proper Sprint output of its + -- implicit importation. + + Set_Is_Internal (DT_Ptr); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => DT_Ptr, + Constant_Present => True, + Object_Definition => New_Reference_To (RTE (RE_Tag), Loc))); + end if; + + pragma Assert (No (Access_Disp_Table (Typ))); + Set_Access_Disp_Table (Typ, New_Elmt_List); + Append_Elmt (DT_Ptr, Access_Disp_Table (Typ)); + + -- 2) Generate the secondary tag entities + + if Has_Abstract_Interfaces (Typ) then + Suffix_Index := 0; + + -- For each interface type we build an unique external name + -- associated with its corresponding secondary dispatch table. + -- This external name will be used to declare an object that + -- references this secondary dispatch table, value that will be + -- used for the elaboration of Typ's objects and also for the + -- elaboration of objects of derivations of Typ that do not + -- override the primitive operation of this interface type. + + AI_Tag_Comp := First_Elmt (Typ_Comps); + while Present (AI_Tag_Comp) loop + Get_Secondary_DT_External_Name + (Typ, Related_Interface (Node (AI_Tag_Comp)), Suffix_Index); + + Typ_Name := Name_Find; + 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_Statically_Allocated (Iface_DT_Ptr); + Set_Is_True_Constant (Iface_DT_Ptr); + Set_Related_Interface + (Iface_DT_Ptr, Related_Interface (Node (AI_Tag_Comp))); + Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); + + Next_Elmt (AI_Tag_Comp); + end loop; + end if; + + -- 3) At the end of Access_Disp_Table we add the entity of an access + -- type declaration. It is used by Build_Get_Prim_Op_Address to + -- expand dispatching calls through the primary dispatch table. + + -- Generate: + -- type Typ_DT is array (1 .. Nb_Prims) of Address; + -- type Typ_DT_Acc is access Typ_DT; + + declare + Name_DT_Prims : constant Name_Id := + New_External_Name (Tname, 'G'); + Name_DT_Prims_Acc : constant Name_Id := + New_External_Name (Tname, 'H'); + DT_Prims : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_DT_Prims); + DT_Prims_Acc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Name_DT_Prims_Acc); + begin + Append_To (Result, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => DT_Prims, + Type_Definition => + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Make_Integer_Literal (Loc, + DT_Entry_Count + (First_Tag_Component (Typ))))), + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Reference_To (RTE (RE_Address), Loc))))); + + Append_To (Result, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => DT_Prims_Acc, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (DT_Prims, Loc)))); + + Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ)); + + -- Analyze the resulting list and suppress the generation of the + -- Init_Proc associated with the above array declaration because + -- we never use such type in object declarations; this type is only + -- used to simplify the expansion associated with dispatching calls. + + Analyze_List (Result); + Set_Suppress_Init_Proc (Base_Type (DT_Prims)); + end; + + return Result; + end Make_Tags; + ----------------------------------- -- Original_View_In_Visible_Part -- ----------------------------------- @@ -4730,15 +5091,15 @@ package body Exp_Disp is pragma Assert (Is_Interface (Iface_Typ)); - Expand_Interface_Thunk - (N => Prim, - Thunk_Alias => Alias (Prim), - Thunk_Id => Thunk_Id, - Thunk_Code => Thunk_Code); + Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); if not Is_Parent (Iface_Typ, Typ) and then Present (Thunk_Code) then + -- Comment needed on why checks are suppressed. This is not just + -- efficiency, but fundamental functionality (see 1.295 RH, which + -- still does not answer this question) ??? + Insert_Action (Ins_Nod, Thunk_Code, Suppress => All_Checks); -- Generate the code necessary to fill the appropriate entry of @@ -5075,6 +5436,7 @@ package body Exp_Disp is elsif not Present (Abstract_Interface_Alias (Prim)) and then Present (Alias (Prim)) + and then Chars (Prim) = Chars (Alias (Prim)) and then Find_Dispatching_Type (Alias (Prim)) /= Typ and then Is_Parent (Find_Dispatching_Type (Alias (Prim)), Typ) @@ -5245,7 +5607,7 @@ package body Exp_Disp is then Error_Msg_NE ("abstract inherited private operation&" & - " must be overridden ('R'M 3.9.3(10))", + " must be overridden (RM 3.9.3(10))", Parent (Typ), Prim); end if; end if; @@ -5384,6 +5746,10 @@ package body Exp_Disp is elsif Is_Concurrent_Record_Type (T) then Conc_Typ := Corresponding_Concurrent_Type (T); + if Present (Full_View (Conc_Typ)) then + Conc_Typ := Full_View (Conc_Typ); + end if; + if Ekind (Conc_Typ) = E_Protected_Type then return New_Reference_To (RTE (RE_TK_Protected), Loc); else @@ -5414,7 +5780,7 @@ package body Exp_Disp is -- Protect this procedure against wrong usage. Required because it will -- be used directly from GDB - if not (Typ in First_Node_Id .. Last_Node_Id) + if not (Typ <= Last_Node_Id) or else not Is_Tagged_Type (Typ) then Write_Str ("wrong usage: Write_DT must be used with tagged types"); diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 32cde2f6302..498b9f05763 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -122,11 +122,11 @@ package Exp_Disp is -- PPOs are collected and added to the Primitive_Operations list of -- a type by the regular analysis mechanism. - -- PPOs are frozen by Exp_Ch3.Predefined_Primitive_Freeze. + -- PPOs are frozen by Exp_Ch3.Predefined_Primitive_Freeze - -- Thunks for PPOs are created by Make_DT. + -- Thunks for PPOs are created by Make_DT - -- Dispatch table positions of PPOs are set by Set_All_DT_Position. + -- Dispatch table positions of PPOs are set by Set_All_DT_Position -- Calls to PPOs proceed as regular dispatching calls. If the PPO -- has a thunk, a call proceeds as a regular dispatching call with @@ -134,8 +134,8 @@ package Exp_Disp is -- Guidelines for addition of new predefined primitive operations - -- Update the value of constant Default_Prim_Op_Count in A-Tags.ads - -- to reflect the new number of PPOs. + -- Update the value of constant Max_Predef_Prims in a-tags.ads to + -- indicate the new number of PPOs. -- Introduce a new predefined name for the new PPO in Snames.ads and -- Snames.adb. @@ -161,10 +161,19 @@ package Exp_Disp is -- for a tagged type. If more predefined primitive operations are -- added, the following items must be changed: - -- Ada.Tags.Defailt_Prim_Op_Count - indirect use + -- Ada.Tags.Max_Predef_Prims - indirect use -- Exp_Disp.Default_Prim_Op_Position - indirect use -- Exp_Disp.Set_All_DT_Position - direct use + procedure Build_Static_Dispatch_Tables (N : Node_Id); + -- N is a library level package declaration or package body. Build the + -- static dispatch table of the tagged types defined at library level. In + -- case of package declarations with private part the generated nodes are + -- added at the end of the list of private declarations. Otherwise they are + -- added to the end of the list of public declarations. In case of package + -- bodies they are added to the end of the list of declarations of the + -- package body. + 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 @@ -182,21 +191,23 @@ package Exp_Disp is -- secondary dispatch table. procedure Expand_Interface_Thunk - (N : Node_Id; - Thunk_Alias : Node_Id; - Thunk_Id : out Entity_Id; - Thunk_Code : out Node_Id); + (Prim : Node_Id; + Thunk_Id : out Entity_Id; + Thunk_Code : out Node_Id); -- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we - -- generate additional subprograms (thunks) to have a layout compatible - -- with the C++ ABI. The thunk modifies the value of the first actual of - -- the call (that is, the pointer to the object) before transferring - -- control to the target function. - -- - -- Required in 3.4 case, why ??? giant comment needed for any gcc - -- specific code ??? - - function Make_DT (Typ : Entity_Id) return List_Id; - -- Expand the declarations for the Dispatch Table. + -- generate additional subprograms (thunks) associated with each primitive + -- Prim to have a layout compatible with the C++ ABI. The thunk displaces + -- the pointers to the actuals that depend on the controlling type before + -- transferring control to the target subprogram. If there is no need to + -- generate the thunk then Thunk_Id and Thunk_Code are set to Empty. + -- Otherwise they are set to the defining identifier and the subprogram + -- body of the generated thunk. + + function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id; + -- Expand the declarations for the Dispatch Table. The node N is the + -- declaration that forces the generation of the table. It is used to place + -- error messages when the declaration leads to the freezing of a given + -- primitive operation that has an incomplete non- tagged formal. function Make_Disp_Asynchronous_Select_Body (Typ : Entity_Id) return Node_Id; @@ -234,10 +245,9 @@ package Exp_Disp is function Make_Disp_Get_Task_Id_Body (Typ : Entity_Id) return Node_Id; - -- Ada 2005 (AI-345): Generate the body of the primitive operation of type - -- Typ used for retrieving the _task_id field of a task interface class- - -- wide type. Generate a null body if Typ is an interface or a non-task - -- type. + -- Ada 2005 (AI-345): Generate body of the primitive operation of type Typ + -- used for retrieving the _task_id field of a task interface class- wide + -- type. Generate a null body if Typ is an interface or a non-task type. function Make_Disp_Get_Task_Id_Spec (Typ : Entity_Id) return Node_Id; @@ -263,6 +273,12 @@ package Exp_Disp is -- selects. Generate code to set the primitive operation kinds and entry -- indices of primitive operations and primitive wrappers. + function Make_Tags (Typ : Entity_Id) return List_Id; + -- Generate the entities associated with the primary and secondary tags of + -- Typ and fill the contents of Access_Disp_Table. In case of library level + -- tagged types this routine imports the forward declaration of the tag + -- entity, that will be declared and exported by Make_DT. + procedure Register_Primitive (Loc : Source_Ptr; Prim : Entity_Id; |