Skip to content

R
riscv-gcc-1
Commit 0e41a941 by Arnaud Charlet
Options

[multiple changes] 

2009-07-13  Emmanuel Briot  <briot@adacore.com>

	* prj-err.adb (Error_Msg): One more case where a message should be
	considered as a warning.

	* gnatcmd.adb (GNATCmd): Fix previous change, which negated a test.

2009-07-13  Thomas Quinot  <quinot@adacore.com>

	* exp_dist.adb (Expand_All_Calls_Remote_Subprogram_Call): Analyze
	calling stubs in the (library level) scope of the RCI locator, where it
	is attached, not in the caller's scope.

2009-07-13  Javier Miranda  <miranda@adacore.com>

	* sem_ch3.adb (Analyze_Object_Declaration): In case of class-wide
	interface object declarations we delay the generation of the equivalent
	record type declarations until its expansion because there are cases in
	which they are not required.            

	* sem_util.adb (Implements_Interface): Add missing support for subtypes.

	* sem_disp.adb (Check_Controlling_Formals): Minor code cleanup plus
	addition of assertion.

	* exp_util.adb (Expand_Subtype_From_Expr): Renamings of class-wide
	interface types require no equivalent constrained type declarations
	because the expanded code only references the tag component associated
	with the interface.
	(Find_Interface_Tag): Improve management of interfaces that are
	ancestors of tagged types.

	* exp_ch3.adb (Expand_N_Object_Declaration): Improve the expansion of
	class-wide object declarations to add missing support to statically
	displace the pointer to the object to reference the tag component
	associated with the interface.

	* exp_disp.adb (Make_Tags) Avoid generation of internally generated
	auxiliary types associated with user-defined dispatching calls if the
	type has no user-defined primitives.

From-SVN: r149574
parent 75069667
Showing with 327 additions and 202 deletions
gcc/ada/ChangeLog
2009-07-13 Emmanuel Briot <briot@adacore.com>
* prj-err.adb (Error_Msg): One more case where a message should be
considered as a warning.
* gnatcmd.adb (GNATCmd): Fix previous change, which negated a test.
2009-07-13 Thomas Quinot <quinot@adacore.com>
* exp_dist.adb (Expand_All_Calls_Remote_Subprogram_Call): Analyze
calling stubs in the (library level) scope of the RCI locator, where it
is attached, not in the caller's scope.
2009-07-13 Javier Miranda <miranda@adacore.com>
* sem_ch3.adb (Analyze_Object_Declaration): In case of class-wide
interface object declarations we delay the generation of the equivalent
record type declarations until its expansion because there are cases in
which they are not required.
* sem_util.adb (Implements_Interface): Add missing support for subtypes.
* sem_disp.adb (Check_Controlling_Formals): Minor code cleanup plus
addition of assertion.
* exp_util.adb (Expand_Subtype_From_Expr): Renamings of class-wide
interface types require no equivalent constrained type declarations
because the expanded code only references the tag component associated
with the interface.
(Find_Interface_Tag): Improve management of interfaces that are
ancestors of tagged types.
* exp_ch3.adb (Expand_N_Object_Declaration): Improve the expansion of
class-wide object declarations to add missing support to statically
displace the pointer to the object to reference the tag component
associated with the interface.
* exp_disp.adb (Make_Tags) Avoid generation of internally generated
auxiliary types associated with user-defined dispatching calls if the
type has no user-defined primitives.
2009-07-13 Vasiliy Fofanov <fofanov@adacore.com> 2009-07-13 Vasiliy Fofanov <fofanov@adacore.com>
* mingw32.h: Make it explicit that we need XP or later. * mingw32.h: Make it explicit that we need XP or later.
......
gcc/ada/exp_ch3.adb
...@@ -4497,121 +4497,164 @@ package body Exp_Ch3 is ...@@ -4497,121 +4497,164 @@ package body Exp_Ch3 is
return; return;
else -- Ada 2005 (AI-251): Rewrite the expression that initializes a
-- In most cases, we must check that the initial value meets any -- class-wide object to ensure that we copy the full object,
-- constraint imposed by the declared type. However, there is one -- unless we are targetting a VM where interfaces are handled by
-- very important exception to this rule. If the entity has an -- VM itself. Note that if the root type of Typ is an ancestor
-- unconstrained nominal subtype, then it acquired its constraints -- of Expr's type, both types share the same dispatch table and
-- from the expression in the first place, and not only does this -- there is no need to displace the pointer.
-- mean that the constraint check is not needed, but an attempt to
-- perform the constraint check can cause order of elaboration
-- problems.
if not Is_Constr_Subt_For_U_Nominal (Typ) then elsif Comes_From_Source (N)
and then Is_Interface (Typ)
then
pragma Assert (Is_Class_Wide_Type (Typ));
-- If this is an allocator for an aggregate that has been if Tagged_Type_Expansion then
-- allocated in place, delay checks until assignments are declare
-- made, because the discriminants are not initialized. Iface : constant Entity_Id := Root_Type (Typ);
Expr_N : Node_Id := Expr;
Expr_Typ : Entity_Id;
if Nkind (Expr) = N_Allocator Decl_1 : Node_Id;
and then No_Initialization (Expr) Decl_2 : Node_Id;
then New_Expr : Node_Id;
null;
else
Apply_Constraint_Check (Expr, Typ);
-- If the expression has been marked as requiring a range begin
-- generate it now and reset the flag. -- If the original node of the expression was a conversion
-- to this specific class-wide interface type then we
-- restore the original node to generate code that
-- statically displaces the pointer to the interface
-- component.
if Do_Range_Check (Expr) then if not Comes_From_Source (Expr_N)
Set_Do_Range_Check (Expr, False); and then Nkind (Expr_N) = N_Unchecked_Type_Conversion
Generate_Range_Check (Expr, Typ, CE_Range_Check_Failed); and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion
end if; and then Etype (Original_Node (Expr_N)) = Typ
then
Rewrite (Expr_N, Original_Node (Expression (N)));
end if; end if;
-- Avoid expansion of redundant interface conversion
if Is_Interface (Etype (Expr_N))
and then Nkind (Expr_N) = N_Type_Conversion
and then Etype (Expr_N) = Typ
then
Expr_N := Expression (Expr_N);
Set_Expression (N, Expr_N);
end if; end if;
-- Ada 2005 (AI-251): Rewrite the expression that initializes a Expr_Typ := Base_Type (Etype (Expr_N));
-- class-wide object to ensure that we copy the full object,
-- unless we are targetting a VM where interfaces are handled by if Is_Class_Wide_Type (Expr_Typ) then
-- VM itself. Note that if the root type of Typ is an ancestor Expr_Typ := Root_Type (Expr_Typ);
-- of Expr's type, both types share the same dispatch table and end if;
-- there is no need to displace the pointer.
-- Replace -- Replace
-- CW : I'Class := Obj; -- CW : I'Class := Obj;
-- by -- by
-- Temp : I'Class := I'Class (Base_Address (Obj'Address)); -- Tmp : T := Obj;
-- CW : I'Class renames Displace (Temp, I'Tag); -- CW : I'Class renames TiC!(Tmp.I_Tag);
if Is_Interface (Typ) if Comes_From_Source (Expr_N)
and then Is_Class_Wide_Type (Typ) and then Nkind (Expr_N) = N_Identifier
and then and then not Is_Interface (Expr_Typ)
(Is_Class_Wide_Type (Etype (Expr)) and then (Expr_Typ = Etype (Expr_Typ)
or else or else not
not Is_Ancestor (Root_Type (Typ), Etype (Expr))) Is_Variable_Size_Record (Etype (Expr_Typ)))
and then Comes_From_Source (Def_Id)
and then Tagged_Type_Expansion
then then
declare
Decl_1 : Node_Id;
Decl_2 : Node_Id;
begin
Decl_1 := Decl_1 :=
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Defining_Identifier =>
Make_Defining_Identifier (Loc, Make_Defining_Identifier (Loc,
New_Internal_Name ('D')), New_Internal_Name ('D')),
Object_Definition => Object_Definition =>
Make_Attribute_Reference (Loc, New_Occurrence_Of (Expr_Typ, Loc),
Expression =>
Unchecked_Convert_To (Expr_Typ,
Relocate_Node (Expr_N)));
-- Statically reference the tag associated with the
-- interface
Decl_2 :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
New_Internal_Name ('D')),
Subtype_Mark =>
New_Occurrence_Of (Typ, Loc),
Name =>
Unchecked_Convert_To (Typ,
Make_Selected_Component (Loc,
Prefix => Prefix =>
New_Occurrence_Of New_Occurrence_Of
(Root_Type (Etype (Def_Id)), Loc), (Defining_Identifier (Decl_1), Loc),
Attribute_Name => Name_Class), Selector_Name =>
New_Reference_To
(Find_Interface_Tag (Expr_Typ, Iface),
Loc))));
Expression => -- General case:
Unchecked_Convert_To
(Class_Wide_Type (Root_Type (Etype (Def_Id))), -- Replace
-- IW : I'Class := Obj;
-- by
-- type Equiv_Record is record ... end record;
-- implicit subtype CW is <Class_Wide_Subtype>;
-- Temp : CW := CW!(Obj'Address);
-- IW : I'Class renames Displace (Temp, I'Tag);
else
-- Generate the equivalent record type
Expand_Subtype_From_Expr
(N => N,
Unc_Type => Typ,
Subtype_Indic => Object_Definition (N),
Exp => Expression (N));
if not Is_Interface (Etype (Expression (N))) then
New_Expr := Relocate_Node (Expression (N));
else
New_Expr :=
Make_Explicit_Dereference (Loc, Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Tag_Ptr), Unchecked_Convert_To (RTE (RE_Tag_Ptr),
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (RE_Base_Address),
Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Expr), Prefix => Relocate_Node (Expression (N)),
Attribute_Name => Name_Address))))))); Attribute_Name => Name_Address)));
end if;
Insert_Action (N, Decl_1); Decl_1 :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
New_Internal_Name ('D')),
Object_Definition =>
New_Occurrence_Of
(Etype (Object_Definition (N)), Loc),
Expression =>
Unchecked_Convert_To
(Etype (Object_Definition (N)), New_Expr));
Decl_2 := Decl_2 :=
Make_Object_Renaming_Declaration (Loc, Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Defining_Identifier =>
Make_Defining_Identifier (Loc, Make_Defining_Identifier (Loc,
New_Internal_Name ('D')), New_Internal_Name ('D')),
Subtype_Mark => Subtype_Mark =>
Make_Attribute_Reference (Loc, New_Occurrence_Of (Typ, Loc),
Prefix =>
New_Occurrence_Of
(Root_Type (Etype (Def_Id)), Loc),
Attribute_Name => Name_Class),
Name => Name =>
Unchecked_Convert_To ( Unchecked_Convert_To (Typ,
Class_Wide_Type (Root_Type (Etype (Def_Id))),
Make_Explicit_Dereference (Loc, Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Tag_Ptr), Unchecked_Convert_To (RTE (RE_Tag_Ptr),
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => Name =>
New_Reference_To (RTE (RE_Displace), Loc), New_Reference_To (RTE (RE_Displace), Loc),
Parameter_Associations => New_List ( Parameter_Associations => New_List (
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Prefix =>
New_Reference_To New_Occurrence_Of
(Defining_Identifier (Decl_1), Loc), (Defining_Identifier (Decl_1), Loc),
Attribute_Name => Name_Address), Attribute_Name => Name_Address),
...@@ -4619,10 +4662,11 @@ package body Exp_Ch3 is ...@@ -4619,10 +4662,11 @@ package body Exp_Ch3 is
New_Reference_To New_Reference_To
(Node (Node
(First_Elmt (First_Elmt
(Access_Disp_Table (Access_Disp_Table (Iface))),
(Root_Type (Typ)))),
Loc)))))))); Loc))))))));
end if;
Insert_Action (N, Decl_1);
Rewrite (N, Decl_2); Rewrite (N, Decl_2);
Analyze (N); Analyze (N);
...@@ -4638,9 +4682,42 @@ package body Exp_Ch3 is ...@@ -4638,9 +4682,42 @@ package body Exp_Ch3 is
Set_Chars (Defining_Identifier (N), Chars (Def_Id)); Set_Chars (Defining_Identifier (N), Chars (Def_Id));
Set_Homonym (Defining_Identifier (N), Homonym (Def_Id)); Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
Exchange_Entities (Defining_Identifier (N), Def_Id); Exchange_Entities (Defining_Identifier (N), Def_Id);
end;
end if;
return; return;
end;
else
-- In most cases, we must check that the initial value meets any
-- constraint imposed by the declared type. However, there is one
-- very important exception to this rule. If the entity has an
-- unconstrained nominal subtype, then it acquired its constraints
-- from the expression in the first place, and not only does this
-- mean that the constraint check is not needed, but an attempt to
-- perform the constraint check can cause order of elaboration
-- problems.
if not Is_Constr_Subt_For_U_Nominal (Typ) then
-- If this is an allocator for an aggregate that has been
-- allocated in place, delay checks until assignments are
-- made, because the discriminants are not initialized.
if Nkind (Expr) = N_Allocator
and then No_Initialization (Expr)
then
null;
else
Apply_Constraint_Check (Expr, Typ);
-- If the expression has been marked as requiring a range
-- generate it now and reset the flag.
if Do_Range_Check (Expr) then
Set_Do_Range_Check (Expr, False);
Generate_Range_Check (Expr, Typ, CE_Range_Check_Failed);
end if;
end if;
end if; end if;
-- If the type is controlled and not inherently limited, then -- If the type is controlled and not inherently limited, then
......
gcc/ada/exp_disp.adb
...@@ -6118,21 +6118,27 @@ package body Exp_Disp is ...@@ -6118,21 +6118,27 @@ package body Exp_Disp is
end loop; end loop;
end if; end if;
-- 3) At the end of Access_Disp_Table we add the entity of an access -- 3) At the end of Access_Disp_Table, if the type has user-defined
-- type declaration. It is used by Build_Get_Prim_Op_Address to -- primitives, we add the entity of an access type declaration that
-- expand dispatching calls through the primary dispatch table. -- is used by Build_Get_Prim_Op_Address to expand dispatching calls
-- through the primary dispatch table.
if UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))) = 0 then
Analyze_List (Result);
-- Generate: -- Generate:
-- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr; -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
-- type Typ_DT_Acc is access Typ_DT; -- type Typ_DT_Acc is access Typ_DT;
else
declare declare
Name_DT_Prims : constant Name_Id := Name_DT_Prims : constant Name_Id :=
New_External_Name (Tname, 'G'); New_External_Name (Tname, 'G');
Name_DT_Prims_Acc : constant Name_Id := Name_DT_Prims_Acc : constant Name_Id :=
New_External_Name (Tname, 'H'); New_External_Name (Tname, 'H');
DT_Prims : constant Entity_Id := DT_Prims : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_DT_Prims); Make_Defining_Identifier (Loc,
Name_DT_Prims);
DT_Prims_Acc : constant Entity_Id := DT_Prims_Acc : constant Entity_Id :=
Make_Defining_Identifier (Loc, Make_Defining_Identifier (Loc,
Name_DT_Prims_Acc); Name_DT_Prims_Acc);
...@@ -6165,17 +6171,18 @@ package body Exp_Disp is ...@@ -6165,17 +6171,18 @@ package body Exp_Disp is
-- Analyze the resulting list and suppress the generation of the -- Analyze the resulting list and suppress the generation of the
-- Init_Proc associated with the above array declaration because -- Init_Proc associated with the above array declaration because
-- we never use such type in object declarations; this type is only -- this type is never used in object declarations. It is only used
-- used to simplify the expansion associated with dispatching calls. -- to simplify the expansion associated with dispatching calls.
Analyze_List (Result); Analyze_List (Result);
Set_Suppress_Init_Proc (Base_Type (DT_Prims)); Set_Suppress_Init_Proc (Base_Type (DT_Prims));
-- Mark entity of dispatch table. Required by the backend to handle -- Mark entity of dispatch table. Required by the back end to
-- the properly. -- handle them properly.
Set_Is_Dispatch_Table_Entity (DT_Prims); Set_Is_Dispatch_Table_Entity (DT_Prims);
end; end;
end if;
Set_Ekind (DT_Ptr, E_Constant); Set_Ekind (DT_Ptr, E_Constant);
Set_Is_Tag (DT_Ptr); Set_Is_Tag (DT_Ptr);
......
gcc/ada/exp_dist.adb
...@@ -2755,11 +2755,11 @@ package body Exp_Dist is ...@@ -2755,11 +2755,11 @@ package body Exp_Dist is
--------------------------------------------- ---------------------------------------------
procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Called_Subprogram : constant Entity_Id := Entity (Name (N)); Called_Subprogram : constant Entity_Id := Entity (Name (N));
RCI_Package : constant Entity_Id := Scope (Called_Subprogram); RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
Loc : constant Source_Ptr := Sloc (N); RCI_Locator_Decl : Node_Id;
RCI_Locator : Node_Id; RCI_Locator : Entity_Id;
RCI_Cache : Entity_Id;
Calling_Stubs : Node_Id; Calling_Stubs : Node_Id;
E_Calling_Stubs : Entity_Id; E_Calling_Stubs : Entity_Id;
...@@ -2767,41 +2767,35 @@ package body Exp_Dist is ...@@ -2767,41 +2767,35 @@ package body Exp_Dist is
E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram); E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
if E_Calling_Stubs = Empty then if E_Calling_Stubs = Empty then
RCI_Cache := RCI_Locator_Table.Get (RCI_Package); RCI_Locator := RCI_Locator_Table.Get (RCI_Package);
if RCI_Cache = Empty then
RCI_Locator :=
RCI_Package_Locator
(Loc, Specification (Unit_Declaration_Node (RCI_Package)));
Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
-- The RCI_Locator package is inserted at the top level in the -- The RCI_Locator package and calling stub are is inserted at the
-- current unit, and must appear in the proper scope, so that it -- top level in the current unit, and must appear in the proper scope
-- is not prematurely removed by the GCC back-end. -- so that it is not prematurely removed by the GCC back end.
declare declare
Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
begin begin
if Ekind (Scop) = E_Package_Body then if Ekind (Scop) = E_Package_Body then
Push_Scope (Spec_Entity (Scop)); Push_Scope (Spec_Entity (Scop));
elsif Ekind (Scop) = E_Subprogram_Body then elsif Ekind (Scop) = E_Subprogram_Body then
Push_Scope Push_Scope
(Corresponding_Spec (Unit_Declaration_Node (Scop))); (Corresponding_Spec (Unit_Declaration_Node (Scop)));
else else
Push_Scope (Scop); Push_Scope (Scop);
end if; end if;
Analyze (RCI_Locator);
Pop_Scope;
end; end;
RCI_Cache := Defining_Unit_Name (RCI_Locator); if RCI_Locator = Empty then
RCI_Locator_Decl :=
RCI_Package_Locator
(Loc, Specification (Unit_Declaration_Node (RCI_Package)));
Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl);
Analyze (RCI_Locator_Decl);
RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl);
else else
RCI_Locator := Parent (RCI_Cache); RCI_Locator_Decl := Parent (RCI_Locator);
end if; end if;
Calling_Stubs := Build_Subprogram_Calling_Stubs Calling_Stubs := Build_Subprogram_Calling_Stubs
...@@ -2811,10 +2805,12 @@ package body Exp_Dist is ...@@ -2811,10 +2805,12 @@ package body Exp_Dist is
Asynchronous => Nkind (N) = N_Procedure_Call_Statement Asynchronous => Nkind (N) = N_Procedure_Call_Statement
and then and then
Is_Asynchronous (Called_Subprogram), Is_Asynchronous (Called_Subprogram),
Locator => RCI_Cache, Locator => RCI_Locator,
New_Name => New_Internal_Name ('S')); New_Name => New_Internal_Name ('S'));
Insert_After (RCI_Locator, Calling_Stubs); Insert_After (RCI_Locator_Decl, Calling_Stubs);
Analyze (Calling_Stubs); Analyze (Calling_Stubs);
Pop_Scope;
E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs)); E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
end if; end if;
......
gcc/ada/exp_util.adb
...@@ -1350,6 +1350,17 @@ package body Exp_Util is ...@@ -1350,6 +1350,17 @@ package body Exp_Util is
Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type))); Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
end if; end if;
-- Renamings of class-wide interface types require no equivalent
-- constrained type declarations because we only need to reference
-- the tag component associated with the interface.
elsif Present (N)
and then Nkind (N) = N_Object_Renaming_Declaration
and then Is_Interface (Unc_Type)
then
pragma Assert (Is_Class_Wide_Type (Unc_Type));
null;
-- In Ada95, nothing to be done if the type of the expression is -- In Ada95, nothing to be done if the type of the expression is
-- limited, because in this case the expression cannot be copied, -- limited, because in this case the expression cannot be copied,
-- and its use can only be by reference. -- and its use can only be by reference.
...@@ -1371,16 +1382,6 @@ package body Exp_Util is ...@@ -1371,16 +1382,6 @@ package body Exp_Util is
then then
null; null;
-- For limited interfaces, nothing to be done
-- This branch may be redundant once the limited interface issue is
-- sorted out???
elsif Is_Interface (Exp_Typ)
and then Is_Limited_Interface (Exp_Typ)
then
null;
-- For limited objects initialized with build in place function calls, -- For limited objects initialized with build in place function calls,
-- nothing to be done; otherwise we prematurely introduce an N_Reference -- nothing to be done; otherwise we prematurely introduce an N_Reference
-- node in the expression initializing the object, which breaks the -- node in the expression initializing the object, which breaks the
...@@ -1546,15 +1547,10 @@ package body Exp_Util is ...@@ -1546,15 +1547,10 @@ package body Exp_Util is
AI : Node_Id; AI : Node_Id;
begin begin
-- Check if the interface is an immediate ancestor of the type and -- This routine does not handle the case in which the interface is an
-- therefore shares the main tag. -- ancestor of Typ. That case is handled by the enclosing subprogram.
if Typ = Iface then pragma Assert (Typ /= Iface);
pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
AI_Tag := First_Tag_Component (Typ);
Found := True;
return;
end if;
-- Climb to the root type handling private types -- Climb to the root type handling private types
...@@ -1632,9 +1628,20 @@ package body Exp_Util is ...@@ -1632,9 +1628,20 @@ package body Exp_Util is
Typ := Corresponding_Record_Type (Typ); Typ := Corresponding_Record_Type (Typ);
end if; end if;
-- If the interface is an ancestor of the type, then it shared the
-- primary dispatch table.
if Is_Ancestor (Iface, Typ) then
pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
return First_Tag_Component (Typ);
-- Otherwise we need to search for its associated tag component
else
Find_Tag (Typ); Find_Tag (Typ);
pragma Assert (Found); pragma Assert (Found);
return AI_Tag; return AI_Tag;
end if;
end Find_Interface_Tag; end Find_Interface_Tag;
------------------ ------------------
......
gcc/ada/gnatcmd.adb
...@@ -2117,16 +2117,16 @@ begin ...@@ -2117,16 +2117,16 @@ begin
end if; end if;
end loop; end loop;
-- If the naming scheme of the project file is not standard, -- If the project file naming scheme is not standard, and if
-- and if the file name ends with the spec suffix, then -- the file name ends with the spec suffix, then indicate to
-- indicate to gnatstub the name of the body file with -- gnatstub the name of the body file with a -o switch.
-- a -o switch.
if Is_Standard_GNAT_Naming (Lang.Config.Naming_Data) then if not Is_Standard_GNAT_Naming (Lang.Config.Naming_Data) then
if File_Index /= 0 then if File_Index /= 0 then
declare declare
Spec : constant String := Spec : constant String :=
Base_Name (Last_Switches.Table (File_Index).all); Base_Name
(Last_Switches.Table (File_Index).all);
Last : Natural := Spec'Last; Last : Natural := Spec'Last;
begin begin
...@@ -2193,8 +2193,7 @@ begin ...@@ -2193,8 +2193,7 @@ begin
end if; end if;
-- For gnat check, -rules and the following switches need to be the -- For gnat check, -rules and the following switches need to be the
-- last options. So, we move all these switches to table -- last options, so move all these switches to table Rules_Switches.
-- Rules_Switches.
if The_Command = Check then if The_Command = Check then
declare declare
......
gcc/ada/prj-err.adb
...@@ -113,7 +113,9 @@ package body Prj.Err is ...@@ -113,7 +113,9 @@ package body Prj.Err is
-- Let the application know there was an error -- Let the application know there was an error
if Flags.Report_Error /= null then if Flags.Report_Error /= null then
Flags.Report_Error (Project, Is_Warning => Msg (Msg'First) = '?'); Flags.Report_Error
(Project,
Is_Warning => Msg (Msg'First) = '?' or Msg (Msg'First) = '<');
end if; end if;
end Error_Msg; end Error_Msg;
......
gcc/ada/sem_ch3.adb
...@@ -591,7 +591,7 @@ package body Sem_Ch3 is ...@@ -591,7 +591,7 @@ package body Sem_Ch3 is
function Is_Progenitor function Is_Progenitor
(Iface : Entity_Id; (Iface : Entity_Id;
Typ : Entity_Id) return Boolean; Typ : Entity_Id) return Boolean;
-- Determine whether type Typ implements interface Iface. This requires -- Determine whether the interface Iface is implemented by Typ. It requires
-- traversing the list of abstract interfaces of the type, as well as that -- traversing the list of abstract interfaces of the type, as well as that
-- of the ancestor types. The predicate is used to determine when a formal -- of the ancestor types. The predicate is used to determine when a formal
-- in the signature of an inherited operation must carry the derived type. -- in the signature of an inherited operation must carry the derived type.
...@@ -2725,6 +2725,13 @@ package body Sem_Ch3 is ...@@ -2725,6 +2725,13 @@ package body Sem_Ch3 is
then then
Act_T := Etype (E); Act_T := Etype (E);
-- In case of class-wide interface object declarations we delay
-- the generation of the equivalent record type declarations until
-- its expansion because there are cases in they are not required.
elsif Is_Interface (T) then
null;
else else
Expand_Subtype_From_Expr (N, T, Object_Definition (N), E); Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
Act_T := Find_Type_Of_Object (Object_Definition (N), N); Act_T := Find_Type_Of_Object (Object_Definition (N), N);
......
gcc/ada/sem_disp.adb
...@@ -105,15 +105,13 @@ package body Sem_Disp is ...@@ -105,15 +105,13 @@ package body Sem_Disp is
begin begin
Formal := First_Formal (Subp); Formal := First_Formal (Subp);
while Present (Formal) loop while Present (Formal) loop
Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp); Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
if Present (Ctrl_Type) then if Present (Ctrl_Type) then
-- When the controlling type is concurrent and declared within a -- When controlling type is concurrent and declared within a
-- generic or inside an instance, use its corresponding record -- generic or inside an instance use corresponding record type.
-- type.
if Is_Concurrent_Type (Ctrl_Type) if Is_Concurrent_Type (Ctrl_Type)
and then Present (Corresponding_Record_Type (Ctrl_Type)) and then Present (Corresponding_Record_Type (Ctrl_Type))
...@@ -124,7 +122,7 @@ package body Sem_Disp is ...@@ -124,7 +122,7 @@ package body Sem_Disp is
if Ctrl_Type = Typ then if Ctrl_Type = Typ then
Set_Is_Controlling_Formal (Formal); Set_Is_Controlling_Formal (Formal);
-- Ada 2005 (AI-231): Anonymous access types used in -- Ada 2005 (AI-231): Anonymous access types that are used in
-- controlling parameters exclude null because it is necessary -- controlling parameters exclude null because it is necessary
-- to read the tag to dispatch, and null has no tag. -- to read the tag to dispatch, and null has no tag.
...@@ -178,7 +176,10 @@ package body Sem_Disp is ...@@ -178,7 +176,10 @@ package body Sem_Disp is
Next_Formal (Formal); Next_Formal (Formal);
end loop; end loop;
if Present (Etype (Subp)) then if Ekind (Subp) = E_Function
or else
Ekind (Subp) = E_Generic_Function
then
Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp); Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
if Present (Ctrl_Type) then if Present (Ctrl_Type) then
...@@ -426,14 +427,12 @@ package body Sem_Disp is ...@@ -426,14 +427,12 @@ package body Sem_Disp is
else else
Par := Parent (N); Par := Parent (N);
while Present (Par) loop while Present (Par) loop
if Nkind_In (Par, N_Function_Call,
if (Nkind (Par) = N_Function_Call or else N_Procedure_Call_Statement,
Nkind (Par) = N_Procedure_Call_Statement or else N_Assignment_Statement,
Nkind (Par) = N_Assignment_Statement or else N_Op_Eq,
Nkind (Par) = N_Op_Eq or else N_Op_Ne)
Nkind (Par) = N_Op_Ne)
and then Is_Tagged_Type (Etype (Subp)) and then Is_Tagged_Type (Etype (Subp))
then then
return; return;
...@@ -471,11 +470,10 @@ package body Sem_Disp is ...@@ -471,11 +470,10 @@ package body Sem_Disp is
-- Find a controlling argument, if any -- Find a controlling argument, if any
if Present (Parameter_Associations (N)) then if Present (Parameter_Associations (N)) then
Actual := First_Actual (N);
Subp_Entity := Entity (Name (N)); Subp_Entity := Entity (Name (N));
Formal := First_Formal (Subp_Entity);
Actual := First_Actual (N);
Formal := First_Formal (Subp_Entity);
while Present (Actual) loop while Present (Actual) loop
Control := Find_Controlling_Arg (Actual); Control := Find_Controlling_Arg (Actual);
exit when Present (Control); exit when Present (Control);
...@@ -544,7 +542,6 @@ package body Sem_Disp is ...@@ -544,7 +542,6 @@ package body Sem_Disp is
end if; end if;
Actual := First_Actual (N); Actual := First_Actual (N);
while Present (Actual) loop while Present (Actual) loop
if Actual /= Control then if Actual /= Control then
...@@ -866,7 +863,7 @@ package body Sem_Disp is ...@@ -866,7 +863,7 @@ package body Sem_Disp is
-- If the type is already frozen, the overriding is not allowed -- If the type is already frozen, the overriding is not allowed
-- except when Old_Subp is not a dispatching operation (which can -- except when Old_Subp is not a dispatching operation (which can
-- occur when Old_Subp was inherited by an untagged type). However, -- occur when Old_Subp was inherited by an untagged type). However,
-- a body with no previous spec freezes the type "after" its -- a body with no previous spec freezes the type *after* its
-- declaration, and therefore is a legal overriding (unless the type -- declaration, and therefore is a legal overriding (unless the type
-- has already been frozen). Only the first such body is legal. -- has already been frozen). Only the first such body is legal.
...@@ -880,7 +877,7 @@ package body Sem_Disp is ...@@ -880,7 +877,7 @@ package body Sem_Disp is
then then
declare declare
Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp); Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
Decl_Item : Node_Id := Next (Parent (Tagged_Type)); Decl_Item : Node_Id;
begin begin
-- ??? The checks here for whether the type has been -- ??? The checks here for whether the type has been
...@@ -899,6 +896,7 @@ package body Sem_Disp is ...@@ -899,6 +896,7 @@ package body Sem_Disp is
-- then the type has been frozen already so the overriding -- then the type has been frozen already so the overriding
-- primitive is illegal. -- primitive is illegal.
Decl_Item := Next (Parent (Tagged_Type));
while Present (Decl_Item) while Present (Decl_Item)
and then (Decl_Item /= Subp_Body) and then (Decl_Item /= Subp_Body)
loop loop
...@@ -1166,8 +1164,10 @@ package body Sem_Disp is ...@@ -1166,8 +1164,10 @@ package body Sem_Disp is
elsif Has_Controlled_Component (Tagged_Type) elsif Has_Controlled_Component (Tagged_Type)
and then and then
(Chars (Subp) = Name_Initialize (Chars (Subp) = Name_Initialize
or else Chars (Subp) = Name_Adjust or else
or else Chars (Subp) = Name_Finalize) Chars (Subp) = Name_Adjust
or else
Chars (Subp) = Name_Finalize)
then then
declare declare
F_Node : constant Node_Id := Freeze_Node (Tagged_Type); F_Node : constant Node_Id := Freeze_Node (Tagged_Type);
...@@ -1187,13 +1187,13 @@ package body Sem_Disp is ...@@ -1187,13 +1187,13 @@ package body Sem_Disp is
TSS_Deep_Finalize); TSS_Deep_Finalize);
begin begin
-- Remove previous controlled function, which was constructed -- Remove previous controlled function which was constructed and
-- and analyzed when the type was frozen. This requires -- analyzed when the type was frozen. This requires removing the
-- removing the body of the redefined primitive, as well as -- body of the redefined primitive, as well as its specification
-- its specification if needed (there is no spec created for -- if needed (there is no spec created for Deep_Initialize, see
-- Deep_Initialize, see exp_ch3.adb). We must also dismantle -- exp_ch3.adb). We must also dismantle the exception information
-- the exception information that may have been generated for -- that may have been generated for it when front end zero-cost
-- it when front end zero-cost tables are enabled. -- tables are enabled.
for J in D_Names'Range loop for J in D_Names'Range loop
Old_P := TSS (Tagged_Type, D_Names (J)); Old_P := TSS (Tagged_Type, D_Names (J));
...@@ -1217,9 +1217,9 @@ package body Sem_Disp is ...@@ -1217,9 +1217,9 @@ package body Sem_Disp is
Build_Late_Proc (Tagged_Type, Chars (Subp)); Build_Late_Proc (Tagged_Type, Chars (Subp));
-- The new operation is added to the actions of the freeze -- The new operation is added to the actions of the freeze node
-- node for the type, but this node has already been analyzed, -- for the type, but this node has already been analyzed, so we
-- so we must retrieve and analyze explicitly the new body. -- must retrieve and analyze explicitly the new body.
if Present (F_Node) if Present (F_Node)
and then Present (Actions (F_Node)) and then Present (Actions (F_Node))
...@@ -1264,14 +1264,10 @@ package body Sem_Disp is ...@@ -1264,14 +1264,10 @@ package body Sem_Disp is
F1 := First_Formal (Proc); F1 := First_Formal (Proc);
F2 := First_Formal (Subp); F2 := First_Formal (Subp);
while Present (F1) and then Present (F2) loop while Present (F1) and then Present (F2) loop
if Ekind (Etype (F1)) = E_Anonymous_Access_Type then if Ekind (Etype (F1)) = E_Anonymous_Access_Type then
if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then
return False; return False;
elsif Designated_Type (Etype (F1)) = Parent_Typ elsif Designated_Type (Etype (F1)) = Parent_Typ
and then Designated_Type (Etype (F2)) /= Full and then Designated_Type (Etype (F2)) /= Full
then then
...@@ -1304,11 +1300,8 @@ package body Sem_Disp is ...@@ -1304,11 +1300,8 @@ package body Sem_Disp is
Op1 := First_Elmt (Old_Prim); Op1 := First_Elmt (Old_Prim);
Op2 := First_Elmt (New_Prim); Op2 := First_Elmt (New_Prim);
while Present (Op1) and then Present (Op2) loop while Present (Op1) and then Present (Op2) loop
if Derives_From (Node (Op1)) then if Derives_From (Node (Op1)) then
if No (Prev) then if No (Prev) then
-- Avoid adding it to the list of primitives if already there! -- Avoid adding it to the list of primitives if already there!
...@@ -1371,6 +1364,7 @@ package body Sem_Disp is ...@@ -1371,6 +1364,7 @@ package body Sem_Disp is
then then
declare declare
Formal : Entity_Id; Formal : Entity_Id;
begin begin
Formal := First_Formal (Old_Subp); Formal := First_Formal (Old_Subp);
while Present (Formal) loop while Present (Formal) loop
...@@ -1397,8 +1391,8 @@ package body Sem_Disp is ...@@ -1397,8 +1391,8 @@ package body Sem_Disp is
-- Otherwise, update its alias and other attributes. -- Otherwise, update its alias and other attributes.
if Present (Alias (Old_Subp)) if Present (Alias (Old_Subp))
and then Nkind (Unit_Declaration_Node (Old_Subp)) and then Nkind (Unit_Declaration_Node (Old_Subp)) /=
/= N_Subprogram_Renaming_Declaration N_Subprogram_Renaming_Declaration
then then
Set_Alias (Old_Subp, Alias (Subp)); Set_Alias (Old_Subp, Alias (Subp));
...@@ -1461,24 +1455,22 @@ package body Sem_Disp is ...@@ -1461,24 +1455,22 @@ package body Sem_Disp is
Typ := Etype (N); Typ := Etype (N);
if Is_Access_Type (Typ) then if Is_Access_Type (Typ) then
-- In the case of an Access attribute, use the type of
-- the prefix, since in the case of an actual for an -- In the case of an Access attribute, use the type of the prefix,
-- access parameter, the attribute's type may be of a -- since in the case of an actual for an access parameter, the
-- specific designated type, even though the prefix -- attribute's type may be of a specific designated type, even
-- type is class-wide. -- though the prefix type is class-wide.
if Nkind (N) = N_Attribute_Reference then if Nkind (N) = N_Attribute_Reference then
Typ := Etype (Prefix (N)); Typ := Etype (Prefix (N));
-- An allocator is dispatching if the type of qualified -- An allocator is dispatching if the type of qualified expression
-- expression is class_wide, in which case this is the -- is class_wide, in which case this is the controlling type.
-- controlling type.
elsif Nkind (Orig_Node) = N_Allocator elsif Nkind (Orig_Node) = N_Allocator
and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression
then then
Typ := Etype (Expression (Orig_Node)); Typ := Etype (Expression (Orig_Node));
else else
Typ := Designated_Type (Typ); Typ := Designated_Type (Typ);
end if; end if;
...@@ -1560,6 +1552,7 @@ package body Sem_Disp is ...@@ -1560,6 +1552,7 @@ package body Sem_Disp is
end if; end if;
end if; end if;
pragma Assert (not Is_Dispatching_Operation (Subp));
return Empty; return Empty;
end Find_Dispatching_Type; end Find_Dispatching_Type;
...@@ -1800,9 +1793,9 @@ package body Sem_Disp is ...@@ -1800,9 +1793,9 @@ package body Sem_Disp is
elsif Nkind (Actual) = N_Identifier elsif Nkind (Actual) = N_Identifier
and then Nkind (Original_Node (Actual)) = N_Function_Call and then Nkind (Original_Node (Actual)) = N_Function_Call
then then
-- Call rewritten as object declaration when stack-checking -- Call rewritten as object declaration when stack-checking is
-- is enabled. Propagate tag to expression in declaration, which -- enabled. Propagate tag to expression in declaration, which is
-- is original call. -- original call.
Call_Node := Expression (Parent (Entity (Actual))); Call_Node := Expression (Parent (Entity (Actual)));
...@@ -1823,8 +1816,8 @@ package body Sem_Disp is ...@@ -1823,8 +1816,8 @@ package body Sem_Disp is
Call_Node := Expression (Actual); Call_Node := Expression (Actual);
end if; end if;
-- Do not set the Controlling_Argument if already set. This happens -- Do not set the Controlling_Argument if already set. This happens in
-- in the special case of _Input (see Exp_Attr, case Input). -- the special case of _Input (see Exp_Attr, case Input).
if No (Controlling_Argument (Call_Node)) then if No (Controlling_Argument (Call_Node)) then
Set_Controlling_Argument (Call_Node, Control); Set_Controlling_Argument (Call_Node, Control);
...@@ -1841,8 +1834,8 @@ package body Sem_Disp is ...@@ -1841,8 +1834,8 @@ package body Sem_Disp is
end loop; end loop;
-- Expansion of dispatching calls is suppressed when VM_Target, because -- Expansion of dispatching calls is suppressed when VM_Target, because
-- the VM back-ends directly handle the generation of dispatching -- the VM back-ends directly handle the generation of dispatching calls
-- calls and would have to undo any expansion to an indirect call. -- and would have to undo any expansion to an indirect call.
if Tagged_Type_Expansion then if Tagged_Type_Expansion then
Expand_Dispatching_Call (Call_Node); Expand_Dispatching_Call (Call_Node);
......
gcc/ada/sem_util.adb
...@@ -4937,26 +4937,22 @@ package body Sem_Util is ...@@ -4937,26 +4937,22 @@ package body Sem_Util is
is is
Ifaces_List : Elist_Id; Ifaces_List : Elist_Id;
Elmt : Elmt_Id; Elmt : Elmt_Id;
Iface : Entity_Id; Iface : Entity_Id := Base_Type (Iface_Ent);
Typ : Entity_Id; Typ : Entity_Id := Base_Type (Typ_Ent);
begin begin
if Is_Class_Wide_Type (Typ_Ent) then if Is_Class_Wide_Type (Typ) then
Typ := Etype (Typ_Ent); Typ := Root_Type (Typ);
else
Typ := Typ_Ent;
end if;
if Is_Class_Wide_Type (Iface_Ent) then
Iface := Etype (Iface_Ent);
else
Iface := Iface_Ent;
end if; end if;
if not Has_Interfaces (Typ) then if not Has_Interfaces (Typ) then
return False; return False;
end if; end if;
if Is_Class_Wide_Type (Iface) then
Iface := Root_Type (Iface);
end if;
Collect_Interfaces (Typ, Ifaces_List); Collect_Interfaces (Typ, Ifaces_List);
Elmt := First_Elmt (Ifaces_List); Elmt := First_Elmt (Ifaces_List);
......
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