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 816 additions and 528 deletions
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_Prim>>
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,
......
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
......
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;
......
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.
......
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