OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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
This commit is contained in:
Arnaud Charlet 2009-07-13 14:17:53 +02:00
parent 75069667df
commit 0e41a941ee
10 changed files with 420 additions and 295 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
gcc/ada/ChangeLog
View File

@ -1,3 +1,44 @@
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>
* mingw32.h: Make it explicit that we need XP or later.

303
gcc/ada/exp_ch3.adb
View File

@ -4497,6 +4497,196 @@ package body Exp_Ch3 is
return;
-- Ada 2005 (AI-251): Rewrite the expression that initializes a
-- class-wide object to ensure that we copy the full object,
-- unless we are targetting a VM where interfaces are handled by
-- VM itself. Note that if the root type of Typ is an ancestor
-- of Expr's type, both types share the same dispatch table and
-- there is no need to displace the pointer.
elsif Comes_From_Source (N)
and then Is_Interface (Typ)
then
pragma Assert (Is_Class_Wide_Type (Typ));
if Tagged_Type_Expansion then
declare
Iface : constant Entity_Id := Root_Type (Typ);
Expr_N : Node_Id := Expr;
Expr_Typ : Entity_Id;
Decl_1 : Node_Id;
Decl_2 : Node_Id;
New_Expr : Node_Id;
begin
-- 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 not Comes_From_Source (Expr_N)
and then Nkind (Expr_N) = N_Unchecked_Type_Conversion
and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion
and then Etype (Original_Node (Expr_N)) = Typ
then
Rewrite (Expr_N, Original_Node (Expression (N)));
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;
Expr_Typ := Base_Type (Etype (Expr_N));
if Is_Class_Wide_Type (Expr_Typ) then
Expr_Typ := Root_Type (Expr_Typ);
end if;
-- Replace
-- CW : I'Class := Obj;
-- by
-- Tmp : T := Obj;
-- CW : I'Class renames TiC!(Tmp.I_Tag);
if Comes_From_Source (Expr_N)
and then Nkind (Expr_N) = N_Identifier
and then not Is_Interface (Expr_Typ)
and then (Expr_Typ = Etype (Expr_Typ)
or else not
Is_Variable_Size_Record (Etype (Expr_Typ)))
then
Decl_1 :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
New_Internal_Name ('D')),
Object_Definition =>
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 =>
New_Occurrence_Of
(Defining_Identifier (Decl_1), Loc),
Selector_Name =>
New_Reference_To
(Find_Interface_Tag (Expr_Typ, Iface),
Loc))));
-- General case:
-- 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,
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Expression (N)),
Attribute_Name => Name_Address)));
end if;
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 :=
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_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (RE_Displace), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of
(Defining_Identifier (Decl_1), Loc),
Attribute_Name => Name_Address),
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Node
(First_Elmt
(Access_Disp_Table (Iface))),
Loc))))))));
end if;
Insert_Action (N, Decl_1);
Rewrite (N, Decl_2);
Analyze (N);
-- Replace internal identifier of Decl_2 by the identifier
-- found in the sources. We also have to exchange entities
-- containing their defining identifiers to ensure the
-- correct replacement of the object declaration by this
-- object renaming declaration (because such definings
-- identifier have been previously added by Enter_Name to
-- the current scope). We must preserve the homonym chain
-- of the source entity as well.
Set_Chars (Defining_Identifier (N), Chars (Def_Id));
Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
Exchange_Entities (Defining_Identifier (N), Def_Id);
end;
end if;
return;
else
-- In most cases, we must check that the initial value meets any
-- constraint imposed by the declared type. However, there is one
@ -4530,119 +4720,6 @@ package body Exp_Ch3 is
end if;
end if;
-- Ada 2005 (AI-251): Rewrite the expression that initializes a
-- class-wide object to ensure that we copy the full object,
-- unless we are targetting a VM where interfaces are handled by
-- VM itself. Note that if the root type of Typ is an ancestor
-- of Expr's type, both types share the same dispatch table and
-- there is no need to displace the pointer.
-- Replace
-- CW : I'Class := Obj;
-- by
-- Temp : I'Class := I'Class (Base_Address (Obj'Address));
-- CW : I'Class renames Displace (Temp, I'Tag);
if Is_Interface (Typ)
and then Is_Class_Wide_Type (Typ)
and then
(Is_Class_Wide_Type (Etype (Expr))
or else
not Is_Ancestor (Root_Type (Typ), Etype (Expr)))
and then Comes_From_Source (Def_Id)
and then Tagged_Type_Expansion
then
declare
Decl_1 : Node_Id;
Decl_2 : Node_Id;
begin
Decl_1 :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
New_Internal_Name ('D')),
Object_Definition =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of
(Root_Type (Etype (Def_Id)), Loc),
Attribute_Name => Name_Class),
Expression =>
Unchecked_Convert_To
(Class_Wide_Type (Root_Type (Etype (Def_Id))),
Make_Explicit_Dereference (Loc,
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,
Prefix => Relocate_Node (Expr),
Attribute_Name => Name_Address)))))));
Insert_Action (N, Decl_1);
Decl_2 :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
New_Internal_Name ('D')),
Subtype_Mark =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of
(Root_Type (Etype (Def_Id)), Loc),
Attribute_Name => Name_Class),
Name =>
Unchecked_Convert_To (
Class_Wide_Type (Root_Type (Etype (Def_Id))),
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (RE_Displace), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To
(Defining_Identifier (Decl_1), Loc),
Attribute_Name => Name_Address),
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Node
(First_Elmt
(Access_Disp_Table
(Root_Type (Typ)))),
Loc))))))));
Rewrite (N, Decl_2);
Analyze (N);
-- Replace internal identifier of Decl_2 by the identifier
-- found in the sources. We also have to exchange entities
-- containing their defining identifiers to ensure the
-- correct replacement of the object declaration by this
-- object renaming declaration (because such definings
-- identifier have been previously added by Enter_Name to
-- the current scope). We must preserve the homonym chain
-- of the source entity as well.
Set_Chars (Defining_Identifier (N), Chars (Def_Id));
Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
Exchange_Entities (Defining_Identifier (N), Def_Id);
return;
end;
end if;
-- If the type is controlled and not inherently limited, then
-- the target is adjusted after the copy and attached to the
-- finalization list. However, no adjustment is done in the case

101
gcc/ada/exp_disp.adb
View File

@ -6118,64 +6118,71 @@ package body Exp_Disp is
end loop;
end if;
-- 3) At the end of Access_Disp_Table we add the entity of an access
-- type declaration. It is used by Build_Get_Prim_Op_Address to
-- expand dispatching calls through the primary dispatch table.
-- 3) At the end of Access_Disp_Table, if the type has user-defined
-- primitives, we add the entity of an access type declaration that
-- 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:
-- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
-- type Typ_DT_Acc is access Typ_DT;
declare
Name_DT_Prims : constant Name_Id :=
New_External_Name (Tname, 'G');
Name_DT_Prims_Acc : constant Name_Id :=
New_External_Name (Tname, 'H');
DT_Prims : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_DT_Prims);
DT_Prims_Acc : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Name_DT_Prims_Acc);
begin
Append_To (Result,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => DT_Prims,
Type_Definition =>
Make_Constrained_Array_Definition (Loc,
Discrete_Subtype_Definitions => New_List (
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 1),
High_Bound => Make_Integer_Literal (Loc,
DT_Entry_Count
(First_Tag_Component (Typ))))),
Component_Definition =>
Make_Component_Definition (Loc,
else
declare
Name_DT_Prims : constant Name_Id :=
New_External_Name (Tname, 'G');
Name_DT_Prims_Acc : constant Name_Id :=
New_External_Name (Tname, 'H');
DT_Prims : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Name_DT_Prims);
DT_Prims_Acc : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Name_DT_Prims_Acc);
begin
Append_To (Result,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => DT_Prims,
Type_Definition =>
Make_Constrained_Array_Definition (Loc,
Discrete_Subtype_Definitions => New_List (
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 1),
High_Bound => Make_Integer_Literal (Loc,
DT_Entry_Count
(First_Tag_Component (Typ))))),
Component_Definition =>
Make_Component_Definition (Loc,
Subtype_Indication =>
New_Reference_To (RTE (RE_Prim_Ptr), Loc)))));
Append_To (Result,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => DT_Prims_Acc,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
New_Reference_To (RTE (RE_Prim_Ptr), Loc)))));
New_Occurrence_Of (DT_Prims, Loc))));
Append_To (Result,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => DT_Prims_Acc,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (DT_Prims, Loc))));
Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
-- Analyze the resulting list and suppress the generation of the
-- Init_Proc associated with the above array declaration because
-- this type is never used in object declarations. It is only used
-- to simplify the expansion associated with dispatching calls.
-- Analyze the resulting list and suppress the generation of the
-- Init_Proc associated with the above array declaration because
-- we never use such type in object declarations; this type is only
-- used to simplify the expansion associated with dispatching calls.
Analyze_List (Result);
Set_Suppress_Init_Proc (Base_Type (DT_Prims));
Analyze_List (Result);
Set_Suppress_Init_Proc (Base_Type (DT_Prims));
-- Mark entity of dispatch table. Required by the back end to
-- handle them properly.
-- Mark entity of dispatch table. Required by the backend to handle
-- the properly.
Set_Is_Dispatch_Table_Entity (DT_Prims);
end;
Set_Is_Dispatch_Table_Entity (DT_Prims);
end;
end if;
Set_Ekind (DT_Ptr, E_Constant);
Set_Is_Tag (DT_Ptr);

66
gcc/ada/exp_dist.adb
View File

@ -2755,11 +2755,11 @@ package body Exp_Dist 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));
RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
Loc : constant Source_Ptr := Sloc (N);
RCI_Locator : Node_Id;
RCI_Cache : Entity_Id;
RCI_Locator_Decl : Node_Id;
RCI_Locator : Entity_Id;
Calling_Stubs : Node_Id;
E_Calling_Stubs : Entity_Id;
@ -2767,41 +2767,35 @@ package body Exp_Dist is
E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
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 :=
-- The RCI_Locator package and calling stub are is inserted at the
-- top level in the current unit, and must appear in the proper scope
-- so that it is not prematurely removed by the GCC back end.
declare
Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
begin
if Ekind (Scop) = E_Package_Body then
Push_Scope (Spec_Entity (Scop));
elsif Ekind (Scop) = E_Subprogram_Body then
Push_Scope
(Corresponding_Spec (Unit_Declaration_Node (Scop)));
else
Push_Scope (Scop);
end if;
end;
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);
-- The RCI_Locator package is inserted at the top level in the
-- current unit, and must appear in the proper scope, so that it
-- is not prematurely removed by the GCC back-end.
declare
Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
begin
if Ekind (Scop) = E_Package_Body then
Push_Scope (Spec_Entity (Scop));
elsif Ekind (Scop) = E_Subprogram_Body then
Push_Scope
(Corresponding_Spec (Unit_Declaration_Node (Scop)));
else
Push_Scope (Scop);
end if;
Analyze (RCI_Locator);
Pop_Scope;
end;
RCI_Cache := Defining_Unit_Name (RCI_Locator);
Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl);
Analyze (RCI_Locator_Decl);
RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl);
else
RCI_Locator := Parent (RCI_Cache);
RCI_Locator_Decl := Parent (RCI_Locator);
end if;
Calling_Stubs := Build_Subprogram_Calling_Stubs
@ -2811,10 +2805,12 @@ package body Exp_Dist is
Asynchronous => Nkind (N) = N_Procedure_Call_Statement
and then
Is_Asynchronous (Called_Subprogram),
Locator => RCI_Cache,
Locator => RCI_Locator,
New_Name => New_Internal_Name ('S'));
Insert_After (RCI_Locator, Calling_Stubs);
Insert_After (RCI_Locator_Decl, Calling_Stubs);
Analyze (Calling_Stubs);
Pop_Scope;
E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
end if;

49
gcc/ada/exp_util.adb
View File

@ -1350,6 +1350,17 @@ package body Exp_Util is
Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
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
-- limited, because in this case the expression cannot be copied,
-- and its use can only be by reference.
@ -1371,16 +1382,6 @@ package body Exp_Util is
then
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,
-- nothing to be done; otherwise we prematurely introduce an N_Reference
-- node in the expression initializing the object, which breaks the
@ -1546,15 +1547,10 @@ package body Exp_Util is
AI : Node_Id;
begin
-- Check if the interface is an immediate ancestor of the type and
-- therefore shares the main tag.
-- This routine does not handle the case in which the interface is an
-- ancestor of Typ. That case is handled by the enclosing subprogram.
if Typ = Iface then
pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
AI_Tag := First_Tag_Component (Typ);
Found := True;
return;
end if;
pragma Assert (Typ /= Iface);
-- Climb to the root type handling private types
@ -1632,9 +1628,20 @@ package body Exp_Util is
Typ := Corresponding_Record_Type (Typ);
end if;
Find_Tag (Typ);
pragma Assert (Found);
return AI_Tag;
-- 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);
pragma Assert (Found);
return AI_Tag;
end if;
end Find_Interface_Tag;
------------------

15
gcc/ada/gnatcmd.adb
View File

@ -2117,16 +2117,16 @@ begin
end if;
end loop;
-- If the naming scheme of the project file is not standard,
-- and if the file name ends with the spec suffix, then
-- indicate to gnatstub the name of the body file with
-- a -o switch.
-- If the project file naming scheme is not standard, and if
-- the file name ends with the spec suffix, then indicate to
-- gnatstub the name of the body file with 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
declare
Spec : constant String :=
Base_Name (Last_Switches.Table (File_Index).all);
Base_Name
(Last_Switches.Table (File_Index).all);
Last : Natural := Spec'Last;
begin
@ -2193,8 +2193,7 @@ begin
end if;
-- For gnat check, -rules and the following switches need to be the
-- last options. So, we move all these switches to table
-- Rules_Switches.
-- last options, so move all these switches to table Rules_Switches.
if The_Command = Check then
declare

4
gcc/ada/prj-err.adb
View File

@ -113,7 +113,9 @@ package body Prj.Err is
-- Let the application know there was an error
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 Error_Msg;

11
gcc/ada/sem_ch3.adb
View File

@ -590,8 +590,8 @@ package body Sem_Ch3 is
function Is_Progenitor
(Iface : Entity_Id;
Typ : Entity_Id) return Boolean;
-- Determine whether type Typ implements interface Iface. This requires
Typ : Entity_Id) return Boolean;
-- Determine whether the interface Iface is implemented by Typ. It requires
-- 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
-- in the signature of an inherited operation must carry the derived type.
@ -2725,6 +2725,13 @@ package body Sem_Ch3 is
then
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
Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
Act_T := Find_Type_Of_Object (Object_Definition (N), N);

105
gcc/ada/sem_disp.adb
View File

@ -105,15 +105,13 @@ package body Sem_Disp is
begin
Formal := First_Formal (Subp);
while Present (Formal) loop
Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
if Present (Ctrl_Type) then
-- When the controlling type is concurrent and declared within a
-- generic or inside an instance, use its corresponding record
-- type.
-- When controlling type is concurrent and declared within a
-- generic or inside an instance use corresponding record type.
if Is_Concurrent_Type (Ctrl_Type)
and then Present (Corresponding_Record_Type (Ctrl_Type))
@ -124,7 +122,7 @@ package body Sem_Disp is
if Ctrl_Type = Typ then
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
-- to read the tag to dispatch, and null has no tag.
@ -178,7 +176,10 @@ package body Sem_Disp is
Next_Formal (Formal);
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);
if Present (Ctrl_Type) then
@ -426,14 +427,12 @@ package body Sem_Disp is
else
Par := Parent (N);
while Present (Par) loop
if (Nkind (Par) = N_Function_Call or else
Nkind (Par) = N_Procedure_Call_Statement or else
Nkind (Par) = N_Assignment_Statement or else
Nkind (Par) = N_Op_Eq or else
Nkind (Par) = N_Op_Ne)
if Nkind_In (Par, N_Function_Call,
N_Procedure_Call_Statement,
N_Assignment_Statement,
N_Op_Eq,
N_Op_Ne)
and then Is_Tagged_Type (Etype (Subp))
then
return;
@ -471,11 +470,10 @@ package body Sem_Disp is
-- Find a controlling argument, if any
if Present (Parameter_Associations (N)) then
Actual := First_Actual (N);
Subp_Entity := Entity (Name (N));
Formal := First_Formal (Subp_Entity);
Actual := First_Actual (N);
Formal := First_Formal (Subp_Entity);
while Present (Actual) loop
Control := Find_Controlling_Arg (Actual);
exit when Present (Control);
@ -544,7 +542,6 @@ package body Sem_Disp is
end if;
Actual := First_Actual (N);
while Present (Actual) loop
if Actual /= Control then
@ -866,7 +863,7 @@ package body Sem_Disp is
-- If the type is already frozen, the overriding is not allowed
-- except when Old_Subp is not a dispatching operation (which can
-- 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
-- has already been frozen). Only the first such body is legal.
@ -880,7 +877,7 @@ package body Sem_Disp is
then
declare
Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
Decl_Item : Node_Id := Next (Parent (Tagged_Type));
Decl_Item : Node_Id;
begin
-- ??? The checks here for whether the type has been
@ -899,6 +896,7 @@ package body Sem_Disp is
-- then the type has been frozen already so the overriding
-- primitive is illegal.
Decl_Item := Next (Parent (Tagged_Type));
while Present (Decl_Item)
and then (Decl_Item /= Subp_Body)
loop
@ -1166,8 +1164,10 @@ package body Sem_Disp is
elsif Has_Controlled_Component (Tagged_Type)
and then
(Chars (Subp) = Name_Initialize
or else Chars (Subp) = Name_Adjust
or else Chars (Subp) = Name_Finalize)
or else
Chars (Subp) = Name_Adjust
or else
Chars (Subp) = Name_Finalize)
then
declare
F_Node : constant Node_Id := Freeze_Node (Tagged_Type);
@ -1187,13 +1187,13 @@ package body Sem_Disp is
TSS_Deep_Finalize);
begin
-- Remove previous controlled function, which was constructed
-- and analyzed when the type was frozen. This requires
-- removing the body of the redefined primitive, as well as
-- its specification if needed (there is no spec created for
-- Deep_Initialize, see exp_ch3.adb). We must also dismantle
-- the exception information that may have been generated for
-- it when front end zero-cost tables are enabled.
-- Remove previous controlled function which was constructed and
-- analyzed when the type was frozen. This requires removing the
-- body of the redefined primitive, as well as its specification
-- if needed (there is no spec created for Deep_Initialize, see
-- exp_ch3.adb). We must also dismantle the exception information
-- that may have been generated for it when front end zero-cost
-- tables are enabled.
for J in D_Names'Range loop
Old_P := TSS (Tagged_Type, D_Names (J));
@ -1217,9 +1217,9 @@ package body Sem_Disp is
Build_Late_Proc (Tagged_Type, Chars (Subp));
-- The new operation is added to the actions of the freeze
-- node for the type, but this node has already been analyzed,
-- so we must retrieve and analyze explicitly the new body.
-- The new operation is added to the actions of the freeze node
-- for the type, but this node has already been analyzed, so we
-- must retrieve and analyze explicitly the new body.
if Present (F_Node)
and then Present (Actions (F_Node))
@ -1264,14 +1264,10 @@ package body Sem_Disp is
F1 := First_Formal (Proc);
F2 := First_Formal (Subp);
while Present (F1) and then Present (F2) loop
if Ekind (Etype (F1)) = E_Anonymous_Access_Type then
if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then
return False;
elsif Designated_Type (Etype (F1)) = Parent_Typ
and then Designated_Type (Etype (F2)) /= Full
then
@ -1304,11 +1300,8 @@ package body Sem_Disp is
Op1 := First_Elmt (Old_Prim);
Op2 := First_Elmt (New_Prim);
while Present (Op1) and then Present (Op2) loop
if Derives_From (Node (Op1)) then
if No (Prev) then
-- Avoid adding it to the list of primitives if already there!
@ -1371,6 +1364,7 @@ package body Sem_Disp is
then
declare
Formal : Entity_Id;
begin
Formal := First_Formal (Old_Subp);
while Present (Formal) loop
@ -1397,8 +1391,8 @@ package body Sem_Disp is
-- Otherwise, update its alias and other attributes.
if Present (Alias (Old_Subp))
and then Nkind (Unit_Declaration_Node (Old_Subp))
/= N_Subprogram_Renaming_Declaration
and then Nkind (Unit_Declaration_Node (Old_Subp)) /=
N_Subprogram_Renaming_Declaration
then
Set_Alias (Old_Subp, Alias (Subp));
@ -1461,24 +1455,22 @@ package body Sem_Disp is
Typ := Etype (N);
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
-- access parameter, the attribute's type may be of a
-- specific designated type, even though the prefix
-- type is class-wide.
-- In the case of an Access attribute, use the type of the prefix,
-- since in the case of an actual for an access parameter, the
-- attribute's type may be of a specific designated type, even
-- though the prefix type is class-wide.
if Nkind (N) = N_Attribute_Reference then
Typ := Etype (Prefix (N));
-- An allocator is dispatching if the type of qualified
-- expression is class_wide, in which case this is the
-- controlling type.
-- An allocator is dispatching if the type of qualified expression
-- is class_wide, in which case this is the controlling type.
elsif Nkind (Orig_Node) = N_Allocator
and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression
then
Typ := Etype (Expression (Orig_Node));
else
Typ := Designated_Type (Typ);
end if;
@ -1560,6 +1552,7 @@ package body Sem_Disp is
end if;
end if;
pragma Assert (not Is_Dispatching_Operation (Subp));
return Empty;
end Find_Dispatching_Type;
@ -1800,9 +1793,9 @@ package body Sem_Disp is
elsif Nkind (Actual) = N_Identifier
and then Nkind (Original_Node (Actual)) = N_Function_Call
then
-- Call rewritten as object declaration when stack-checking
-- is enabled. Propagate tag to expression in declaration, which
-- is original call.
-- Call rewritten as object declaration when stack-checking is
-- enabled. Propagate tag to expression in declaration, which is
-- original call.
Call_Node := Expression (Parent (Entity (Actual)));
@ -1823,8 +1816,8 @@ package body Sem_Disp is
Call_Node := Expression (Actual);
end if;
-- Do not set the Controlling_Argument if already set. This happens
-- in the special case of _Input (see Exp_Attr, case Input).
-- Do not set the Controlling_Argument if already set. This happens in
-- the special case of _Input (see Exp_Attr, case Input).
if No (Controlling_Argument (Call_Node)) then
Set_Controlling_Argument (Call_Node, Control);
@ -1841,8 +1834,8 @@ package body Sem_Disp is
end loop;
-- Expansion of dispatching calls is suppressed when VM_Target, because
-- the VM back-ends directly handle the generation of dispatching
-- calls and would have to undo any expansion to an indirect call.
-- the VM back-ends directly handle the generation of dispatching calls
-- and would have to undo any expansion to an indirect call.
if Tagged_Type_Expansion then
Expand_Dispatching_Call (Call_Node);

20
gcc/ada/sem_util.adb
View File

@ -4937,26 +4937,22 @@ package body Sem_Util is
is
Ifaces_List : Elist_Id;
Elmt : Elmt_Id;
Iface : Entity_Id;
Typ : Entity_Id;
Iface : Entity_Id := Base_Type (Iface_Ent);
Typ : Entity_Id := Base_Type (Typ_Ent);
begin
if Is_Class_Wide_Type (Typ_Ent) then
Typ := Etype (Typ_Ent);
else
Typ := Typ_Ent;
end if;
if Is_Class_Wide_Type (Iface_Ent) then
Iface := Etype (Iface_Ent);
else
Iface := Iface_Ent;
if Is_Class_Wide_Type (Typ) then
Typ := Root_Type (Typ);
end if;
if not Has_Interfaces (Typ) then
return False;
end if;
if Is_Class_Wide_Type (Iface) then
Iface := Root_Type (Iface);
end if;
Collect_Interfaces (Typ, Ifaces_List);
Elmt := First_Elmt (Ifaces_List);