From 0d62118c727650669b97dda9090bcb3cfc03d749 Mon Sep 17 00:00:00 2001 From: charlet Date: Tue, 14 Aug 2007 08:38:48 +0000 Subject: [PATCH] 2007-08-14 Thomas Quinot Ed Schonberg Javier Miranda Robert Dewar * exp_ch3.ads, exp_ch3.adb (Add_Final_Chain): New subprogram. (Freeze_Array_Type, Freeze_Record_Type): For the case of a component type that is an anonymous access to controlled object, establish an associated finalization chain to avoid corrupting the global finalization list when a dynamically allocated object designated by such a component is deallocated. (Make_Controlling_Function_Wrappers): Create wrappers for constructor functions that need it, even when not marked Requires_Overriding. (Initialize_Tag): Replace call to has_discriminants by call to Is_Variable_Size_Record in the circuitry that handles the initialization of secondary tags. (Is_Variable_Size_Record): New implementation. (Expand_N_Object_Declaration): Suppress call to init proc if there is a Suppress_Initialization pragma for a derived type. (Is_Variable_Size_Record): New subprogram. (Build_Offset_To_Top_Functions): New implementation that simplifies the initial version of this routine and also fixes problems causing incomplete initialization of the table of interfaces. (Build_Init_Procedure): Improve the generation of code to initialize the the tag components of secondary dispatch tables. (Init_Secondary_Tags): New implementation that simplifies the previous version of this routine. (Make_DT): Add parameter to indicate when type has been frozen by an object declaration, for diagnostic purposes. (Check_Premature_Freezing): New subsidiary procedure of Make_DT, to diagnose attemps to freeze a subprogram when some untagged type of its profile is a private type whose full view has not been analyzed yet. (Freeze_Array_Type): Generate init proc for packed array if either Initialize or Normalize_Scalars is set. (Make_Controlling_Function_Wrappers, Make_Null_Procedure_Specs): when constructing the new profile, copy the null_exclusion indicator for each parameter, to ensure full conformance of the new body with the spec. * sem_type.ads, sem_type.adb (Make_Controlling_Function_Wrappers): Create wrappers for constructor functions that need it, even when not marked Requires_Overriding. (Covers): Handle properly designated types of anonymous access types, whose non-limited views are themselves incomplete types. (Add_Entry): Use an entity to store the abstract operation which hides an interpretation. (Binary_Op_May_Be_Hidden): Rename to Binary_Op_Interp_Has_Abstract_Op. (Collect_Interps): Use Empty as an actual for Abstract_Op in the initialization aggregate. (Function_Interp_May_Be_Hidden): Rename to Function_Interp_Has_Abstract_Op. (Has_Compatible_Type): Remove machinery that skips interpretations if they are labeled as potentially hidden by an abstract operator. (Has_Hidden_Interp): Rename to Has_Abstract_Op. (Set_May_Be_Hidden): Rename to Set_Abstract_Op. (Write_Overloads): Output the abstract operator if present. (Add_Entry): Before inserting a new entry into the interpretation table for a node, determine whether the entry will be disabled by an abstract operator. (Binary_Op_Interp_May_Be_Hidden): New routine. (Collect_Interps): Add value for flag May_Be_Hidden in initialization aggregate. (Function_Interp_May_Be_Hidden): New routine. (Has_Compatible_Type): Do not consider interpretations hidden by abstract operators when trying to determine whether two types are compatible. (Has_Hidden_Interp): New routine. (Set_May_Be_Hidden_Interp): New routine. (Write_Overloads): Write the status of flag May_Be_Hidden. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127417 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/exp_ch3.adb | 1077 ++++++++++++++++++++++++++++---------------------- gcc/ada/exp_ch3.ads | 19 +- gcc/ada/sem_type.adb | 214 ++++++++-- gcc/ada/sem_type.ads | 34 +- 4 files changed, 816 insertions(+), 528 deletions(-) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 9f2a60b..a178833 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -73,6 +73,10 @@ package body Exp_Ch3 is -- Local Subprograms -- ----------------------- + function Add_Final_Chain (Def_Id : Entity_Id) return Entity_Id; + -- Add the declaration of a finalization list to the freeze actions for + -- Def_Id, and return its defining identifier. + procedure Adjust_Discriminants (Rtype : Entity_Id); -- This is used when freezing a record type. It attempts to construct -- more restrictive subtypes for discriminants so that the max size of @@ -103,7 +107,7 @@ package body Exp_Ch3 is function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id; -- This function builds a static aggregate that can serve as the initial -- value for a record type whose components are scalar and initialized - -- with compile-time values, or arrays with similarc initialization or + -- with compile-time values, or arrays with similar initialization or -- defaults. When possible, initialization of an object of the type can -- be achieved by using a copy of the aggregate as an initial value, thus -- removing the implicit call that would otherwise constitute elaboration @@ -206,6 +210,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_Record (E : Entity_Id) return Boolean; + -- Returns true if E has variable size components + function Make_Eq_Case (E : Entity_Id; CL : Node_Id; @@ -341,6 +348,28 @@ package body Exp_Ch3 is -- the generation of these operations, as a useful optimization or for -- certification purposes. + --------------------- + -- Add_Final_Chain -- + --------------------- + + function Add_Final_Chain (Def_Id : Entity_Id) return Entity_Id is + Loc : constant Source_Ptr := Sloc (Def_Id); + Flist : Entity_Id; + + begin + Flist := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Def_Id), 'L')); + + Append_Freeze_Action (Def_Id, + Make_Object_Declaration (Loc, + Defining_Identifier => Flist, + Object_Definition => + New_Reference_To (RTE (RE_List_Controller), Loc))); + + return Flist; + end Add_Final_Chain; + -------------------------- -- Adjust_Discriminants -- -------------------------- @@ -874,7 +903,7 @@ package body Exp_Ch3 is end loop; Return_Node := - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Make_Function_Call (Loc, Name => @@ -884,7 +913,7 @@ package body Exp_Ch3 is else Return_Node := - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => New_Reference_To (Standard_False, Loc)); end if; @@ -898,7 +927,7 @@ package body Exp_Ch3 is Set_Discrete_Choices (Case_Alt_Node, Choice_List); Return_Node := - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => New_Reference_To (Standard_True, Loc)); @@ -1762,7 +1791,7 @@ package body Exp_Ch3 is if Ada_Version >= Ada_05 and then Can_Never_Be_Null (Etype (Id)) -- Lhs then - if Nkind (Exp) = N_Null then + if Known_Null (Exp) then return New_List ( Make_Raise_Constraint_Error (Sloc (Exp), Reason => CE_Null_Not_Allowed)); @@ -1996,136 +2025,120 @@ package body Exp_Ch3 is ----------------------------------- procedure Build_Offset_To_Top_Functions is - ADT : Elmt_Id; - Body_Node : Node_Id; - Func_Id : Entity_Id; - Spec_Node : Node_Id; - E : Entity_Id; - procedure Build_Offset_To_Top_Internal (Typ : Entity_Id); - -- Internal subprogram used to recursively traverse all the ancestors + procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id); + -- Generate: + -- function Fxx (O : in Rec_Typ) return Storage_Offset is + -- begin + -- return O.Iface_Comp'Position; + -- end Fxx; - ---------------------------------- - -- Build_Offset_To_Top_Internal -- - ---------------------------------- + ------------------------------ + -- Build_Offset_To_Top_Body -- + ------------------------------ + + procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id) is + Body_Node : Node_Id; + Func_Id : Entity_Id; + Spec_Node : Node_Id; - procedure Build_Offset_To_Top_Internal (Typ : Entity_Id) is begin - -- Climb to the ancestor (if any) handling synchronized interface - -- derivations and private types + Func_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('F')); - if Is_Concurrent_Record_Type (Typ) then - declare - Iface_List : constant List_Id := - Abstract_Interface_List (Typ); - begin - if Is_Non_Empty_List (Iface_List) then - Build_Offset_To_Top_Internal (Etype (First (Iface_List))); - end if; - end; + Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id); - elsif Present (Full_View (Etype (Typ))) then - if Full_View (Etype (Typ)) /= Typ then - Build_Offset_To_Top_Internal (Full_View (Etype (Typ))); - end if; + -- Generate + -- function Fxx (O : in Rec_Typ) return Storage_Offset; - elsif Etype (Typ) /= Typ then - Build_Offset_To_Top_Internal (Etype (Typ)); + Spec_Node := New_Node (N_Function_Specification, Loc); + Set_Defining_Unit_Name (Spec_Node, Func_Id); + Set_Parameter_Specifications (Spec_Node, New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), + In_Present => True, + Parameter_Type => New_Reference_To (Rec_Type, Loc)))); + Set_Result_Definition (Spec_Node, + New_Reference_To (RTE (RE_Storage_Offset), Loc)); + + -- Generate + -- function Fxx (O : in Rec_Typ) return Storage_Offset is + -- begin + -- return O.Iface_Comp'Position; + -- end Fxx; + + Body_Node := New_Node (N_Subprogram_Body, Loc); + Set_Specification (Body_Node, Spec_Node); + Set_Declarations (Body_Node, New_List); + Set_Handled_Statement_Sequence (Body_Node, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uO), + Selector_Name => New_Reference_To + (Iface_Comp, Loc)), + Attribute_Name => Name_Position))))); + + Set_Ekind (Func_Id, E_Function); + Set_Mechanism (Func_Id, Default_Mechanism); + Set_Is_Internal (Func_Id, True); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Func_Id); end if; - if Present (Abstract_Interfaces (Typ)) - and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) - then - E := First_Entity (Typ); - while Present (E) loop - if Is_Tag (E) - and then Chars (E) /= Name_uTag - then - if Typ = Rec_Type then - Body_Node := New_Node (N_Subprogram_Body, Loc); - - Func_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('F')); - - Set_DT_Offset_To_Top_Func (E, Func_Id); - - Spec_Node := New_Node (N_Function_Specification, Loc); - Set_Defining_Unit_Name (Spec_Node, Func_Id); - Set_Parameter_Specifications (Spec_Node, New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uO), - In_Present => True, - Parameter_Type => New_Reference_To (Typ, Loc)))); - Set_Result_Definition (Spec_Node, - New_Reference_To (RTE (RE_Storage_Offset), Loc)); - - Set_Specification (Body_Node, Spec_Node); - Set_Declarations (Body_Node, New_List); - Set_Handled_Statement_Sequence (Body_Node, - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Return_Statement (Loc, - Expression => - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, - Name_uO), - Selector_Name => New_Reference_To - (E, Loc)), - Attribute_Name => Name_Position))))); - - Set_Ekind (Func_Id, E_Function); - Set_Mechanism (Func_Id, Default_Mechanism); - Set_Is_Internal (Func_Id, True); - - if not Debug_Generated_Code then - Set_Debug_Info_Off (Func_Id); - end if; - - Analyze (Body_Node); + Analyze (Body_Node); - Append_Freeze_Action (Rec_Type, Body_Node); - end if; + Append_Freeze_Action (Rec_Type, Body_Node); + end Build_Offset_To_Top_Function; - Next_Elmt (ADT); - end if; + -- Local variables - Next_Entity (E); - end loop; - end if; - end Build_Offset_To_Top_Internal; + Ifaces_List : Elist_Id; + Ifaces_Comp_List : Elist_Id; + Ifaces_Tag_List : Elist_Id; + Iface_Elmt : Elmt_Id; + Comp_Elmt : Elmt_Id; -- Start of processing for Build_Offset_To_Top_Functions begin - if Is_Concurrent_Record_Type (Rec_Type) - and then Is_Empty_List (Abstract_Interface_List (Rec_Type)) - then - return; + -- Offset_To_Top_Functions are built only for derivations of types + -- with discriminants that cover interface types. - elsif Etype (Rec_Type) = Rec_Type + if not Is_Tagged_Type (Rec_Type) + or else Etype (Rec_Type) = Rec_Type or else not Has_Discriminants (Etype (Rec_Type)) - or else No (Abstract_Interfaces (Rec_Type)) - or else Is_Empty_Elmt_List (Abstract_Interfaces (Rec_Type)) then return; end if; - -- Skip the first _Tag, which is the main tag of the tagged type. - -- Following tags correspond with abstract interfaces. + Collect_Interfaces_Info (Rec_Type, + Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List); - ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Rec_Type))); + -- For each interface type with secondary dispatch table we generate + -- the Offset_To_Top_Functions (required to displace the pointer in + -- interface conversions) - -- Handle private types + Iface_Elmt := First_Elmt (Ifaces_List); + Comp_Elmt := First_Elmt (Ifaces_Comp_List); + while Present (Iface_Elmt) loop - if Present (Full_View (Rec_Type)) then - Build_Offset_To_Top_Internal (Full_View (Rec_Type)); - else - Build_Offset_To_Top_Internal (Rec_Type); - end if; + -- If the interface is a parent of Rec_Type it shares the primary + -- dispatch table and hence there is no need to build the function + + if not Is_Parent (Node (Iface_Elmt), Rec_Type) then + Build_Offset_To_Top_Function (Iface_Comp => Node (Comp_Elmt)); + end if; + + Next_Elmt (Iface_Elmt); + Next_Elmt (Comp_Elmt); + end loop; end Build_Offset_To_Top_Functions; -------------------------- @@ -2139,7 +2152,7 @@ package body Exp_Ch3 is Proc_Spec_Node : Node_Id; Body_Stmts : List_Id; Record_Extension_Node : Node_Id; - Init_Tag : Node_Id; + Init_Tags_List : List_Id; begin Body_Stmts := New_List; @@ -2241,7 +2254,9 @@ package body Exp_Ch3 is and then VM_Target = No_VM and then not No_Run_Time_Mode then - Init_Tag := + -- Initialize the primary tag + + Init_Tags_List := New_List ( Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, @@ -2251,7 +2266,23 @@ package body Exp_Ch3 is Expression => New_Reference_To - (Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)); + (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_Abstract_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; -- The tag must be inserted before the assignments to other -- components, because the initial value of the component may @@ -2266,12 +2297,10 @@ package body Exp_Ch3 is -- after the calls to initialize the parent. if not Is_CPP_Class (Etype (Rec_Type)) then - Init_Tag := + Prepend_To (Body_Stmts, Make_If_Statement (Loc, Condition => New_Occurrence_Of (Set_Tag, Loc), - Then_Statements => New_List (Init_Tag)); - - Prepend_To (Body_Stmts, Init_Tag); + Then_Statements => Init_Tags_List)); -- CPP_Class: In this case the dispatch table of the parent was -- built in the C++ side and we copy the table of the parent to @@ -2279,12 +2308,12 @@ package body Exp_Ch3 is else declare - Nod : Node_Id := First (Body_Stmts); - New_N : Node_Id; + Nod : Node_Id; begin -- We assume 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))) @@ -2299,11 +2328,14 @@ package body Exp_Ch3 is -- _init._tag := new_dt; -- end if; - New_N := + Prepend_To (Init_Tags_List, Build_Inherit_Prims (Loc, + Typ => Rec_Type, Old_Tag_Node => Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), + Prefix => + Make_Identifier (Loc, + Chars => Name_uInit), Selector_Name => New_Reference_To (First_Tag_Component (Rec_Type), Loc)), @@ -2311,16 +2343,14 @@ package body Exp_Ch3 is New_Reference_To (Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc), - Num_Prims => + Num_Prims => UI_To_Int - (DT_Entry_Count (First_Tag_Component (Rec_Type)))); + (DT_Entry_Count (First_Tag_Component (Rec_Type))))); - Init_Tag := + Insert_After (Nod, Make_If_Statement (Loc, Condition => New_Occurrence_Of (Set_Tag, Loc), - Then_Statements => New_List (New_N, Init_Tag)); - - Insert_After (Nod, Init_Tag); + 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. @@ -2343,7 +2373,7 @@ package body Exp_Ch3 is then Register_Primitive (Loc, Prim => Prim, - Ins_Nod => Init_Tag); + Ins_Nod => Last (Init_Tags_List)); end if; Next_Elmt (E); @@ -2352,18 +2382,31 @@ package body Exp_Ch3 is end; end if; - -- Ada 2005 (AI-251): Initialization of all the tags corresponding - -- with abstract interfaces + -- Ada 2005 (AI-251): Initialize the secondary tag components + -- located at variable positions. We delay the generation of this + -- code until here because the value of the attribute 'Position + -- applied to variable size components of the parent type that + -- depend on discriminants is only safely read at runtime after + -- the parent components have been initialized. - if VM_Target = No_VM - and then Ada_Version >= Ada_05 + if Ada_Version >= Ada_05 and then not Is_Interface (Rec_Type) and then Has_Abstract_Interfaces (Rec_Type) + and then Has_Discriminants (Etype (Rec_Type)) + and then Is_Variable_Size_Record (Etype (Rec_Type)) then + Init_Tags_List := New_List; + Init_Secondary_Tags - (Typ => Rec_Type, - Target => Make_Identifier (Loc, Name_uInit), - Stmts_List => Body_Stmts); + (Typ => Rec_Type, + Target => Make_Identifier (Loc, Name_uInit), + Stmts_List => Init_Tags_List, + Fixed_Comps => False, + Variable_Comps => True); + + if Is_Non_Empty_List (Init_Tags_List) then + Append_List_To (Body_Stmts, Init_Tags_List); + end if; end if; end if; @@ -3498,7 +3541,7 @@ package body Exp_Ch3 is Left_Opnd => New_Reference_To (A, Loc), Right_Opnd => New_Reference_To (B, Loc)), Then_Statements => New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => New_Occurrence_Of (Standard_False, Loc))))); -- Generate component-by-component comparison. Note that we must @@ -3522,7 +3565,7 @@ package body Exp_Ch3 is end if; Append_To (Stmts, - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => New_Reference_To (Standard_True, Loc))); Set_TSS (Typ, F); @@ -3944,6 +3987,33 @@ package body Exp_Ch3 is return; end if; + -- Force construction of dispatch tables of library level tagged types + + if VM_Target = No_VM + and then Static_Dispatch_Tables + and then Is_Library_Level_Entity (Def_Id) + and then Is_Library_Level_Tagged_Type (Typ) + and then (Ekind (Typ) = E_Record_Type + or else Ekind (Typ) = E_Protected_Type + or else Ekind (Typ) = E_Task_Type) + and then not Has_Dispatch_Table (Typ) + then + declare + New_Nodes : List_Id := No_List; + + begin + if Is_Concurrent_Type (Typ) then + New_Nodes := Make_DT (Corresponding_Record_Type (Typ), N); + else + New_Nodes := Make_DT (Typ, N); + end if; + + if not Is_Empty_List (New_Nodes) then + Insert_List_Before (N, New_Nodes); + end if; + end; + end if; + -- Make shared memory routines for shared passive variable if Is_Shared_Passive (Def_Id) then @@ -3960,10 +4030,15 @@ package body Exp_Ch3 is Build_Master_Entity (Def_Id); end if; - -- Build a list controller for declarations of the form - -- Obj : access Some_Type [:= Expression]; + -- Build a list controller for declarations where the type is anonymous + -- access and the designated type is controlled. Only declarations from + -- source files receive such controllers in order to provide the same + -- lifespan for any potential coextensions that may be associated with + -- the object. Finalization lists of internal controlled anonymous + -- access objects are already handled in Expand_N_Allocator. - if Ekind (Typ) = E_Anonymous_Access_Type + if Comes_From_Source (N) + and then Ekind (Typ) = E_Anonymous_Access_Type and then Is_Controlled (Directly_Designated_Type (Typ)) and then No (Associated_Final_Chain (Typ)) then @@ -4040,12 +4115,26 @@ package body Exp_Ch3 is -- Call type initialization procedure if there is one. We build the -- call and put it immediately after the object declaration, so that -- it will be expanded in the usual manner. Note that this will - -- result in proper handling of defaulted discriminants. The call - -- to the Init_Proc is suppressed if No_Initialization is set. + -- result in proper handling of defaulted discriminants. + + -- Need call if there is a base init proc if Has_Non_Null_Base_Init_Proc (Typ) - and then not No_Initialization (N) - and then not Is_Value_Type (Typ) + + -- Suppress call if No_Initialization set on declaration + + and then not No_Initialization (N) + + -- Suppress call for special case of value type for VM + + and then not Is_Value_Type (Typ) + + -- Suppress call if Suppress_Init_Proc set on the type. This is + -- needed for the derived type case, where Suppress_Initialization + -- may be set for the derived type, even if there is an init proc + -- defined for the root type. + + and then not Suppress_Init_Proc (Typ) then -- The call to the initialization procedure does NOT freeze the -- object being initialized. This is because the call is not a @@ -4556,9 +4645,9 @@ package body Exp_Ch3 is -- Ada 2005 (AI-251): The following condition covers secondary -- tags but also the adjacent component contanining the offset -- to the base of the object (component generated if the parent - -- has discriminants ---see Add_Interface_Tag_Components). This - -- is required to avoid the addition of the controller between - -- the secondary tag and its adjacent component. + -- has discriminants --- see Add_Interface_Tag_Components). + -- This is required to avoid the addition of the controller + -- between the secondary tag and its adjacent component. or else Present (Related_Interface @@ -4695,8 +4784,9 @@ package body Exp_Ch3 is ----------------------- procedure Freeze_Array_Type (N : Node_Id) is - Typ : constant Entity_Id := Entity (N); - Base : constant Entity_Id := Base_Type (Typ); + Typ : constant Entity_Id := Entity (N); + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Base : constant Entity_Id := Base_Type (Typ); begin if not Is_Bit_Packed_Array (Typ) then @@ -4706,10 +4796,10 @@ package body Exp_Ch3 is -- been a private type at the point of definition. Same if component -- type is controlled. - Set_Has_Task (Base, Has_Task (Component_Type (Typ))); + Set_Has_Task (Base, Has_Task (Comp_Typ)); Set_Has_Controlled_Component (Base, - Has_Controlled_Component (Component_Type (Typ)) - or else Is_Controlled (Component_Type (Typ))); + Has_Controlled_Component (Comp_Typ) + or else Is_Controlled (Comp_Typ)); if No (Init_Proc (Base)) then @@ -4746,22 +4836,30 @@ package body Exp_Ch3 is end if; end if; - if Typ = Base and then Has_Controlled_Component (Base) then - Build_Controlling_Procs (Base); + if Typ = Base then + if Has_Controlled_Component (Base) then + Build_Controlling_Procs (Base); - if not Is_Limited_Type (Component_Type (Typ)) - and then Number_Dimensions (Typ) = 1 + if not Is_Limited_Type (Comp_Typ) + and then Number_Dimensions (Typ) = 1 + then + Build_Slice_Assignment (Typ); + end if; + + elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type + and then Controlled_Type (Directly_Designated_Type (Comp_Typ)) then - Build_Slice_Assignment (Typ); + Set_Associated_Final_Chain (Comp_Typ, Add_Final_Chain (Typ)); end if; end if; - -- For packed case, there is a default initialization, except if the - -- component type is itself a packed structure with an initialization - -- procedure. + -- For packed case, default initialization, except if the component type + -- is itself a packed structure with an initialization procedure, or + -- initialize/normalize scalars active, and we have a base type. - elsif Present (Init_Proc (Component_Type (Base))) - and then No (Base_Init_Proc (Base)) + elsif (Present (Init_Proc (Component_Type (Base))) + and then No (Base_Init_Proc (Base))) + or else (Init_Or_Norm_Scalars and then Base = Typ) then Build_Array_Init_Proc (Base, N); end if; @@ -4788,14 +4886,14 @@ package body Exp_Ch3 is pragma Warnings (Off, Func); begin - -- Various optimization are possible if the given representation is - -- contiguous. + -- Various optimizations possible if given representation is contiguous Is_Contiguous := True; + Ent := First_Literal (Typ); Last_Repval := Enumeration_Rep (Ent); - Next_Literal (Ent); + Next_Literal (Ent); while Present (Ent) loop if Enumeration_Rep (Ent) - Last_Repval /= 1 then Is_Contiguous := False; @@ -4968,7 +5066,7 @@ package body Exp_Ch3 is Make_Integer_Literal (Loc, Intval => Last_Repval))), Statements => New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Pos_Expr)))); else @@ -4981,7 +5079,7 @@ package body Exp_Ch3 is Intval => Enumeration_Rep (Ent))), Statements => New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Make_Integer_Literal (Loc, Intval => Enumeration_Pos (Ent)))))); @@ -5000,7 +5098,7 @@ package body Exp_Ch3 is Make_Raise_Constraint_Error (Loc, Condition => Make_Identifier (Loc, Name_uF), Reason => CE_Invalid_Data), - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Make_Integer_Literal (Loc, -1))))); @@ -5013,7 +5111,7 @@ package body Exp_Ch3 is Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_List (Make_Others_Choice (Loc)), Statements => New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Make_Integer_Literal (Loc, -1))))); end if; @@ -5068,12 +5166,18 @@ package body Exp_Ch3 is ------------------------ procedure Freeze_Record_Type (N : Node_Id) is - Comp : Entity_Id; - Def_Id : constant Node_Id := Entity (N); - Predef_List : List_Id; - Type_Decl : constant Node_Id := Parent (Def_Id); - - Renamed_Eq : Node_Id := Empty; + Def_Id : constant Node_Id := Entity (N); + Type_Decl : constant Node_Id := Parent (Def_Id); + Comp : Entity_Id; + Comp_Typ : Entity_Id; + Has_Static_DT : Boolean := False; + Predef_List : List_Id; + + Flist : Entity_Id := Empty; + -- Finalization list allocated for the case of a type with anonymous + -- access components whose designated type is potentially controlled. + + Renamed_Eq : Node_Id := Empty; -- Could use some comments ??? Wrapper_Decl_List : List_Id := No_List; @@ -5082,11 +5186,11 @@ package body Exp_Ch3 is begin -- Build discriminant checking functions if not a derived type (for - -- derived types that are not tagged types, we always use the - -- discriminant checking functions of the parent type). However, for - -- untagged types the derivation may have taken place before the - -- parent was frozen, so we copy explicitly the discriminant checking - -- functions from the parent into the components of the derived type. + -- derived types that are not tagged types, always use the discriminant + -- checking functions of the parent type). However, for untagged types + -- the derivation may have taken place before the parent was frozen, so + -- we copy explicitly the discriminant checking functions from the + -- parent into the components of the derived type. if not Is_Derived_Type (Def_Id) or else Has_New_Non_Standard_Rep (Def_Id) @@ -5139,14 +5243,25 @@ package body Exp_Ch3 is Comp := First_Component (Def_Id); while Present (Comp) loop - if Has_Task (Etype (Comp)) then + Comp_Typ := Etype (Comp); + + if Has_Task (Comp_Typ) then Set_Has_Task (Def_Id); - elsif Has_Controlled_Component (Etype (Comp)) + elsif Has_Controlled_Component (Comp_Typ) or else (Chars (Comp) /= Name_uParent - and then Is_Controlled (Etype (Comp))) + and then Is_Controlled (Comp_Typ)) then Set_Has_Controlled_Component (Def_Id); + + elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type + and then Controlled_Type (Directly_Designated_Type (Comp_Typ)) + then + if No (Flist) then + Flist := Add_Final_Chain (Def_Id); + end if; + + Set_Associated_Final_Chain (Comp_Typ, Flist); end if; Next_Component (Comp); @@ -5159,31 +5274,28 @@ package body Exp_Ch3 is -- just use it. if Is_Tagged_Type (Def_Id) then + Has_Static_DT := + Static_Dispatch_Tables + and then Is_Library_Level_Tagged_Type (Def_Id); - if Is_CPP_Class (Def_Id) then - - -- Because of the new C++ ABI compatibility we now allow the - -- programmer to use the Ada tag (and in this case we must do - -- the normal expansion of the tag) + -- Add the _Tag component - if Etype (First_Component (Def_Id)) = RTE (RE_Tag) - and then Underlying_Type (Etype (Def_Id)) = Def_Id - then - Expand_Tagged_Root (Def_Id); - end if; + if Underlying_Type (Etype (Def_Id)) = Def_Id then + Expand_Tagged_Root (Def_Id); + end if; + if Is_CPP_Class (Def_Id) then Set_All_DT_Position (Def_Id); Set_Default_Constructor (Def_Id); - -- With CPP_Class types Make_DT does a minimum decoration of the - -- Access_Disp_Table list. + -- Create the tag entities with a minimum decoration if VM_Target = No_VM then - Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); + Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id)); end if; else - if not Static_Dispatch_Tables then + if not Has_Static_DT then -- Usually inherited primitives are not delayed but the first -- Ada extension of a CPP_Class is an exception since the @@ -5221,10 +5333,6 @@ package body Exp_Ch3 is end; end if; - if Underlying_Type (Etype (Def_Id)) = Def_Id then - Expand_Tagged_Root (Def_Id); - end if; - -- Unfreeze momentarily the type to add the predefined primitives -- operations. The reason we unfreeze is so that these predefined -- operations will indeed end up as primitive operations (which @@ -5280,12 +5388,22 @@ package body Exp_Ch3 is Expand_Record_Controller (Def_Id); end if; - -- Build the dispatch table. Suppress its creation when VM_Target - -- because the dispatching mechanism is handled internally by the - -- VMs. + -- Create and decorate the tags. Suppress their creation when + -- VM_Target because the dispatching mechanism is handled + -- internally by the VMs. if VM_Target = No_VM then - Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); + Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id)); + + -- Generate dispatch table of locally defined tagged type. + -- Dispatch tables of library level tagged types are built + -- later (see Analyze_Declarations). + + if VM_Target = No_VM + and then not Has_Static_DT + then + Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); + end if; end if; -- Make sure that the primitives Initialize, Adjust and Finalize @@ -5409,19 +5527,6 @@ package body Exp_Ch3 is if Present (Wrapper_Body_List) then Append_Freeze_Actions (Def_Id, Wrapper_Body_List); 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 not Restriction_Active (No_Dispatching_Calls) - and then Is_Concurrent_Record_Type (Def_Id) - and then Has_Abstract_Interfaces (Def_Id) - then - Append_Freeze_Actions (Def_Id, - Make_Select_Specific_Data_Table (Def_Id)); - end if; end if; end Freeze_Record_Type; @@ -5786,15 +5891,7 @@ package body Exp_Ch3 is or else Has_Controlled_Coextensions (Desig_Type) then - Set_Associated_Final_Chain (Def_Id, - Make_Defining_Identifier (Loc, - New_External_Name (Chars (Def_Id), 'L'))); - - Append_Freeze_Action (Def_Id, - Make_Object_Declaration (Loc, - Defining_Identifier => Associated_Final_Chain (Def_Id), - Object_Definition => - New_Reference_To (RTE (RE_List_Controller), Loc))); + Set_Associated_Final_Chain (Def_Id, Add_Final_Chain (Def_Id)); end if; end; @@ -6337,33 +6434,58 @@ package body Exp_Ch3 is ------------------------- procedure Init_Secondary_Tags - (Typ : Entity_Id; - Target : Node_Id; - Stmts_List : List_Id) + (Typ : Entity_Id; + Target : Node_Id; + Stmts_List : List_Id; + Fixed_Comps : Boolean := True; + Variable_Comps : Boolean := True) is - Loc : constant Source_Ptr := Sloc (Target); - ADT : Elmt_Id; - Full_Typ : Entity_Id; - AI_Tag_Comp : Entity_Id; + Loc : constant Source_Ptr := Sloc (Target); - Is_Synch_Typ : Boolean := False; - -- In case of non concurrent-record-types each parent-type has the - -- tags associated with the interface types that are not implemented - -- by the ancestors; concurrent-record-types have their whole list of - -- interface tags (and this case requires some special management). + procedure 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. procedure Initialize_Tag (Typ : Entity_Id; Iface : Entity_Id; - Tag_Comp : in out Entity_Id; + Tag_Comp : Entity_Id; Iface_Tag : Node_Id); -- Initialize the tag of the secondary dispatch table of Typ associated -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag. + -- Compiling under the CPP full ABI compatibility mode, if the ancestor + -- of Typ CPP tagged type we generate code to inherit the contents of + -- the dispatch table directly from the ancestor. - procedure Init_Secondary_Tags_Internal (Typ : Entity_Id); - -- Internal subprogram used to recursively climb to the root type. - -- We assume that all the primitives of the imported C++ class are - -- defined in the C side. + --------------------- + -- 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 -- @@ -6372,261 +6494,166 @@ package body Exp_Ch3 is procedure Initialize_Tag (Typ : Entity_Id; Iface : Entity_Id; - Tag_Comp : in out Entity_Id; + Tag_Comp : Entity_Id; Iface_Tag : Node_Id) is - Prev_E : Entity_Id; + Comp_Typ : Entity_Id; + Offset_To_Top_Comp : Entity_Id := Empty; begin - -- 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 pointer to the secondary DT associated with the + -- interface. - if Is_CPP_Class (Etype (Typ)) then + if not Is_Parent (Iface, Typ) then Append_To (Stmts_List, - Build_Inherit_Prims (Loc, - Old_Tag_Node => + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), + 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))))); + Expression => + New_Reference_To (Iface_Tag, Loc))); end if; - -- Initialize the pointer to the secondary DT associated with the - -- interface. - - Append_To (Stmts_List, - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => New_Reference_To (Tag_Comp, Loc)), - Expression => - New_Reference_To (Iface_Tag, Loc))); + -- Issue error if Set_Offset_To_Top is not available in a + -- configurable run-time environment. - -- If the ancestor is CPP_Class, nothing else to do here - - if Is_CPP_Class (Etype (Typ)) then - null; - - -- Otherwise, comment required ??? - - else - -- Issue error if Set_Offset_To_Top is not available in a - -- configurable run-time environment. - - if not RTE_Available (RE_Set_Offset_To_Top) then - Error_Msg_CRT ("abstract interface types", Typ); - return; - end if; + if not RTE_Available (RE_Set_Offset_To_Top) then + Error_Msg_CRT ("abstract interface types", Typ); + return; + end if; - -- We generate a different call when the parent of the type has - -- discriminants. + Comp_Typ := Scope (Tag_Comp); - if Typ /= Etype (Typ) - and then Has_Discriminants (Etype (Typ)) - then - pragma Assert - (Present (DT_Offset_To_Top_Func (Tag_Comp))); - - -- Generate: - -- Set_Offset_To_Top - -- (This => Init, - -- Interface_T => Iface'Tag, - -- Is_Constant => False, - -- Offset_Value => n, - -- Offset_Func => Fn'Address) - - Append_To (Stmts_List, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To - (RTE (RE_Set_Offset_To_Top), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Copy_Tree (Target), - Attribute_Name => Name_Address), + -- Initialize the entries of the table of interfaces. We generate a + -- different call when the parent of the type has variable size + -- components. - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To - (Node (First_Elmt (Access_Disp_Table (Iface))), - Loc)), + if Comp_Typ /= Etype (Comp_Typ) + and then Is_Variable_Size_Record (Etype (Comp_Typ)) + and then Chars (Tag_Comp) /= Name_uTag + then + pragma Assert + (Present (DT_Offset_To_Top_Func (Tag_Comp))); - New_Occurrence_Of (Standard_False, Loc), + -- Generate: + -- Set_Offset_To_Top + -- (This => Init, + -- Interface_T => Iface'Tag, + -- Is_Constant => False, + -- Offset_Value => n, + -- Offset_Func => Fn'Address) - Unchecked_Convert_To - (RTE (RE_Storage_Offset), - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => - New_Reference_To (Tag_Comp, Loc)), - Attribute_Name => Name_Position)), - - Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr), - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To - (DT_Offset_To_Top_Func (Tag_Comp), Loc), - Attribute_Name => Name_Address))))); + Append_To (Stmts_List, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Target), + Attribute_Name => Name_Address), - -- In this case the next component stores the value of the - -- offset to the top. + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Iface))), + Loc)), - Prev_E := Tag_Comp; - Next_Entity (Tag_Comp); - pragma Assert (Present (Tag_Comp)); + New_Occurrence_Of (Standard_False, Loc), - Append_To (Stmts_List, - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => New_Reference_To (Tag_Comp, Loc)), - Expression => + Unchecked_Convert_To + (RTE (RE_Storage_Offset), Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Copy_Tree (Target), Selector_Name => - New_Reference_To (Prev_E, Loc)), - Attribute_Name => Name_Position))); + New_Reference_To (Tag_Comp, Loc)), + Attribute_Name => Name_Position)), - -- Normal case: No discriminants in the parent type - - else - -- Generate: - -- Set_Offset_To_Top - -- (This => Init, - -- Interface_T => Iface'Tag, - -- Is_Constant => True, - -- Offset_Value => n, - -- Offset_Func => null); - - Append_To (Stmts_List, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To - (RTE (RE_Set_Offset_To_Top), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Copy_Tree (Target), - Attribute_Name => Name_Address), - - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To - (Node (First_Elmt - (Access_Disp_Table (Iface))), - Loc)), - - New_Occurrence_Of (Standard_True, Loc), - - Unchecked_Convert_To - (RTE (RE_Storage_Offset), - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => - New_Reference_To (Tag_Comp, Loc)), - Attribute_Name => Name_Position)), - - Make_Null (Loc)))); - end if; - end if; - end Initialize_Tag; - - ---------------------------------- - -- Init_Secondary_Tags_Internal -- - ---------------------------------- - - procedure Init_Secondary_Tags_Internal (Typ : Entity_Id) is - AI_Elmt : Elmt_Id; - - begin - -- Climb to the ancestor (if any) handling synchronized interface - -- derivations and private types + Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To + (DT_Offset_To_Top_Func (Tag_Comp), Loc), + Attribute_Name => Name_Address))))); - if Is_Concurrent_Record_Type (Typ) then - declare - Iface_List : constant List_Id := Abstract_Interface_List (Typ); + -- In this case the next component stores the value of the + -- offset to the top. - begin - if Is_Non_Empty_List (Iface_List) then - Init_Secondary_Tags_Internal (Etype (First (Iface_List))); - end if; - end; + Offset_To_Top_Comp := Next_Entity (Tag_Comp); + pragma Assert (Present (Offset_To_Top_Comp)); - elsif Present (Full_View (Etype (Typ))) then - if Full_View (Etype (Typ)) /= Typ then - Init_Secondary_Tags_Internal (Full_View (Etype (Typ))); - end if; + Append_To (Stmts_List, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Reference_To + (Offset_To_Top_Comp, Loc)), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Reference_To (Tag_Comp, Loc)), + Attribute_Name => Name_Position))); - elsif Etype (Typ) /= Typ then - Init_Secondary_Tags_Internal (Etype (Typ)); - end if; + -- Normal case: No discriminants in the parent type - if Is_Interface (Typ) then + else -- Generate: -- Set_Offset_To_Top -- (This => Init, -- Interface_T => Iface'Tag, -- Is_Constant => True, - -- Offset_Value => 0, - -- Offset_Func => null) + -- Offset_Value => n, + -- Offset_Func => null); Append_To (Stmts_List, Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc), + Name => New_Reference_To + (RTE (RE_Set_Offset_To_Top), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => New_Copy_Tree (Target), Attribute_Name => Name_Address), + Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To - (Node (First_Elmt (Access_Disp_Table (Typ))), + (Node (First_Elmt + (Access_Disp_Table (Iface))), Loc)), + New_Occurrence_Of (Standard_True, Loc), - Make_Integer_Literal (Loc, Uint_0), - Make_Null (Loc)))); - end if; - if Present (Abstract_Interfaces (Typ)) - and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) - then - if not Is_Synch_Typ then - AI_Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ)); - pragma Assert (Present (AI_Tag_Comp)); - end if; + Unchecked_Convert_To + (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Reference_To (Tag_Comp, Loc)), + Attribute_Name => Name_Position)), - AI_Elmt := First_Elmt (Abstract_Interfaces (Typ)); - while Present (AI_Elmt) loop - pragma Assert (Present (Node (ADT))); + Make_Null (Loc)))); + end if; + end Initialize_Tag; - Initialize_Tag - (Typ => Typ, - Iface => Node (AI_Elmt), - Tag_Comp => AI_Tag_Comp, - Iface_Tag => Node (ADT)); + -- Local variables - Next_Elmt (ADT); - AI_Tag_Comp := Next_Tag_Component (AI_Tag_Comp); - Next_Elmt (AI_Elmt); - end loop; - end if; - end Init_Secondary_Tags_Internal; + Full_Typ : Entity_Id; + Ifaces_List : Elist_Id; + Ifaces_Comp_List : Elist_Id; + Ifaces_Tag_List : Elist_Id; + Iface_Elmt : Elmt_Id; + Iface_Comp_Elmt : Elmt_Id; + Iface_Tag_Elmt : Elmt_Id; + Tag_Comp : Node_Id; + In_Variable_Pos : Boolean; -- Start of processing for Init_Secondary_Tags begin - -- Skip the first _Tag, which is the main tag of the tagged type. - -- Following tags correspond with abstract interfaces. - - ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); - -- Handle private types if Present (Full_View (Typ)) then @@ -6635,14 +6662,106 @@ package body Exp_Ch3 is Full_Typ := Typ; end if; - if Is_Concurrent_Record_Type (Typ) then - Is_Synch_Typ := True; - AI_Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ)); - end if; + Collect_Interfaces_Info + (Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List); - Init_Secondary_Tags_Internal (Full_Typ); + Iface_Elmt := First_Elmt (Ifaces_List); + Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List); + Iface_Tag_Elmt := First_Elmt (Ifaces_Tag_List); + while Present (Iface_Elmt) loop + Tag_Comp := Node (Iface_Comp_Elmt); + + -- 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. + + 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)); + + -- Otherwise we generate code to initialize the tag + + else + -- Check if the parent of the 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 (In_Variable_Pos and then Variable_Comps) + or else (not In_Variable_Pos and then Fixed_Comps) + then + Initialize_Tag (Full_Typ, + Iface => Node (Iface_Elmt), + Tag_Comp => Tag_Comp, + Iface_Tag => Node (Iface_Tag_Elmt)); + end if; + end if; + + Next_Elmt (Iface_Elmt); + Next_Elmt (Iface_Comp_Elmt); + Next_Elmt (Iface_Tag_Elmt); + end loop; end Init_Secondary_Tags; + ----------------------------- + -- Is_Variable_Size_Record -- + ----------------------------- + + function Is_Variable_Size_Record (E : Entity_Id) return Boolean is + Comp : Entity_Id; + Comp_Typ : Entity_Id; + Idx : Node_Id; + + begin + pragma Assert (Is_Record_Type (E)); + + Comp := First_Entity (E); + while Present (Comp) loop + Comp_Typ := Etype (Comp); + + if Is_Record_Type (Comp_Typ) then + + -- Recursive call if the record type has discriminants + + if Has_Discriminants (Comp_Typ) + and then Is_Variable_Size_Record (Comp_Typ) + then + return True; + end if; + + elsif Is_Array_Type (Comp_Typ) then + + -- Check if some index is initialized with a non-constant value + + Idx := First_Index (Comp_Typ); + while Present (Idx) loop + if Nkind (Idx) = N_Range then + if (Nkind (Low_Bound (Idx)) = N_Identifier + and then Present (Entity (Low_Bound (Idx))) + and then Ekind (Entity (Low_Bound (Idx))) /= E_Constant) + or else + (Nkind (High_Bound (Idx)) = N_Identifier + and then Present (Entity (High_Bound (Idx))) + and then Ekind (Entity (High_Bound (Idx))) /= E_Constant) + then + return True; + end if; + end if; + + Idx := Next_Index (Idx); + end loop; + end if; + + Next_Entity (Comp); + end loop; + + return False; + end Is_Variable_Size_Record; + ---------------------------------------- -- Make_Controlling_Function_Wrappers -- ---------------------------------------- @@ -6684,19 +6803,28 @@ package body Exp_Ch3 is -- Input constructed by the expander. The test for Comes_From_Source -- is needed to distinguish inherited operations from renamings -- (which also have Alias set). + -- The function may be abstract, or require_Overriding may be set -- for it, because tests for null extensions may already have reset - -- the Is_Abstract_Subprogram_Flag. - - if (Is_Abstract_Subprogram (Subp) - or else Requires_Overriding (Subp)) - and then Present (Alias (Subp)) - and then not Is_Abstract_Subprogram (Alias (Subp)) - and then not Comes_From_Source (Subp) - and then Ekind (Subp) = E_Function - and then Has_Controlling_Result (Subp) - and then not Is_Access_Type (Etype (Subp)) - and then not Is_TSS (Subp, TSS_Stream_Input) + -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not + -- set, functions that need wrappers are recognized by having an + -- alias that returns the parent type. + + if Comes_From_Source (Subp) + or else No (Alias (Subp)) + or else Ekind (Subp) /= E_Function + or else not Has_Controlling_Result (Subp) + or else Is_Access_Type (Etype (Subp)) + or else Is_Abstract_Subprogram (Alias (Subp)) + or else Is_TSS (Subp, TSS_Stream_Input) + then + goto Next_Prim; + + elsif Is_Abstract_Subprogram (Subp) + or else Requires_Overriding (Subp) + or else + (Is_Null_Extension (Etype (Subp)) + and then Etype (Alias (Subp)) /= Etype (Subp)) then Formal_List := No_List; Formal := First_Formal (Subp); @@ -6713,6 +6841,8 @@ package body Exp_Ch3 is Chars => Chars (Formal)), In_Present => In_Present (Parent (Formal)), Out_Present => Out_Present (Parent (Formal)), + Null_Exclusion_Present => + Null_Exclusion_Present (Parent (Formal)), Parameter_Type => New_Reference_To (Etype (Formal), Loc), Expression => @@ -6725,11 +6855,11 @@ package body Exp_Ch3 is Func_Spec := Make_Function_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, Chars (Subp)), - Parameter_Specifications => - Formal_List, - Result_Definition => + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Chars (Subp)), + Parameter_Specifications => Formal_List, + Result_Definition => New_Reference_To (Etype (Subp), Loc)); Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); @@ -6775,7 +6905,7 @@ package body Exp_Ch3 is end loop; Return_Stmt := - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Make_Extension_Aggregate (Loc, Ancestor_Part => @@ -6805,6 +6935,7 @@ package body Exp_Ch3 is (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec)); end if; + <> Next_Elmt (Prim_Elmt); end loop; end Make_Controlling_Function_Wrappers; @@ -6951,7 +7082,7 @@ package body Exp_Ch3 is Make_Implicit_If_Statement (E, Condition => Cond, Then_Statements => New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => New_Occurrence_Of (Standard_False, Loc)))); end if; end if; @@ -7021,6 +7152,8 @@ package body Exp_Ch3 is Chars => Chars (Formal)), In_Present => In_Present (Parent (Formal)), Out_Present => Out_Present (Parent (Formal)), + Null_Exclusion_Present => + Null_Exclusion_Present (Parent (Formal)), Parameter_Type => New_Reference_To (Etype (Formal), Loc), Expression => @@ -7591,7 +7724,7 @@ package body Exp_Ch3 is Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name_X), @@ -7614,7 +7747,7 @@ package body Exp_Ch3 is Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name_X), @@ -7741,12 +7874,12 @@ package body Exp_Ch3 is Make_Eq_If (Tag_Typ, Discriminant_Specifications (Def))); Append_List_To (Stmts, Make_Eq_Case (Tag_Typ, Comps)); Append_To (Stmts, - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => New_Reference_To (Standard_True, Loc))); else Append_To (Stmts, - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Expand_Record_Equality (Tag_Typ, Typ => Tag_Typ, diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index 20136be..64858c0 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -111,12 +111,17 @@ package Exp_Ch3 is -- since it would confuse any remaining processing of the freeze node. procedure Init_Secondary_Tags - (Typ : Entity_Id; - Target : Node_Id; - Stmts_List : List_Id); - -- Ada 2005 (AI-251): Initialize the tags of all the secondary tables - -- associated with the abstract interfaces of Typ. The generated code - -- referencing tag fields of Target is appended to Stmts_List. + (Typ : Entity_Id; + Target : Node_Id; + Stmts_List : List_Id; + Fixed_Comps : Boolean := True; + Variable_Comps : Boolean := True); + -- Ada 2005 (AI-251): Initialize the tags of the secondary dispatch tables + -- of Typ. The generated code referencing tag fields of Target is appended + -- to Stmts_List. If Fixed_Comps is True then the tag components located at + -- fixed positions of Target are initialized; if Variable_Comps is True + -- then tags components located at variable positions of Target are + -- initialized. function Needs_Simple_Initialization (T : Entity_Id) return Boolean; -- Certain types need initialization even though there is no specific diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 4622110..077240c 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -161,6 +161,29 @@ package body Sem_Type is pragma Warnings (Off, All_Overloads); -- Debugging procedure: list full contents of Overloads table + function Binary_Op_Interp_Has_Abstract_Op + (N : Node_Id; + E : Entity_Id) return Entity_Id; + -- Given the node and entity of a binary operator, determine whether the + -- actuals of E contain an abstract interpretation with regards to the + -- types of their corresponding formals. Return the abstract operation or + -- Empty. + + function Function_Interp_Has_Abstract_Op + (N : Node_Id; + E : Entity_Id) return Entity_Id; + -- Given the node and entity of a function call, determine whether the + -- actuals of E contain an abstract interpretation with regards to the + -- types of their corresponding formals. Return the abstract operation or + -- Empty. + + function Has_Abstract_Op + (N : Node_Id; + Typ : Entity_Id) return Entity_Id; + -- Subsidiary routine to Binary_Op_Interp_Has_Abstract_Op and Function_ + -- Interp_Has_Abstract_Op. Determine whether an overloaded node has an + -- abstract interpretation which yields type Typ. + procedure New_Interps (N : Node_Id); -- Initialize collection of interpretations for the given node, which is -- either an overloaded entity, or an operation whose arguments have @@ -183,10 +206,10 @@ package body Sem_Type is is Vis_Type : Entity_Id; - procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id); - -- Add one interpretation to node. Node is already known to be - -- overloaded. Add new interpretation if not hidden by previous - -- one, and remove previous one if hidden by new one. + procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id); + -- Add one interpretation to an overloaded node. Add a new entry if + -- not hidden by previous one, and remove previous one if hidden by + -- new one. function Is_Universal_Operation (Op : Entity_Id) return Boolean; -- True if the entity is a predefined operator and the operands have @@ -196,12 +219,26 @@ package body Sem_Type is -- Add_Entry -- --------------- - procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is - Index : Interp_Index; - It : Interp; + procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is + Abstr_Op : Entity_Id := Empty; + I : Interp_Index; + It : Interp; + + -- Start of processing for Add_Entry begin - Get_First_Interp (N, Index, It); + -- Find out whether the new entry references interpretations that + -- are abstract or disabled by abstract operators. + + if Ada_Version >= Ada_05 then + if Nkind (N) in N_Binary_Op then + Abstr_Op := Binary_Op_Interp_Has_Abstract_Op (N, Name); + elsif Nkind (N) = N_Function_Call then + Abstr_Op := Function_Interp_Has_Abstract_Op (N, Name); + end if; + end if; + + Get_First_Interp (N, I, It); while Present (It.Nam) loop -- A user-defined subprogram hides another declared at an outer @@ -254,7 +291,7 @@ package body Sem_Type is end if; else - All_Interp.Table (Index).Nam := Name; + All_Interp.Table (I).Nam := Name; return; end if; @@ -268,15 +305,12 @@ package body Sem_Type is -- Otherwise keep going else - Get_Next_Interp (Index, It); + Get_Next_Interp (I, It); end if; end loop; - -- On exit, enter new interpretation. The context, or a preference - -- rule, will resolve the ambiguity on the second pass. - - All_Interp.Table (All_Interp.Last) := (Name, Typ); + All_Interp.Table (All_Interp.Last) := (Name, Typ, Abstr_Op); All_Interp.Increment_Last; All_Interp.Table (All_Interp.Last) := No_Interp; end Add_Entry; @@ -501,6 +535,27 @@ package body Sem_Type is end loop; end All_Overloads; + -------------------------------------- + -- Binary_Op_Interp_Has_Abstract_Op -- + -------------------------------------- + + function Binary_Op_Interp_Has_Abstract_Op + (N : Node_Id; + E : Entity_Id) return Entity_Id + is + Abstr_Op : Entity_Id; + E_Left : constant Node_Id := First_Formal (E); + E_Right : constant Node_Id := Next_Formal (E_Left); + + begin + Abstr_Op := Has_Abstract_Op (Left_Opnd (N), Etype (E_Left)); + if Present (Abstr_Op) then + return Abstr_Op; + end if; + + return Has_Abstract_Op (Right_Opnd (N), Etype (E_Right)); + end Binary_Op_Interp_Has_Abstract_Op; + --------------------- -- Collect_Interps -- --------------------- @@ -567,7 +622,8 @@ package body Sem_Type is and then In_Instance and then not Is_Inherited_Operation (H) then - All_Interp.Table (All_Interp.Last) := (H, Etype (H)); + All_Interp.Table (All_Interp.Last) := + (H, Etype (H), Empty); All_Interp.Increment_Last; All_Interp.Table (All_Interp.Last) := No_Interp; goto Next_Homograph; @@ -821,9 +877,11 @@ package body Sem_Type is return True; -- If the expected type is an anonymous access, the designated type must - -- cover that of the expression. + -- cover that of the expression. Use the base type for this check: even + -- though access subtypes are rare in sources, they are generated for + -- actuals in instantiations. - elsif Ekind (T1) = E_Anonymous_Access_Type + elsif Ekind (BT1) = E_Anonymous_Access_Type and then Is_Access_Type (T2) and then Covers (Designated_Type (T1), Designated_Type (T2)) then @@ -987,10 +1045,11 @@ package body Sem_Type is elsif From_With_Type (T1) then -- If the expected type is the non-limited view of a type, the - -- expression may have the limited view. + -- expression may have the limited view. If that one in turn is + -- incomplete, get full view if available. if Is_Incomplete_Type (T1) then - return Covers (Non_Limited_View (T1), T2); + return Covers (Get_Full_View (Non_Limited_View (T1)), T2); elsif Ekind (T1) = E_Class_Wide_Type then return @@ -1006,7 +1065,7 @@ package body Sem_Type is -- verify that the context type is the non-limited view. if Is_Incomplete_Type (T2) then - return Covers (T1, Non_Limited_View (T2)); + return Covers (T1, Get_Full_View (Non_Limited_View (T2))); elsif Ekind (T2) = E_Class_Wide_Type then return @@ -1471,7 +1530,7 @@ package body Sem_Type is -- then we must check whether the user-defined entity hides the prede- -- fined one. - if Chars (Nam1) in Any_Operator_Name + if Chars (Nam1) in Any_Operator_Name and then Standard_Operator then if Typ = Universal_Integer @@ -1677,7 +1736,7 @@ package body Sem_Type is end if; end if; - -- an implicit concatenation operator on a string type cannot be + -- An implicit concatenation operator on a string type cannot be -- disambiguated from the predefined concatenation. This can only -- happen with concatenation of string literals. @@ -1687,7 +1746,7 @@ package body Sem_Type is then return No_Interp; - -- If the user-defined operator is in an open scope, or in the scope + -- If the user-defined operator is in an open scope, or in the scope -- of the resulting type, or given by an expanded name that names its -- scope, it hides the predefined operator for the type. Exponentiation -- has to be special-cased because the implicit operator does not have @@ -1904,9 +1963,48 @@ package body Sem_Type is else return Specific_Type (T, Etype (R)); end if; - end Find_Unique_Type; + ------------------------------------- + -- Function_Interp_Has_Abstract_Op -- + ------------------------------------- + + function Function_Interp_Has_Abstract_Op + (N : Node_Id; + E : Entity_Id) return Entity_Id + is + Abstr_Op : Entity_Id; + Act : Node_Id; + Act_Parm : Node_Id; + Form_Parm : Node_Id; + + begin + if Is_Overloaded (N) then + Act_Parm := First_Actual (N); + Form_Parm := First_Formal (E); + while Present (Act_Parm) + and then Present (Form_Parm) + loop + Act := Act_Parm; + + if Nkind (Act) = N_Parameter_Association then + Act := Explicit_Actual_Parameter (Act); + end if; + + Abstr_Op := Has_Abstract_Op (Act, Etype (Form_Parm)); + + if Present (Abstr_Op) then + return Abstr_Op; + end if; + + Next_Actual (Act_Parm); + Next_Formal (Form_Parm); + end loop; + end if; + + return Empty; + end Function_Interp_Has_Abstract_Op; + ---------------------- -- Get_First_Interp -- ---------------------- @@ -1916,8 +2014,8 @@ package body Sem_Type is I : out Interp_Index; It : out Interp) is - Map_Ptr : Int; Int_Ind : Interp_Index; + Map_Ptr : Int; O_N : Node_Id; begin @@ -2030,6 +2128,34 @@ package body Sem_Type is end if; end Has_Compatible_Type; + --------------------- + -- Has_Abstract_Op -- + --------------------- + + function Has_Abstract_Op + (N : Node_Id; + Typ : Entity_Id) return Entity_Id + is + I : Interp_Index; + It : Interp; + + begin + if Is_Overloaded (N) then + Get_First_Interp (N, I, It); + while Present (It.Nam) loop + if Present (It.Abstract_Op) + and then Etype (It.Abstract_Op) = Typ + then + return It.Abstract_Op; + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + + return Empty; + end Has_Abstract_Op; + ---------- -- Hash -- ---------- @@ -2384,18 +2510,17 @@ package body Sem_Type is then return False; - else return - Is_Numeric_Type (T) - and then not In_Open_Scopes (Scope (T)) - and then not Is_Potentially_Use_Visible (T) - and then not In_Use (T) - and then not In_Use (Scope (T)) - and then + else + return Is_Numeric_Type (T) + and then not In_Open_Scopes (Scope (T)) + and then not Is_Potentially_Use_Visible (T) + and then not In_Use (T) + and then not In_Use (Scope (T)) + and then (Nkind (Orig_Node) /= N_Function_Call or else Nkind (Name (Orig_Node)) /= N_Expanded_Name or else Entity (Prefix (Name (Orig_Node))) /= Scope (T)) - - and then not In_Instance; + and then not In_Instance; end if; end Is_Invisible_Operator; @@ -2866,6 +2991,15 @@ package body Sem_Type is end if; end Specific_Type; + --------------------- + -- Set_Abstract_Op -- + --------------------- + + procedure Set_Abstract_Op (I : Interp_Index; V : Entity_Id) is + begin + All_Interp.Table (I).Abstract_Op := V; + end Set_Abstract_Op; + ----------------------- -- Valid_Boolean_Arg -- ----------------------- @@ -2956,9 +3090,9 @@ package body Sem_Type is Get_First_Interp (N, I, It); Write_Str ("Overloaded entity "); Write_Eol; - Write_Str (" Name Type"); + Write_Str (" Name Type Abstract Op"); Write_Eol; - Write_Str ("==============================="); + Write_Str ("==============================================="); Write_Eol; Nam := It.Nam; @@ -2970,6 +3104,14 @@ package body Sem_Type is Write_Int (Int (It.Typ)); Write_Str (" "); Write_Name (Chars (It.Typ)); + + if Present (It.Abstract_Op) then + Write_Str (" "); + Write_Int (Int (It.Abstract_Op)); + Write_Str (" "); + Write_Name (Chars (It.Abstract_Op)); + end if; + Write_Eol; Get_Next_Interp (I, It); Nam := It.Nam; diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads index 172e146..0cc5e5d 100644 --- a/gcc/ada/sem_type.ads +++ b/gcc/ada/sem_type.ads @@ -41,13 +41,13 @@ package Sem_Type is -- the visibility rules find such a potential ambiguity, the set of -- possible interpretations must be attached to the identifier, and -- overload resolution must be performed over the innermost enclosing - -- complete context. At the end of the resolution, either a single + -- complete context. At the end of the resolution, either a single -- interpretation is found for all identifiers in the context, or else a -- type error (invalid type or ambiguous reference) must be signalled. -- The set of interpretations of a given name is stored in a data structure -- that is separate from the syntax tree, because it corresponds to - -- transient information. The interpretations themselves are stored in + -- transient information. The interpretations themselves are stored in -- table All_Interp. A mapping from tree nodes to sets of interpretations -- called Interp_Map, is maintained by the overload resolution routines. -- Both these structures are initialized at the beginning of every complete @@ -64,11 +64,15 @@ package Sem_Type is -- only one interpretation is present anyway. type Interp is record - Nam : Entity_Id; - Typ : Entity_Id; + Nam : Entity_Id; + Typ : Entity_Id; + Abstract_Op : Entity_Id := Empty; end record; - No_Interp : constant Interp := (Empty, Empty); + -- Entity Abstract_Op is set to the abstract operation which potentially + -- disables the interpretation in Ada 2005 mode. + + No_Interp : constant Interp := (Empty, Empty, Empty); subtype Interp_Index is Int; @@ -122,8 +126,9 @@ package Sem_Type is -- E is an overloadable entity, and T is its type. For constructs such -- as indexed expressions, the caller sets E equal to T, because the -- overloading comes from other fields, and the node itself has no name - -- to resolve. Add_One_Interp includes the semantic processing to deal - -- with adding entries that hide one another etc. + -- to resolve. Hidden denotes whether an interpretation has been disabled + -- by an abstract operator. Add_One_Interp includes semantic processing to + -- deal with adding entries that hide one another etc. -- For operators, the legality of the operation depends on the visibility -- of T and its scope. If the operator is an equality or comparison, T is @@ -172,7 +177,7 @@ package Sem_Type is I1, I2 : Interp_Index; Typ : Entity_Id) return Interp; - -- If more than one interpretation of a name in a call is legal, apply + -- If more than one interpretation of a name in a call is legal, apply -- preference rules (universal types first) and operator visibility in -- order to remove ambiguity. I1 and I2 are the first two interpretations -- that are compatible with the context, but there may be others. @@ -216,19 +221,22 @@ package Sem_Type is -- interpretations is universal, choose the non-universal one. If either -- node is overloaded, find single common interpretation. - function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean; - -- Checks whether T1 is any subtype of T2 directly or indirectly. Applies - -- only to scalar subtypes ??? - function Is_Ancestor (T1, T2 : Entity_Id) return Boolean; -- T1 is a tagged type (not class-wide). Verify that it is one of the -- ancestors of type T2 (which may or not be class-wide) - function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean; + function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean; + -- Checks whether T1 is any subtype of T2 directly or indirectly. Applies + -- only to scalar subtypes ??? + + function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean; -- Used to resolve subprograms renaming operators, and calls to user -- defined operators. Determines whether a given operator Op, matches -- a specification, New_S. + procedure Set_Abstract_Op (I : Interp_Index; V : Entity_Id); + -- Set the abstract operation field of an interpretation + function Valid_Comparison_Arg (T : Entity_Id) return Boolean; -- A valid argument to an ordering operator must be a discrete type, a -- real type, or a one dimensional array with a discrete component type. -- 2.7.4