Skip to content

R
riscv-gcc-1
Commit 04df6250 by Thomas Quinot Committed by Arnaud Charlet
Options

exp_ch3.ads, [...] (Add_Final_Chain): New subprogram. 

2007-08-14  Thomas Quinot  <quinot@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>
	    Robert Dewar  <dewar@adacore.com>

	* 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.

From-SVN: r127417
parent 3e8ee849
Showing with 652 additions and 364 deletions
gcc/ada/exp_ch3.adb
...@@ -73,6 +73,10 @@ package body Exp_Ch3 is ...@@ -73,6 +73,10 @@ package body Exp_Ch3 is
-- Local Subprograms -- -- 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); procedure Adjust_Discriminants (Rtype : Entity_Id);
-- This is used when freezing a record type. It attempts to construct -- This is used when freezing a record type. It attempts to construct
-- more restrictive subtypes for discriminants so that the max size of -- more restrictive subtypes for discriminants so that the max size of
...@@ -103,7 +107,7 @@ package body Exp_Ch3 is ...@@ -103,7 +107,7 @@ package body Exp_Ch3 is
function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id; function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id;
-- This function builds a static aggregate that can serve as the initial -- This function builds a static aggregate that can serve as the initial
-- value for a record type whose components are scalar and initialized -- 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 -- 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 -- be achieved by using a copy of the aggregate as an initial value, thus
-- removing the implicit call that would otherwise constitute elaboration -- removing the implicit call that would otherwise constitute elaboration
...@@ -206,6 +210,9 @@ package body Exp_Ch3 is ...@@ -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 -- 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. -- 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 function Make_Eq_Case
(E : Entity_Id; (E : Entity_Id;
CL : Node_Id; CL : Node_Id;
...@@ -341,6 +348,28 @@ package body Exp_Ch3 is ...@@ -341,6 +348,28 @@ package body Exp_Ch3 is
-- the generation of these operations, as a useful optimization or for -- the generation of these operations, as a useful optimization or for
-- certification purposes. -- 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 -- -- Adjust_Discriminants --
-------------------------- --------------------------
...@@ -874,7 +903,7 @@ package body Exp_Ch3 is ...@@ -874,7 +903,7 @@ package body Exp_Ch3 is
end loop; end loop;
Return_Node := Return_Node :=
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => Name =>
...@@ -884,7 +913,7 @@ package body Exp_Ch3 is ...@@ -884,7 +913,7 @@ package body Exp_Ch3 is
else else
Return_Node := Return_Node :=
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
New_Reference_To (Standard_False, Loc)); New_Reference_To (Standard_False, Loc));
end if; end if;
...@@ -898,7 +927,7 @@ package body Exp_Ch3 is ...@@ -898,7 +927,7 @@ package body Exp_Ch3 is
Set_Discrete_Choices (Case_Alt_Node, Choice_List); Set_Discrete_Choices (Case_Alt_Node, Choice_List);
Return_Node := Return_Node :=
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
New_Reference_To (Standard_True, Loc)); New_Reference_To (Standard_True, Loc));
...@@ -1762,7 +1791,7 @@ package body Exp_Ch3 is ...@@ -1762,7 +1791,7 @@ package body Exp_Ch3 is
if Ada_Version >= Ada_05 if Ada_Version >= Ada_05
and then Can_Never_Be_Null (Etype (Id)) -- Lhs and then Can_Never_Be_Null (Etype (Id)) -- Lhs
then then
if Nkind (Exp) = N_Null then if Known_Null (Exp) then
return New_List ( return New_List (
Make_Raise_Constraint_Error (Sloc (Exp), Make_Raise_Constraint_Error (Sloc (Exp),
Reason => CE_Null_Not_Allowed)); Reason => CE_Null_Not_Allowed));
...@@ -1996,85 +2025,63 @@ package body Exp_Ch3 is ...@@ -1996,85 +2025,63 @@ package body Exp_Ch3 is
----------------------------------- -----------------------------------
procedure Build_Offset_To_Top_Functions 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); procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id);
-- Internal subprogram used to recursively traverse all the ancestors -- 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_Internal (Typ : Entity_Id) is procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id) is
begin Body_Node : Node_Id;
-- Climb to the ancestor (if any) handling synchronized interface Func_Id : Entity_Id;
-- derivations and private types Spec_Node : Node_Id;
if Is_Concurrent_Record_Type (Typ) then
declare
Iface_List : constant List_Id :=
Abstract_Interface_List (Typ);
begin begin
if Is_Non_Empty_List (Iface_List) then
Build_Offset_To_Top_Internal (Etype (First (Iface_List)));
end if;
end;
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;
elsif Etype (Typ) /= Typ then
Build_Offset_To_Top_Internal (Etype (Typ));
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 := Func_Id :=
Make_Defining_Identifier (Loc, Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('F')); Chars => New_Internal_Name ('F'));
Set_DT_Offset_To_Top_Func (E, Func_Id); Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id);
-- Generate
-- function Fxx (O : in Rec_Typ) return Storage_Offset;
Spec_Node := New_Node (N_Function_Specification, Loc); Spec_Node := New_Node (N_Function_Specification, Loc);
Set_Defining_Unit_Name (Spec_Node, Func_Id); Set_Defining_Unit_Name (Spec_Node, Func_Id);
Set_Parameter_Specifications (Spec_Node, New_List ( Set_Parameter_Specifications (Spec_Node, New_List (
Make_Parameter_Specification (Loc, Make_Parameter_Specification (Loc,
Defining_Identifier => Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
Make_Defining_Identifier (Loc, Name_uO),
In_Present => True, In_Present => True,
Parameter_Type => New_Reference_To (Typ, Loc)))); Parameter_Type => New_Reference_To (Rec_Type, Loc))));
Set_Result_Definition (Spec_Node, Set_Result_Definition (Spec_Node,
New_Reference_To (RTE (RE_Storage_Offset), Loc)); 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_Specification (Body_Node, Spec_Node);
Set_Declarations (Body_Node, New_List); Set_Declarations (Body_Node, New_List);
Set_Handled_Statement_Sequence (Body_Node, Set_Handled_Statement_Sequence (Body_Node,
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List ( Statements => New_List (
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Prefix =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Prefix => Make_Identifier (Loc, Name_uO),
Name_uO),
Selector_Name => New_Reference_To Selector_Name => New_Reference_To
(E, Loc)), (Iface_Comp, Loc)),
Attribute_Name => Name_Position))))); Attribute_Name => Name_Position)))));
Set_Ekind (Func_Id, E_Function); Set_Ekind (Func_Id, E_Function);
...@@ -2088,44 +2095,50 @@ package body Exp_Ch3 is ...@@ -2088,44 +2095,50 @@ package body Exp_Ch3 is
Analyze (Body_Node); Analyze (Body_Node);
Append_Freeze_Action (Rec_Type, Body_Node); Append_Freeze_Action (Rec_Type, Body_Node);
end if; end Build_Offset_To_Top_Function;
Next_Elmt (ADT); -- Local variables
end if;
Next_Entity (E); Ifaces_List : Elist_Id;
end loop; Ifaces_Comp_List : Elist_Id;
end if; Ifaces_Tag_List : Elist_Id;
end Build_Offset_To_Top_Internal; Iface_Elmt : Elmt_Id;
Comp_Elmt : Elmt_Id;
-- Start of processing for Build_Offset_To_Top_Functions -- Start of processing for Build_Offset_To_Top_Functions
begin begin
if Is_Concurrent_Record_Type (Rec_Type) -- Offset_To_Top_Functions are built only for derivations of types
and then Is_Empty_List (Abstract_Interface_List (Rec_Type)) -- with discriminants that cover interface types.
then
return;
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 not Has_Discriminants (Etype (Rec_Type))
or else No (Abstract_Interfaces (Rec_Type))
or else Is_Empty_Elmt_List (Abstract_Interfaces (Rec_Type))
then then
return; return;
end if; end if;
-- Skip the first _Tag, which is the main tag of the tagged type. Collect_Interfaces_Info (Rec_Type,
-- Following tags correspond with abstract interfaces. 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 -- If the interface is a parent of Rec_Type it shares the primary
Build_Offset_To_Top_Internal (Full_View (Rec_Type)); -- dispatch table and hence there is no need to build the function
else
Build_Offset_To_Top_Internal (Rec_Type); if not Is_Parent (Node (Iface_Elmt), Rec_Type) then
Build_Offset_To_Top_Function (Iface_Comp => Node (Comp_Elmt));
end if; end if;
Next_Elmt (Iface_Elmt);
Next_Elmt (Comp_Elmt);
end loop;
end Build_Offset_To_Top_Functions; end Build_Offset_To_Top_Functions;
-------------------------- --------------------------
...@@ -2139,7 +2152,7 @@ package body Exp_Ch3 is ...@@ -2139,7 +2152,7 @@ package body Exp_Ch3 is
Proc_Spec_Node : Node_Id; Proc_Spec_Node : Node_Id;
Body_Stmts : List_Id; Body_Stmts : List_Id;
Record_Extension_Node : Node_Id; Record_Extension_Node : Node_Id;
Init_Tag : Node_Id; Init_Tags_List : List_Id;
begin begin
Body_Stmts := New_List; Body_Stmts := New_List;
...@@ -2241,7 +2254,9 @@ package body Exp_Ch3 is ...@@ -2241,7 +2254,9 @@ package body Exp_Ch3 is
and then VM_Target = No_VM and then VM_Target = No_VM
and then not No_Run_Time_Mode and then not No_Run_Time_Mode
then then
Init_Tag := -- Initialize the primary tag
Init_Tags_List := New_List (
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => Name =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
...@@ -2251,7 +2266,23 @@ package body Exp_Ch3 is ...@@ -2251,7 +2266,23 @@ package body Exp_Ch3 is
Expression => Expression =>
New_Reference_To 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 -- The tag must be inserted before the assignments to other
-- components, because the initial value of the component may -- components, because the initial value of the component may
...@@ -2266,12 +2297,10 @@ package body Exp_Ch3 is ...@@ -2266,12 +2297,10 @@ package body Exp_Ch3 is
-- after the calls to initialize the parent. -- after the calls to initialize the parent.
if not Is_CPP_Class (Etype (Rec_Type)) then if not Is_CPP_Class (Etype (Rec_Type)) then
Init_Tag := Prepend_To (Body_Stmts,
Make_If_Statement (Loc, Make_If_Statement (Loc,
Condition => New_Occurrence_Of (Set_Tag, Loc), Condition => New_Occurrence_Of (Set_Tag, Loc),
Then_Statements => New_List (Init_Tag)); Then_Statements => Init_Tags_List));
Prepend_To (Body_Stmts, Init_Tag);
-- CPP_Class: In this case the dispatch table of the parent was -- 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 -- built in the C++ side and we copy the table of the parent to
...@@ -2279,12 +2308,12 @@ package body Exp_Ch3 is ...@@ -2279,12 +2308,12 @@ package body Exp_Ch3 is
else else
declare declare
Nod : Node_Id := First (Body_Stmts); Nod : Node_Id;
New_N : Node_Id;
begin begin
-- We assume the first init_proc call is for the parent -- We assume the first init_proc call is for the parent
Nod := First (Body_Stmts);
while Present (Next (Nod)) while Present (Next (Nod))
and then (Nkind (Nod) /= N_Procedure_Call_Statement and then (Nkind (Nod) /= N_Procedure_Call_Statement
or else not Is_Init_Proc (Name (Nod))) or else not Is_Init_Proc (Name (Nod)))
...@@ -2299,11 +2328,14 @@ package body Exp_Ch3 is ...@@ -2299,11 +2328,14 @@ package body Exp_Ch3 is
-- _init._tag := new_dt; -- _init._tag := new_dt;
-- end if; -- end if;
New_N := Prepend_To (Init_Tags_List,
Build_Inherit_Prims (Loc, Build_Inherit_Prims (Loc,
Typ => Rec_Type,
Old_Tag_Node => Old_Tag_Node =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit), Prefix =>
Make_Identifier (Loc,
Chars => Name_uInit),
Selector_Name => Selector_Name =>
New_Reference_To New_Reference_To
(First_Tag_Component (Rec_Type), Loc)), (First_Tag_Component (Rec_Type), Loc)),
...@@ -2313,14 +2345,12 @@ package body Exp_Ch3 is ...@@ -2313,14 +2345,12 @@ package body Exp_Ch3 is
Loc), Loc),
Num_Prims => Num_Prims =>
UI_To_Int 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, Make_If_Statement (Loc,
Condition => New_Occurrence_Of (Set_Tag, Loc), Condition => New_Occurrence_Of (Set_Tag, Loc),
Then_Statements => New_List (New_N, Init_Tag)); Then_Statements => Init_Tags_List));
Insert_After (Nod, Init_Tag);
-- We have inherited table of the parent from the CPP side. -- We have inherited table of the parent from the CPP side.
-- Now we fill the slots associated with Ada primitives. -- Now we fill the slots associated with Ada primitives.
...@@ -2343,7 +2373,7 @@ package body Exp_Ch3 is ...@@ -2343,7 +2373,7 @@ package body Exp_Ch3 is
then then
Register_Primitive (Loc, Register_Primitive (Loc,
Prim => Prim, Prim => Prim,
Ins_Nod => Init_Tag); Ins_Nod => Last (Init_Tags_List));
end if; end if;
Next_Elmt (E); Next_Elmt (E);
...@@ -2352,18 +2382,31 @@ package body Exp_Ch3 is ...@@ -2352,18 +2382,31 @@ package body Exp_Ch3 is
end; end;
end if; end if;
-- Ada 2005 (AI-251): Initialization of all the tags corresponding -- Ada 2005 (AI-251): Initialize the secondary tag components
-- with abstract interfaces -- 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 if Ada_Version >= Ada_05
and then Ada_Version >= Ada_05
and then not Is_Interface (Rec_Type) and then not Is_Interface (Rec_Type)
and then Has_Abstract_Interfaces (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 then
Init_Tags_List := New_List;
Init_Secondary_Tags Init_Secondary_Tags
(Typ => Rec_Type, (Typ => Rec_Type,
Target => Make_Identifier (Loc, Name_uInit), Target => Make_Identifier (Loc, Name_uInit),
Stmts_List => Body_Stmts); 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;
end if; end if;
...@@ -3498,7 +3541,7 @@ package body Exp_Ch3 is ...@@ -3498,7 +3541,7 @@ package body Exp_Ch3 is
Left_Opnd => New_Reference_To (A, Loc), Left_Opnd => New_Reference_To (A, Loc),
Right_Opnd => New_Reference_To (B, Loc)), Right_Opnd => New_Reference_To (B, Loc)),
Then_Statements => New_List ( Then_Statements => New_List (
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_False, Loc))))); Expression => New_Occurrence_Of (Standard_False, Loc)))));
-- Generate component-by-component comparison. Note that we must -- Generate component-by-component comparison. Note that we must
...@@ -3522,7 +3565,7 @@ package body Exp_Ch3 is ...@@ -3522,7 +3565,7 @@ package body Exp_Ch3 is
end if; end if;
Append_To (Stmts, Append_To (Stmts,
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => New_Reference_To (Standard_True, Loc))); Expression => New_Reference_To (Standard_True, Loc)));
Set_TSS (Typ, F); Set_TSS (Typ, F);
...@@ -3944,6 +3987,33 @@ package body Exp_Ch3 is ...@@ -3944,6 +3987,33 @@ package body Exp_Ch3 is
return; return;
end if; 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 -- Make shared memory routines for shared passive variable
if Is_Shared_Passive (Def_Id) then if Is_Shared_Passive (Def_Id) then
...@@ -3960,10 +4030,15 @@ package body Exp_Ch3 is ...@@ -3960,10 +4030,15 @@ package body Exp_Ch3 is
Build_Master_Entity (Def_Id); Build_Master_Entity (Def_Id);
end if; end if;
-- Build a list controller for declarations of the form -- Build a list controller for declarations where the type is anonymous
-- Obj : access Some_Type [:= Expression]; -- 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 Is_Controlled (Directly_Designated_Type (Typ))
and then No (Associated_Final_Chain (Typ)) and then No (Associated_Final_Chain (Typ))
then then
...@@ -4040,12 +4115,26 @@ package body Exp_Ch3 is ...@@ -4040,12 +4115,26 @@ package body Exp_Ch3 is
-- Call type initialization procedure if there is one. We build the -- Call type initialization procedure if there is one. We build the
-- call and put it immediately after the object declaration, so that -- call and put it immediately after the object declaration, so that
-- it will be expanded in the usual manner. Note that this will -- it will be expanded in the usual manner. Note that this will
-- result in proper handling of defaulted discriminants. The call -- result in proper handling of defaulted discriminants.
-- to the Init_Proc is suppressed if No_Initialization is set.
-- Need call if there is a base init proc
if Has_Non_Null_Base_Init_Proc (Typ) if Has_Non_Null_Base_Init_Proc (Typ)
-- Suppress call if No_Initialization set on declaration
and then not No_Initialization (N) and then not No_Initialization (N)
-- Suppress call for special case of value type for VM
and then not Is_Value_Type (Typ) 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 then
-- The call to the initialization procedure does NOT freeze the -- The call to the initialization procedure does NOT freeze the
-- object being initialized. This is because the call is not a -- object being initialized. This is because the call is not a
...@@ -4556,9 +4645,9 @@ package body Exp_Ch3 is ...@@ -4556,9 +4645,9 @@ package body Exp_Ch3 is
-- Ada 2005 (AI-251): The following condition covers secondary -- Ada 2005 (AI-251): The following condition covers secondary
-- tags but also the adjacent component contanining the offset -- tags but also the adjacent component contanining the offset
-- to the base of the object (component generated if the parent -- to the base of the object (component generated if the parent
-- has discriminants ---see Add_Interface_Tag_Components). This -- has discriminants --- see Add_Interface_Tag_Components).
-- is required to avoid the addition of the controller between -- This is required to avoid the addition of the controller
-- the secondary tag and its adjacent component. -- between the secondary tag and its adjacent component.
or else Present or else Present
(Related_Interface (Related_Interface
...@@ -4696,6 +4785,7 @@ package body Exp_Ch3 is ...@@ -4696,6 +4785,7 @@ package body Exp_Ch3 is
procedure Freeze_Array_Type (N : Node_Id) is procedure Freeze_Array_Type (N : Node_Id) is
Typ : constant Entity_Id := Entity (N); Typ : constant Entity_Id := Entity (N);
Comp_Typ : constant Entity_Id := Component_Type (Typ);
Base : constant Entity_Id := Base_Type (Typ); Base : constant Entity_Id := Base_Type (Typ);
begin begin
...@@ -4706,10 +4796,10 @@ package body Exp_Ch3 is ...@@ -4706,10 +4796,10 @@ package body Exp_Ch3 is
-- been a private type at the point of definition. Same if component -- been a private type at the point of definition. Same if component
-- type is controlled. -- 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, Set_Has_Controlled_Component (Base,
Has_Controlled_Component (Component_Type (Typ)) Has_Controlled_Component (Comp_Typ)
or else Is_Controlled (Component_Type (Typ))); or else Is_Controlled (Comp_Typ));
if No (Init_Proc (Base)) then if No (Init_Proc (Base)) then
...@@ -4746,22 +4836,30 @@ package body Exp_Ch3 is ...@@ -4746,22 +4836,30 @@ package body Exp_Ch3 is
end if; end if;
end if; end if;
if Typ = Base and then Has_Controlled_Component (Base) then if Typ = Base then
if Has_Controlled_Component (Base) then
Build_Controlling_Procs (Base); Build_Controlling_Procs (Base);
if not Is_Limited_Type (Component_Type (Typ)) if not Is_Limited_Type (Comp_Typ)
and then Number_Dimensions (Typ) = 1 and then Number_Dimensions (Typ) = 1
then then
Build_Slice_Assignment (Typ); Build_Slice_Assignment (Typ);
end if; end if;
elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type
and then Controlled_Type (Directly_Designated_Type (Comp_Typ))
then
Set_Associated_Final_Chain (Comp_Typ, Add_Final_Chain (Typ));
end if;
end if; end if;
-- For packed case, there is a default initialization, except if the -- For packed case, default initialization, except if the component type
-- component type is itself a packed structure with an initialization -- is itself a packed structure with an initialization procedure, or
-- procedure. -- initialize/normalize scalars active, and we have a base type.
elsif Present (Init_Proc (Component_Type (Base))) elsif (Present (Init_Proc (Component_Type (Base)))
and then No (Base_Init_Proc (Base)) and then No (Base_Init_Proc (Base)))
or else (Init_Or_Norm_Scalars and then Base = Typ)
then then
Build_Array_Init_Proc (Base, N); Build_Array_Init_Proc (Base, N);
end if; end if;
...@@ -4788,14 +4886,14 @@ package body Exp_Ch3 is ...@@ -4788,14 +4886,14 @@ package body Exp_Ch3 is
pragma Warnings (Off, Func); pragma Warnings (Off, Func);
begin begin
-- Various optimization are possible if the given representation is -- Various optimizations possible if given representation is contiguous
-- contiguous.
Is_Contiguous := True; Is_Contiguous := True;
Ent := First_Literal (Typ); Ent := First_Literal (Typ);
Last_Repval := Enumeration_Rep (Ent); Last_Repval := Enumeration_Rep (Ent);
Next_Literal (Ent);
Next_Literal (Ent);
while Present (Ent) loop while Present (Ent) loop
if Enumeration_Rep (Ent) - Last_Repval /= 1 then if Enumeration_Rep (Ent) - Last_Repval /= 1 then
Is_Contiguous := False; Is_Contiguous := False;
...@@ -4968,7 +5066,7 @@ package body Exp_Ch3 is ...@@ -4968,7 +5066,7 @@ package body Exp_Ch3 is
Make_Integer_Literal (Loc, Intval => Last_Repval))), Make_Integer_Literal (Loc, Intval => Last_Repval))),
Statements => New_List ( Statements => New_List (
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Pos_Expr)))); Expression => Pos_Expr))));
else else
...@@ -4981,7 +5079,7 @@ package body Exp_Ch3 is ...@@ -4981,7 +5079,7 @@ package body Exp_Ch3 is
Intval => Enumeration_Rep (Ent))), Intval => Enumeration_Rep (Ent))),
Statements => New_List ( Statements => New_List (
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
Make_Integer_Literal (Loc, Make_Integer_Literal (Loc,
Intval => Enumeration_Pos (Ent)))))); Intval => Enumeration_Pos (Ent))))));
...@@ -5000,7 +5098,7 @@ package body Exp_Ch3 is ...@@ -5000,7 +5098,7 @@ package body Exp_Ch3 is
Make_Raise_Constraint_Error (Loc, Make_Raise_Constraint_Error (Loc,
Condition => Make_Identifier (Loc, Name_uF), Condition => Make_Identifier (Loc, Name_uF),
Reason => CE_Invalid_Data), Reason => CE_Invalid_Data),
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
Make_Integer_Literal (Loc, -1))))); Make_Integer_Literal (Loc, -1)))));
...@@ -5013,7 +5111,7 @@ package body Exp_Ch3 is ...@@ -5013,7 +5111,7 @@ package body Exp_Ch3 is
Make_Case_Statement_Alternative (Loc, Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List (Make_Others_Choice (Loc)), Discrete_Choices => New_List (Make_Others_Choice (Loc)),
Statements => New_List ( Statements => New_List (
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
Make_Integer_Literal (Loc, -1))))); Make_Integer_Literal (Loc, -1)))));
end if; end if;
...@@ -5068,10 +5166,16 @@ package body Exp_Ch3 is ...@@ -5068,10 +5166,16 @@ package body Exp_Ch3 is
------------------------ ------------------------
procedure Freeze_Record_Type (N : Node_Id) is procedure Freeze_Record_Type (N : Node_Id) is
Comp : Entity_Id;
Def_Id : constant Node_Id := Entity (N); Def_Id : constant Node_Id := Entity (N);
Predef_List : List_Id;
Type_Decl : constant Node_Id := Parent (Def_Id); 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; Renamed_Eq : Node_Id := Empty;
-- Could use some comments ??? -- Could use some comments ???
...@@ -5082,11 +5186,11 @@ package body Exp_Ch3 is ...@@ -5082,11 +5186,11 @@ package body Exp_Ch3 is
begin begin
-- Build discriminant checking functions if not a derived type (for -- Build discriminant checking functions if not a derived type (for
-- derived types that are not tagged types, we always use the -- derived types that are not tagged types, always use the discriminant
-- discriminant checking functions of the parent type). However, for -- checking functions of the parent type). However, for untagged types
-- untagged types the derivation may have taken place before the -- the derivation may have taken place before the parent was frozen, so
-- parent was frozen, so we copy explicitly the discriminant checking -- we copy explicitly the discriminant checking functions from the
-- functions from the parent into the components of the derived type. -- parent into the components of the derived type.
if not Is_Derived_Type (Def_Id) if not Is_Derived_Type (Def_Id)
or else Has_New_Non_Standard_Rep (Def_Id) or else Has_New_Non_Standard_Rep (Def_Id)
...@@ -5139,14 +5243,25 @@ package body Exp_Ch3 is ...@@ -5139,14 +5243,25 @@ package body Exp_Ch3 is
Comp := First_Component (Def_Id); Comp := First_Component (Def_Id);
while Present (Comp) loop 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); Set_Has_Task (Def_Id);
elsif Has_Controlled_Component (Etype (Comp)) elsif Has_Controlled_Component (Comp_Typ)
or else (Chars (Comp) /= Name_uParent or else (Chars (Comp) /= Name_uParent
and then Is_Controlled (Etype (Comp))) and then Is_Controlled (Comp_Typ))
then then
Set_Has_Controlled_Component (Def_Id); 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; end if;
Next_Component (Comp); Next_Component (Comp);
...@@ -5159,31 +5274,28 @@ package body Exp_Ch3 is ...@@ -5159,31 +5274,28 @@ package body Exp_Ch3 is
-- just use it. -- just use it.
if Is_Tagged_Type (Def_Id) then 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 -- Add the _Tag component
-- 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)
if Etype (First_Component (Def_Id)) = RTE (RE_Tag) if Underlying_Type (Etype (Def_Id)) = Def_Id then
and then Underlying_Type (Etype (Def_Id)) = Def_Id
then
Expand_Tagged_Root (Def_Id); Expand_Tagged_Root (Def_Id);
end if; end if;
if Is_CPP_Class (Def_Id) then
Set_All_DT_Position (Def_Id); Set_All_DT_Position (Def_Id);
Set_Default_Constructor (Def_Id); Set_Default_Constructor (Def_Id);
-- With CPP_Class types Make_DT does a minimum decoration of the -- Create the tag entities with a minimum decoration
-- Access_Disp_Table list.
if VM_Target = No_VM then 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; end if;
else else
if not Static_Dispatch_Tables then if not Has_Static_DT then
-- Usually inherited primitives are not delayed but the first -- Usually inherited primitives are not delayed but the first
-- Ada extension of a CPP_Class is an exception since the -- Ada extension of a CPP_Class is an exception since the
...@@ -5221,10 +5333,6 @@ package body Exp_Ch3 is ...@@ -5221,10 +5333,6 @@ package body Exp_Ch3 is
end; end;
end if; 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 -- Unfreeze momentarily the type to add the predefined primitives
-- operations. The reason we unfreeze is so that these predefined -- operations. The reason we unfreeze is so that these predefined
-- operations will indeed end up as primitive operations (which -- operations will indeed end up as primitive operations (which
...@@ -5280,13 +5388,23 @@ package body Exp_Ch3 is ...@@ -5280,13 +5388,23 @@ package body Exp_Ch3 is
Expand_Record_Controller (Def_Id); Expand_Record_Controller (Def_Id);
end if; end if;
-- Build the dispatch table. Suppress its creation when VM_Target -- Create and decorate the tags. Suppress their creation when
-- because the dispatching mechanism is handled internally by the -- VM_Target because the dispatching mechanism is handled
-- VMs. -- internally by the VMs.
if VM_Target = No_VM then if VM_Target = No_VM then
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)); Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
end if; end if;
end if;
-- Make sure that the primitives Initialize, Adjust and Finalize -- Make sure that the primitives Initialize, Adjust and Finalize
-- are Frozen before other TSS subprograms. We don't want them -- are Frozen before other TSS subprograms. We don't want them
...@@ -5409,19 +5527,6 @@ package body Exp_Ch3 is ...@@ -5409,19 +5527,6 @@ package body Exp_Ch3 is
if Present (Wrapper_Body_List) then if Present (Wrapper_Body_List) then
Append_Freeze_Actions (Def_Id, Wrapper_Body_List); Append_Freeze_Actions (Def_Id, Wrapper_Body_List);
end if; 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 if;
end Freeze_Record_Type; end Freeze_Record_Type;
...@@ -5786,15 +5891,7 @@ package body Exp_Ch3 is ...@@ -5786,15 +5891,7 @@ package body Exp_Ch3 is
or else Has_Controlled_Coextensions (Desig_Type) or else Has_Controlled_Coextensions (Desig_Type)
then then
Set_Associated_Final_Chain (Def_Id, Set_Associated_Final_Chain (Def_Id, Add_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)));
end if; end if;
end; end;
...@@ -6339,53 +6436,47 @@ package body Exp_Ch3 is ...@@ -6339,53 +6436,47 @@ package body Exp_Ch3 is
procedure Init_Secondary_Tags procedure Init_Secondary_Tags
(Typ : Entity_Id; (Typ : Entity_Id;
Target : Node_Id; Target : Node_Id;
Stmts_List : List_Id) Stmts_List : List_Id;
Fixed_Comps : Boolean := True;
Variable_Comps : Boolean := True)
is is
Loc : constant Source_Ptr := Sloc (Target); Loc : constant Source_Ptr := Sloc (Target);
ADT : Elmt_Id;
Full_Typ : Entity_Id;
AI_Tag_Comp : Entity_Id;
Is_Synch_Typ : Boolean := False; procedure Inherit_CPP_Tag
-- In case of non concurrent-record-types each parent-type has the (Typ : Entity_Id;
-- tags associated with the interface types that are not implemented Iface : Entity_Id;
-- by the ancestors; concurrent-record-types have their whole list of Tag_Comp : Entity_Id;
-- interface tags (and this case requires some special management). 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 procedure Initialize_Tag
(Typ : Entity_Id; (Typ : Entity_Id;
Iface : Entity_Id; Iface : Entity_Id;
Tag_Comp : in out Entity_Id; Tag_Comp : Entity_Id;
Iface_Tag : Node_Id); Iface_Tag : Node_Id);
-- Initialize the tag of the secondary dispatch table of Typ associated -- Initialize the tag of the secondary dispatch table of Typ associated
-- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag. -- 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. -- Inherit_CPP_Tag --
-- We assume that all the primitives of the imported C++ class are ---------------------
-- defined in the C side.
--------------------
-- Initialize_Tag --
--------------------
procedure Initialize_Tag procedure Inherit_CPP_Tag
(Typ : Entity_Id; (Typ : Entity_Id;
Iface : Entity_Id; Iface : Entity_Id;
Tag_Comp : in out Entity_Id; Tag_Comp : Entity_Id;
Iface_Tag : Node_Id) Iface_Tag : Node_Id)
is is
Prev_E : Entity_Id;
begin begin
-- If we are compiling under the CPP full ABI compatibility mode and pragma Assert (Is_CPP_Class (Etype (Typ)));
-- 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 (Typ)) then
Append_To (Stmts_List, Append_To (Stmts_List,
Build_Inherit_Prims (Loc, Build_Inherit_Prims (Loc,
Typ => Iface,
Old_Tag_Node => Old_Tag_Node =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target), Prefix => New_Copy_Tree (Target),
...@@ -6393,13 +6484,27 @@ package body Exp_Ch3 is ...@@ -6393,13 +6484,27 @@ package body Exp_Ch3 is
New_Tag_Node => New_Tag_Node =>
New_Reference_To (Iface_Tag, Loc), New_Reference_To (Iface_Tag, Loc),
Num_Prims => Num_Prims =>
UI_To_Int UI_To_Int (DT_Entry_Count (First_Tag_Component (Iface)))));
(DT_Entry_Count (First_Tag_Component (Iface))))); end Inherit_CPP_Tag;
end if;
--------------------
-- Initialize_Tag --
--------------------
procedure Initialize_Tag
(Typ : Entity_Id;
Iface : Entity_Id;
Tag_Comp : Entity_Id;
Iface_Tag : Node_Id)
is
Comp_Typ : Entity_Id;
Offset_To_Top_Comp : Entity_Id := Empty;
begin
-- Initialize the pointer to the secondary DT associated with the -- Initialize the pointer to the secondary DT associated with the
-- interface. -- interface.
if not Is_Parent (Iface, Typ) then
Append_To (Stmts_List, Append_To (Stmts_List,
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => Name =>
...@@ -6408,15 +6513,8 @@ package body Exp_Ch3 is ...@@ -6408,15 +6513,8 @@ package body Exp_Ch3 is
Selector_Name => New_Reference_To (Tag_Comp, Loc)), Selector_Name => New_Reference_To (Tag_Comp, Loc)),
Expression => Expression =>
New_Reference_To (Iface_Tag, Loc))); New_Reference_To (Iface_Tag, Loc)));
end if;
-- 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 -- Issue error if Set_Offset_To_Top is not available in a
-- configurable run-time environment. -- configurable run-time environment.
...@@ -6425,11 +6523,15 @@ package body Exp_Ch3 is ...@@ -6425,11 +6523,15 @@ package body Exp_Ch3 is
return; return;
end if; end if;
-- We generate a different call when the parent of the type has Comp_Typ := Scope (Tag_Comp);
-- discriminants.
-- Initialize the entries of the table of interfaces. We generate a
-- different call when the parent of the type has variable size
-- components.
if Typ /= Etype (Typ) if Comp_Typ /= Etype (Comp_Typ)
and then Has_Discriminants (Etype (Typ)) and then Is_Variable_Size_Record (Etype (Comp_Typ))
and then Chars (Tag_Comp) /= Name_uTag
then then
pragma Assert pragma Assert
(Present (DT_Offset_To_Top_Func (Tag_Comp))); (Present (DT_Offset_To_Top_Func (Tag_Comp)));
...@@ -6444,8 +6546,7 @@ package body Exp_Ch3 is ...@@ -6444,8 +6546,7 @@ package body Exp_Ch3 is
Append_To (Stmts_List, Append_To (Stmts_List,
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
(RTE (RE_Set_Offset_To_Top), Loc),
Parameter_Associations => New_List ( Parameter_Associations => New_List (
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => New_Copy_Tree (Target), Prefix => New_Copy_Tree (Target),
...@@ -6477,23 +6578,23 @@ package body Exp_Ch3 is ...@@ -6477,23 +6578,23 @@ package body Exp_Ch3 is
-- In this case the next component stores the value of the -- In this case the next component stores the value of the
-- offset to the top. -- offset to the top.
Prev_E := Tag_Comp; Offset_To_Top_Comp := Next_Entity (Tag_Comp);
Next_Entity (Tag_Comp); pragma Assert (Present (Offset_To_Top_Comp));
pragma Assert (Present (Tag_Comp));
Append_To (Stmts_List, Append_To (Stmts_List,
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => Name =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target), Prefix => New_Copy_Tree (Target),
Selector_Name => New_Reference_To (Tag_Comp, Loc)), Selector_Name => New_Reference_To
(Offset_To_Top_Comp, Loc)),
Expression => Expression =>
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Prefix =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target), Prefix => New_Copy_Tree (Target),
Selector_Name => Selector_Name =>
New_Reference_To (Prev_E, Loc)), New_Reference_To (Tag_Comp, Loc)),
Attribute_Name => Name_Position))); Attribute_Name => Name_Position)));
-- Normal case: No discriminants in the parent type -- Normal case: No discriminants in the parent type
...@@ -6536,112 +6637,130 @@ package body Exp_Ch3 is ...@@ -6536,112 +6637,130 @@ package body Exp_Ch3 is
Make_Null (Loc)))); Make_Null (Loc))));
end if; end if;
end if;
end Initialize_Tag; end Initialize_Tag;
---------------------------------- -- Local variables
-- Init_Secondary_Tags_Internal --
----------------------------------
procedure Init_Secondary_Tags_Internal (Typ : Entity_Id) is
AI_Elmt : Elmt_Id;
begin Full_Typ : Entity_Id;
-- Climb to the ancestor (if any) handling synchronized interface Ifaces_List : Elist_Id;
-- derivations and private types 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;
if Is_Concurrent_Record_Type (Typ) then -- Start of processing for Init_Secondary_Tags
declare
Iface_List : constant List_Id := Abstract_Interface_List (Typ);
begin begin
if Is_Non_Empty_List (Iface_List) then -- Handle private types
Init_Secondary_Tags_Internal (Etype (First (Iface_List)));
end if;
end;
elsif Present (Full_View (Etype (Typ))) then if Present (Full_View (Typ)) then
if Full_View (Etype (Typ)) /= Typ then Full_Typ := Full_View (Typ);
Init_Secondary_Tags_Internal (Full_View (Etype (Typ))); else
Full_Typ := Typ;
end if; end if;
elsif Etype (Typ) /= Typ then Collect_Interfaces_Info
Init_Secondary_Tags_Internal (Etype (Typ)); (Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List);
end if;
if Is_Interface (Typ) then Iface_Elmt := First_Elmt (Ifaces_List);
-- Generate: Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
-- Set_Offset_To_Top Iface_Tag_Elmt := First_Elmt (Ifaces_Tag_List);
-- (This => Init, while Present (Iface_Elmt) loop
-- Interface_T => Iface'Tag, Tag_Comp := Node (Iface_Comp_Elmt);
-- Is_Constant => True,
-- Offset_Value => 0,
-- Offset_Func => null)
Append_To (Stmts_List, -- If we are compiling under the CPP full ABI compatibility mode and
Make_Procedure_Call_Statement (Loc, -- the ancestor is a CPP_Pragma tagged type then we generate code to
Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc), -- inherit the contents of the dispatch table directly from the
Parameter_Associations => New_List ( -- ancestor.
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))),
Loc)),
New_Occurrence_Of (Standard_True, Loc),
Make_Integer_Literal (Loc, Uint_0),
Make_Null (Loc))));
end if;
if Present (Abstract_Interfaces (Typ)) if Is_CPP_Class (Etype (Full_Typ)) then
and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) Inherit_CPP_Tag (Full_Typ,
then Iface => Node (Iface_Elmt),
if not Is_Synch_Typ then Tag_Comp => Tag_Comp,
AI_Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ)); Iface_Tag => Node (Iface_Tag_Elmt));
pragma Assert (Present (AI_Tag_Comp));
end if; -- Otherwise we generate code to initialize the tag
AI_Elmt := First_Elmt (Abstract_Interfaces (Typ)); else
while Present (AI_Elmt) loop -- Check if the parent of the record type has variable size
pragma Assert (Present (Node (ADT))); -- components.
Initialize_Tag In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp))
(Typ => Typ, and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp)));
Iface => Node (AI_Elmt),
Tag_Comp => AI_Tag_Comp,
Iface_Tag => Node (ADT));
Next_Elmt (ADT); if (In_Variable_Pos and then Variable_Comps)
AI_Tag_Comp := Next_Tag_Component (AI_Tag_Comp); or else (not In_Variable_Pos and then Fixed_Comps)
Next_Elmt (AI_Elmt); then
end loop; Initialize_Tag (Full_Typ,
Iface => Node (Iface_Elmt),
Tag_Comp => Tag_Comp,
Iface_Tag => Node (Iface_Tag_Elmt));
end if;
end if; end if;
end Init_Secondary_Tags_Internal;
-- Start of processing for Init_Secondary_Tags 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 begin
-- Skip the first _Tag, which is the main tag of the tagged type. pragma Assert (Is_Record_Type (E));
-- Following tags correspond with abstract interfaces.
ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); Comp := First_Entity (E);
while Present (Comp) loop
Comp_Typ := Etype (Comp);
-- Handle private types if Is_Record_Type (Comp_Typ) then
if Present (Full_View (Typ)) then -- Recursive call if the record type has discriminants
Full_Typ := Full_View (Typ);
else if Has_Discriminants (Comp_Typ)
Full_Typ := Typ; and then Is_Variable_Size_Record (Comp_Typ)
then
return True;
end if; end if;
if Is_Concurrent_Record_Type (Typ) then elsif Is_Array_Type (Comp_Typ) then
Is_Synch_Typ := True;
AI_Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ)); -- 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; end if;
Init_Secondary_Tags_Internal (Full_Typ); Idx := Next_Index (Idx);
end Init_Secondary_Tags; end loop;
end if;
Next_Entity (Comp);
end loop;
return False;
end Is_Variable_Size_Record;
---------------------------------------- ----------------------------------------
-- Make_Controlling_Function_Wrappers -- -- Make_Controlling_Function_Wrappers --
...@@ -6684,19 +6803,28 @@ package body Exp_Ch3 is ...@@ -6684,19 +6803,28 @@ package body Exp_Ch3 is
-- Input constructed by the expander. The test for Comes_From_Source -- Input constructed by the expander. The test for Comes_From_Source
-- is needed to distinguish inherited operations from renamings -- is needed to distinguish inherited operations from renamings
-- (which also have Alias set). -- (which also have Alias set).
-- The function may be abstract, or require_Overriding may be set -- The function may be abstract, or require_Overriding may be set
-- for it, because tests for null extensions may already have reset -- for it, because tests for null extensions may already have reset
-- the Is_Abstract_Subprogram_Flag. -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not
-- set, functions that need wrappers are recognized by having an
if (Is_Abstract_Subprogram (Subp) -- alias that returns the parent type.
or else Requires_Overriding (Subp))
and then Present (Alias (Subp)) if Comes_From_Source (Subp)
and then not Is_Abstract_Subprogram (Alias (Subp)) or else No (Alias (Subp))
and then not Comes_From_Source (Subp) or else Ekind (Subp) /= E_Function
and then Ekind (Subp) = E_Function or else not Has_Controlling_Result (Subp)
and then Has_Controlling_Result (Subp) or else Is_Access_Type (Etype (Subp))
and then not Is_Access_Type (Etype (Subp)) or else Is_Abstract_Subprogram (Alias (Subp))
and then not Is_TSS (Subp, TSS_Stream_Input) 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 then
Formal_List := No_List; Formal_List := No_List;
Formal := First_Formal (Subp); Formal := First_Formal (Subp);
...@@ -6713,6 +6841,8 @@ package body Exp_Ch3 is ...@@ -6713,6 +6841,8 @@ package body Exp_Ch3 is
Chars => Chars (Formal)), Chars => Chars (Formal)),
In_Present => In_Present (Parent (Formal)), In_Present => In_Present (Parent (Formal)),
Out_Present => Out_Present (Parent (Formal)), Out_Present => Out_Present (Parent (Formal)),
Null_Exclusion_Present =>
Null_Exclusion_Present (Parent (Formal)),
Parameter_Type => Parameter_Type =>
New_Reference_To (Etype (Formal), Loc), New_Reference_To (Etype (Formal), Loc),
Expression => Expression =>
...@@ -6726,9 +6856,9 @@ package body Exp_Ch3 is ...@@ -6726,9 +6856,9 @@ package body Exp_Ch3 is
Func_Spec := Func_Spec :=
Make_Function_Specification (Loc, Make_Function_Specification (Loc,
Defining_Unit_Name => Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Chars (Subp)), Make_Defining_Identifier (Loc,
Parameter_Specifications => Chars => Chars (Subp)),
Formal_List, Parameter_Specifications => Formal_List,
Result_Definition => Result_Definition =>
New_Reference_To (Etype (Subp), Loc)); New_Reference_To (Etype (Subp), Loc));
...@@ -6775,7 +6905,7 @@ package body Exp_Ch3 is ...@@ -6775,7 +6905,7 @@ package body Exp_Ch3 is
end loop; end loop;
Return_Stmt := Return_Stmt :=
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
Make_Extension_Aggregate (Loc, Make_Extension_Aggregate (Loc,
Ancestor_Part => Ancestor_Part =>
...@@ -6805,6 +6935,7 @@ package body Exp_Ch3 is ...@@ -6805,6 +6935,7 @@ package body Exp_Ch3 is
(Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec)); (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec));
end if; end if;
<<Next_Prim>>
Next_Elmt (Prim_Elmt); Next_Elmt (Prim_Elmt);
end loop; end loop;
end Make_Controlling_Function_Wrappers; end Make_Controlling_Function_Wrappers;
...@@ -6951,7 +7082,7 @@ package body Exp_Ch3 is ...@@ -6951,7 +7082,7 @@ package body Exp_Ch3 is
Make_Implicit_If_Statement (E, Make_Implicit_If_Statement (E,
Condition => Cond, Condition => Cond,
Then_Statements => New_List ( Then_Statements => New_List (
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_False, Loc)))); Expression => New_Occurrence_Of (Standard_False, Loc))));
end if; end if;
end if; end if;
...@@ -7021,6 +7152,8 @@ package body Exp_Ch3 is ...@@ -7021,6 +7152,8 @@ package body Exp_Ch3 is
Chars => Chars (Formal)), Chars => Chars (Formal)),
In_Present => In_Present (Parent (Formal)), In_Present => In_Present (Parent (Formal)),
Out_Present => Out_Present (Parent (Formal)), Out_Present => Out_Present (Parent (Formal)),
Null_Exclusion_Present =>
Null_Exclusion_Present (Parent (Formal)),
Parameter_Type => Parameter_Type =>
New_Reference_To (Etype (Formal), Loc), New_Reference_To (Etype (Formal), Loc),
Expression => Expression =>
...@@ -7591,7 +7724,7 @@ package body Exp_Ch3 is ...@@ -7591,7 +7724,7 @@ package body Exp_Ch3 is
Set_Handled_Statement_Sequence (Decl, Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc, New_List ( Make_Handled_Sequence_Of_Statements (Loc, New_List (
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_X), Prefix => Make_Identifier (Loc, Name_X),
...@@ -7614,7 +7747,7 @@ package body Exp_Ch3 is ...@@ -7614,7 +7747,7 @@ package body Exp_Ch3 is
Set_Handled_Statement_Sequence (Decl, Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc, New_List ( Make_Handled_Sequence_Of_Statements (Loc, New_List (
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_X), Prefix => Make_Identifier (Loc, Name_X),
...@@ -7741,12 +7874,12 @@ package body Exp_Ch3 is ...@@ -7741,12 +7874,12 @@ package body Exp_Ch3 is
Make_Eq_If (Tag_Typ, Discriminant_Specifications (Def))); Make_Eq_If (Tag_Typ, Discriminant_Specifications (Def)));
Append_List_To (Stmts, Make_Eq_Case (Tag_Typ, Comps)); Append_List_To (Stmts, Make_Eq_Case (Tag_Typ, Comps));
Append_To (Stmts, Append_To (Stmts,
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => New_Reference_To (Standard_True, Loc))); Expression => New_Reference_To (Standard_True, Loc)));
else else
Append_To (Stmts, Append_To (Stmts,
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
Expand_Record_Equality (Tag_Typ, Expand_Record_Equality (Tag_Typ,
Typ => Tag_Typ, Typ => Tag_Typ,
......
gcc/ada/exp_ch3.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -113,10 +113,15 @@ package Exp_Ch3 is ...@@ -113,10 +113,15 @@ package Exp_Ch3 is
procedure Init_Secondary_Tags procedure Init_Secondary_Tags
(Typ : Entity_Id; (Typ : Entity_Id;
Target : Node_Id; Target : Node_Id;
Stmts_List : List_Id); Stmts_List : List_Id;
-- Ada 2005 (AI-251): Initialize the tags of all the secondary tables Fixed_Comps : Boolean := True;
-- associated with the abstract interfaces of Typ. The generated code Variable_Comps : Boolean := True);
-- referencing tag fields of Target is appended to Stmts_List. -- 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; function Needs_Simple_Initialization (T : Entity_Id) return Boolean;
-- Certain types need initialization even though there is no specific -- Certain types need initialization even though there is no specific
......
gcc/ada/sem_type.adb
...@@ -161,6 +161,29 @@ package body Sem_Type is ...@@ -161,6 +161,29 @@ package body Sem_Type is
pragma Warnings (Off, All_Overloads); pragma Warnings (Off, All_Overloads);
-- Debugging procedure: list full contents of Overloads table -- 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); procedure New_Interps (N : Node_Id);
-- Initialize collection of interpretations for the given node, which is -- Initialize collection of interpretations for the given node, which is
-- either an overloaded entity, or an operation whose arguments have -- either an overloaded entity, or an operation whose arguments have
...@@ -184,9 +207,9 @@ package body Sem_Type is ...@@ -184,9 +207,9 @@ package body Sem_Type is
Vis_Type : Entity_Id; Vis_Type : Entity_Id;
procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id); procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id);
-- Add one interpretation to node. Node is already known to be -- Add one interpretation to an overloaded node. Add a new entry if
-- overloaded. Add new interpretation if not hidden by previous -- not hidden by previous one, and remove previous one if hidden by
-- one, and remove previous one if hidden by new one. -- new one.
function Is_Universal_Operation (Op : Entity_Id) return Boolean; function Is_Universal_Operation (Op : Entity_Id) return Boolean;
-- True if the entity is a predefined operator and the operands have -- True if the entity is a predefined operator and the operands have
...@@ -197,11 +220,25 @@ package body Sem_Type is ...@@ -197,11 +220,25 @@ package body Sem_Type is
--------------- ---------------
procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is
Index : Interp_Index; Abstr_Op : Entity_Id := Empty;
I : Interp_Index;
It : Interp; It : Interp;
-- Start of processing for Add_Entry
begin 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 while Present (It.Nam) loop
-- A user-defined subprogram hides another declared at an outer -- A user-defined subprogram hides another declared at an outer
...@@ -254,7 +291,7 @@ package body Sem_Type is ...@@ -254,7 +291,7 @@ package body Sem_Type is
end if; end if;
else else
All_Interp.Table (Index).Nam := Name; All_Interp.Table (I).Nam := Name;
return; return;
end if; end if;
...@@ -268,15 +305,12 @@ package body Sem_Type is ...@@ -268,15 +305,12 @@ package body Sem_Type is
-- Otherwise keep going -- Otherwise keep going
else else
Get_Next_Interp (Index, It); Get_Next_Interp (I, It);
end if; end if;
end loop; end loop;
-- On exit, enter new interpretation. The context, or a preference All_Interp.Table (All_Interp.Last) := (Name, Typ, Abstr_Op);
-- rule, will resolve the ambiguity on the second pass.
All_Interp.Table (All_Interp.Last) := (Name, Typ);
All_Interp.Increment_Last; All_Interp.Increment_Last;
All_Interp.Table (All_Interp.Last) := No_Interp; All_Interp.Table (All_Interp.Last) := No_Interp;
end Add_Entry; end Add_Entry;
...@@ -501,6 +535,27 @@ package body Sem_Type is ...@@ -501,6 +535,27 @@ package body Sem_Type is
end loop; end loop;
end All_Overloads; 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 -- -- Collect_Interps --
--------------------- ---------------------
...@@ -567,7 +622,8 @@ package body Sem_Type is ...@@ -567,7 +622,8 @@ package body Sem_Type is
and then In_Instance and then In_Instance
and then not Is_Inherited_Operation (H) and then not Is_Inherited_Operation (H)
then 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.Increment_Last;
All_Interp.Table (All_Interp.Last) := No_Interp; All_Interp.Table (All_Interp.Last) := No_Interp;
goto Next_Homograph; goto Next_Homograph;
...@@ -821,9 +877,11 @@ package body Sem_Type is ...@@ -821,9 +877,11 @@ package body Sem_Type is
return True; return True;
-- If the expected type is an anonymous access, the designated type must -- 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 Is_Access_Type (T2)
and then Covers (Designated_Type (T1), Designated_Type (T2)) and then Covers (Designated_Type (T1), Designated_Type (T2))
then then
...@@ -987,10 +1045,11 @@ package body Sem_Type is ...@@ -987,10 +1045,11 @@ package body Sem_Type is
elsif From_With_Type (T1) then elsif From_With_Type (T1) then
-- If the expected type is the non-limited view of a type, the -- 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 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 elsif Ekind (T1) = E_Class_Wide_Type then
return return
...@@ -1006,7 +1065,7 @@ package body Sem_Type is ...@@ -1006,7 +1065,7 @@ package body Sem_Type is
-- verify that the context type is the non-limited view. -- verify that the context type is the non-limited view.
if Is_Incomplete_Type (T2) then 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 elsif Ekind (T2) = E_Class_Wide_Type then
return return
...@@ -1677,7 +1736,7 @@ package body Sem_Type is ...@@ -1677,7 +1736,7 @@ package body Sem_Type is
end if; end if;
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 -- disambiguated from the predefined concatenation. This can only
-- happen with concatenation of string literals. -- happen with concatenation of string literals.
...@@ -1904,9 +1963,48 @@ package body Sem_Type is ...@@ -1904,9 +1963,48 @@ package body Sem_Type is
else else
return Specific_Type (T, Etype (R)); return Specific_Type (T, Etype (R));
end if; end if;
end Find_Unique_Type; 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 -- -- Get_First_Interp --
---------------------- ----------------------
...@@ -1916,8 +2014,8 @@ package body Sem_Type is ...@@ -1916,8 +2014,8 @@ package body Sem_Type is
I : out Interp_Index; I : out Interp_Index;
It : out Interp) It : out Interp)
is is
Map_Ptr : Int;
Int_Ind : Interp_Index; Int_Ind : Interp_Index;
Map_Ptr : Int;
O_N : Node_Id; O_N : Node_Id;
begin begin
...@@ -2030,6 +2128,34 @@ package body Sem_Type is ...@@ -2030,6 +2128,34 @@ package body Sem_Type is
end if; end if;
end Has_Compatible_Type; 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 -- -- Hash --
---------- ----------
...@@ -2384,8 +2510,8 @@ package body Sem_Type is ...@@ -2384,8 +2510,8 @@ package body Sem_Type is
then then
return False; return False;
else return else
Is_Numeric_Type (T) return Is_Numeric_Type (T)
and then not In_Open_Scopes (Scope (T)) and then not In_Open_Scopes (Scope (T))
and then not Is_Potentially_Use_Visible (T) and then not Is_Potentially_Use_Visible (T)
and then not In_Use (T) and then not In_Use (T)
...@@ -2394,7 +2520,6 @@ package body Sem_Type is ...@@ -2394,7 +2520,6 @@ package body Sem_Type is
(Nkind (Orig_Node) /= N_Function_Call (Nkind (Orig_Node) /= N_Function_Call
or else Nkind (Name (Orig_Node)) /= N_Expanded_Name or else Nkind (Name (Orig_Node)) /= N_Expanded_Name
or else Entity (Prefix (Name (Orig_Node))) /= Scope (T)) or else Entity (Prefix (Name (Orig_Node))) /= Scope (T))
and then not In_Instance; and then not In_Instance;
end if; end if;
end Is_Invisible_Operator; end Is_Invisible_Operator;
...@@ -2866,6 +2991,15 @@ package body Sem_Type is ...@@ -2866,6 +2991,15 @@ package body Sem_Type is
end if; end if;
end Specific_Type; 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 -- -- Valid_Boolean_Arg --
----------------------- -----------------------
...@@ -2956,9 +3090,9 @@ package body Sem_Type is ...@@ -2956,9 +3090,9 @@ package body Sem_Type is
Get_First_Interp (N, I, It); Get_First_Interp (N, I, It);
Write_Str ("Overloaded entity "); Write_Str ("Overloaded entity ");
Write_Eol; Write_Eol;
Write_Str (" Name Type"); Write_Str (" Name Type Abstract Op");
Write_Eol; Write_Eol;
Write_Str ("==============================="); Write_Str ("===============================================");
Write_Eol; Write_Eol;
Nam := It.Nam; Nam := It.Nam;
...@@ -2970,6 +3104,14 @@ package body Sem_Type is ...@@ -2970,6 +3104,14 @@ package body Sem_Type is
Write_Int (Int (It.Typ)); Write_Int (Int (It.Typ));
Write_Str (" "); Write_Str (" ");
Write_Name (Chars (It.Typ)); 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; Write_Eol;
Get_Next_Interp (I, It); Get_Next_Interp (I, It);
Nam := It.Nam; Nam := It.Nam;
......
gcc/ada/sem_type.ads
...@@ -66,9 +66,13 @@ package Sem_Type is ...@@ -66,9 +66,13 @@ package Sem_Type is
type Interp is record type Interp is record
Nam : Entity_Id; Nam : Entity_Id;
Typ : Entity_Id; Typ : Entity_Id;
Abstract_Op : Entity_Id := Empty;
end record; 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; subtype Interp_Index is Int;
...@@ -122,8 +126,9 @@ package Sem_Type is ...@@ -122,8 +126,9 @@ package Sem_Type is
-- E is an overloadable entity, and T is its type. For constructs such -- 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 -- as indexed expressions, the caller sets E equal to T, because the
-- overloading comes from other fields, and the node itself has no name -- overloading comes from other fields, and the node itself has no name
-- to resolve. Add_One_Interp includes the semantic processing to deal -- to resolve. Hidden denotes whether an interpretation has been disabled
-- with adding entries that hide one another etc. -- 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 -- 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 -- of T and its scope. If the operator is an equality or comparison, T is
...@@ -216,19 +221,22 @@ package Sem_Type is ...@@ -216,19 +221,22 @@ package Sem_Type is
-- interpretations is universal, choose the non-universal one. If either -- interpretations is universal, choose the non-universal one. If either
-- node is overloaded, find single common interpretation. -- 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; function Is_Ancestor (T1, T2 : Entity_Id) return Boolean;
-- T1 is a tagged type (not class-wide). Verify that it is one of the -- 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) -- ancestors of type T2 (which may or not be class-wide)
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; function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean;
-- Used to resolve subprograms renaming operators, and calls to user -- Used to resolve subprograms renaming operators, and calls to user
-- defined operators. Determines whether a given operator Op, matches -- defined operators. Determines whether a given operator Op, matches
-- a specification, New_S. -- 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; function Valid_Comparison_Arg (T : Entity_Id) return Boolean;
-- A valid argument to an ordering operator must be a discrete type, a -- 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. -- real type, or a one dimensional array with a discrete component type.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment