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

[Ada] Fix conformance errors and erroneous code

Browse Source 
gcc/ada/

	* contracts.adb, einfo-utils.adb, einfo-utils.ads, exp_ch7.adb,
	exp_ch9.adb, exp_disp.adb, exp_prag.adb, exp_smem.adb,
	exp_util.adb, freeze.adb, sem_aggr.adb, sem_attr.adb,
	sem_ch8.adb, sem_prag.ads, sem_util.adb, sem_util.ads: Fix
	conformance errors.
	* errout.adb, erroutc.adb: Remove pragmas Suppress.
	* err_vars.ads: Initialize variables that were previously being
	read uninitialized.
This commit is contained in:
Bob Duff 2021-07-26 15:26:28 -04:00 committed by Pierre-Marie de Rodat
parent 490a987e05
commit c0471c61e1
19 changed files with 65 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/ada/contracts.adb
View File

@ -3440,7 +3440,7 @@ package body Contracts is
-- Get_Postcond_Enabled --
--------------------------
function Get_Postcond_Enabled (Subp : Entity_Id) return Node_Id is
function Get_Postcond_Enabled (Subp : Entity_Id) return Entity_Id is
Decl : Node_Id;
begin
Decl :=
@ -3465,7 +3465,7 @@ package body Contracts is
------------------------------------
function Get_Result_Object_For_Postcond
(Subp : Entity_Id) return Node_Id
(Subp : Entity_Id) return Entity_Id
is
Decl : Node_Id;
begin
@ -3490,7 +3490,7 @@ package body Contracts is
-- Get_Return_Success_For_Postcond --
-------------------------------------
function Get_Return_Success_For_Postcond (Subp : Entity_Id) return Node_Id
function Get_Return_Success_For_Postcond (Subp : Entity_Id) return Entity_Id
is
Decl : Node_Id;
begin

4
gcc/ada/einfo-utils.adb
View File

@ -701,7 +701,7 @@ package body Einfo.Utils is
-- Entry_Index_Type --
----------------------
function Entry_Index_Type (Id : E) return N is
function Entry_Index_Type (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Entry_Family);
return Etype (Discrete_Subtype_Definition (Parent (Id)));
@ -1745,7 +1745,7 @@ package body Einfo.Utils is
-- Link_Entities --
-------------------
procedure Link_Entities (First : Entity_Id; Second : Node_Id) is
procedure Link_Entities (First, Second : Entity_Id) is
begin
if Present (Second) then
Set_Prev_Entity (Second, First); -- First <-- Second

2
gcc/ada/einfo-utils.ads
View File

@ -625,7 +625,7 @@ package Einfo.Utils is
-- WARNING: There is a matching C declaration of this subprogram in fe.h
procedure Link_Entities (First : Entity_Id; Second : Entity_Id);
procedure Link_Entities (First, Second : Entity_Id);
-- Link entities First and Second in one entity chain.
--
-- NOTE: No updates are done to the First_Entity and Last_Entity fields

17
gcc/ada/err_vars.ads
View File

@ -105,12 +105,15 @@ package Err_Vars is
-- of the following global variables to appropriate values before making a
-- call to one of the error message routines with a string containing the
-- insertion character to get the value inserted in an appropriate format.
--
-- Some of these are initialized below, because they are read before being
-- set by clients.
Error_Msg_Col : Column_Number;
-- Column for @ insertion character in message
Error_Msg_Uint_1 : Uint;
Error_Msg_Uint_2 : Uint;
Error_Msg_Uint_2 : Uint := No_Uint;
-- Uint values for ^ insertion characters in message
-- WARNING: There is a matching C declaration of these variables in fe.h
@ -119,21 +122,21 @@ package Err_Vars is
-- Source location for # insertion character in message
Error_Msg_Name_1 : Name_Id;
Error_Msg_Name_2 : Name_Id;
Error_Msg_Name_3 : Name_Id;
Error_Msg_Name_2 : Name_Id := No_Name;
Error_Msg_Name_3 : Name_Id := No_Name;
-- Name_Id values for % insertion characters in message
Error_Msg_File_1 : File_Name_Type;
Error_Msg_File_2 : File_Name_Type;
Error_Msg_File_3 : File_Name_Type;
Error_Msg_File_2 : File_Name_Type := No_File;
Error_Msg_File_3 : File_Name_Type := No_File;
-- File_Name_Type values for { insertion characters in message
Error_Msg_Unit_1 : Unit_Name_Type;
Error_Msg_Unit_2 : Unit_Name_Type;
Error_Msg_Unit_2 : Unit_Name_Type := No_Unit_Name;
-- Unit_Name_Type values for $ insertion characters in message
Error_Msg_Node_1 : Node_Id;
Error_Msg_Node_2 : Node_Id;
Error_Msg_Node_2 : Node_Id := Empty;
-- Node_Id values for & insertion characters in message
Error_Msg_Warn : Boolean;

20
gcc/ada/errout.adb
View File

@ -3602,15 +3602,9 @@ package body Errout is
end if;
-- The following assignment ensures that a second ampersand insertion
-- character will correspond to the Error_Msg_Node_2 parameter. We
-- suppress possible validity checks in case operating in -gnatVa mode,
-- and Error_Msg_Node_2 is not needed and has not been set.
-- character will correspond to the Error_Msg_Node_2 parameter.
declare
pragma Suppress (Range_Check);
begin
Error_Msg_Node_1 := Error_Msg_Node_2;
end;
Error_Msg_Node_1 := Error_Msg_Node_2;
end Set_Msg_Insertion_Node;
--------------------------------------
@ -3790,15 +3784,9 @@ package body Errout is
end if;
-- The following assignment ensures that a second percent insertion
-- character will correspond to the Error_Msg_Unit_2 parameter. We
-- suppress possible validity checks in case operating in -gnatVa mode,
-- and Error_Msg_Unit_2 is not needed and has not been set.
-- character will correspond to the Error_Msg_Unit_2 parameter.
declare
pragma Suppress (Range_Check);
begin
Error_Msg_Unit_1 := Error_Msg_Unit_2;
end;
Error_Msg_Unit_1 := Error_Msg_Unit_2;
end Set_Msg_Insertion_Unit_Name;
------------------

48
gcc/ada/erroutc.adb
View File

@ -1119,17 +1119,11 @@ package body Erroutc is
end if;
-- The following assignments ensure that the second and third {
-- insertion characters will correspond to the Error_Msg_File_2 and
-- Error_Msg_File_3 values and We suppress possible validity checks in
-- case operating in -gnatVa mode, and Error_Msg_File_2 or
-- Error_Msg_File_3 is not needed and has not been set.
-- insertion characters will correspond to the Error_Msg_File_2
-- and Error_Msg_File_3 values.
declare
pragma Suppress (Range_Check);
begin
Error_Msg_File_1 := Error_Msg_File_2;
Error_Msg_File_2 := Error_Msg_File_3;
end;
Error_Msg_File_1 := Error_Msg_File_2;
Error_Msg_File_2 := Error_Msg_File_3;
end Set_Msg_Insertion_File_Name;
-----------------------------------
@ -1299,16 +1293,10 @@ package body Erroutc is
-- The following assignments ensure that the second and third percent
-- insertion characters will correspond to the Error_Msg_Name_2 and
-- Error_Msg_Name_3 as required. We suppress possible validity checks in
-- case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed
-- and has not been set.
-- Error_Msg_Name_3 as required.
declare
pragma Suppress (Range_Check);
begin
Error_Msg_Name_1 := Error_Msg_Name_2;
Error_Msg_Name_2 := Error_Msg_Name_3;
end;
Error_Msg_Name_1 := Error_Msg_Name_2;
Error_Msg_Name_2 := Error_Msg_Name_3;
end Set_Msg_Insertion_Name;
------------------------------------
@ -1334,16 +1322,10 @@ package body Erroutc is
-- The following assignments ensure that the second and third % or %%
-- insertion characters will correspond to the Error_Msg_Name_2 and
-- Error_Msg_Name_3 values and We suppress possible validity checks in
-- case operating in -gnatVa mode, and Error_Msg_Name_2 or
-- Error_Msg_Name_3 is not needed and has not been set.
-- Error_Msg_Name_3 values.
declare
pragma Suppress (Range_Check);
begin
Error_Msg_Name_1 := Error_Msg_Name_2;
Error_Msg_Name_2 := Error_Msg_Name_3;
end;
Error_Msg_Name_1 := Error_Msg_Name_2;
Error_Msg_Name_2 := Error_Msg_Name_3;
end Set_Msg_Insertion_Name_Literal;
-------------------------------------
@ -1427,15 +1409,9 @@ package body Erroutc is
end loop;
-- The following assignment ensures that a second caret insertion
-- character will correspond to the Error_Msg_Uint_2 parameter. We
-- suppress possible validity checks in case operating in -gnatVa mode,
-- and Error_Msg_Uint_2 is not needed and has not been set.
-- character will correspond to the Error_Msg_Uint_2 parameter.
declare
pragma Suppress (Range_Check);
begin
Error_Msg_Uint_1 := Error_Msg_Uint_2;
end;
Error_Msg_Uint_1 := Error_Msg_Uint_2;
end Set_Msg_Insertion_Uint;
-----------------

8
gcc/ada/exp_ch7.adb
View File

@ -486,11 +486,11 @@ package body Exp_Ch7 is
function Make_Deep_Proc
(Prim : Final_Primitives;
Typ : Entity_Id;
Stmts : List_Id) return Node_Id;
Stmts : List_Id) return Entity_Id;
-- This function generates the tree for Deep_Initialize, Deep_Adjust or
-- Deep_Finalize procedures according to the first parameter, these
-- procedures operate on the type Typ. The Stmts parameter gives the body
-- of the procedure.
-- Deep_Finalize procedures according to the first parameter. These
-- procedures operate on the type Typ. The Stmts parameter gives the
-- body of the procedure.
function Make_Deep_Array_Body
(Prim : Final_Primitives;

10
gcc/ada/exp_ch9.adb
View File

@ -145,7 +145,7 @@ package body Exp_Ch9 is
function Build_Corresponding_Record
(N : Node_Id;
Ctyp : Node_Id;
Ctyp : Entity_Id;
Loc : Source_Ptr) return Node_Id;
-- Common to tasks and protected types. Copy discriminant specifications,
-- build record declaration. N is the type declaration, Ctyp is the
@ -1583,9 +1583,9 @@ package body Exp_Ch9 is
--------------------------------
function Build_Corresponding_Record
(N : Node_Id;
Ctyp : Entity_Id;
Loc : Source_Ptr) return Node_Id
(N : Node_Id;
Ctyp : Entity_Id;
Loc : Source_Ptr) return Node_Id
is
Rec_Ent : constant Entity_Id :=
Make_Defining_Identifier
@ -14867,7 +14867,7 @@ package body Exp_Ch9 is
Actuals : List_Id;
Formals : List_Id;
Decls : List_Id;
Stmts : List_Id) return Node_Id
Stmts : List_Id) return Entity_Id
is
Actual : Entity_Id;
Expr : Node_Id := Empty;

2
gcc/ada/exp_disp.adb
View File

@ -348,7 +348,7 @@ package body Exp_Disp is
-- Build_Static_Dispatch_Tables --
----------------------------------
procedure Build_Static_Dispatch_Tables (N : Entity_Id) is
procedure Build_Static_Dispatch_Tables (N : Node_Id) is
Target_List : List_Id;
procedure Build_Dispatch_Tables (List : List_Id);

12
gcc/ada/exp_prag.adb
View File

@ -752,10 +752,10 @@ package body Exp_Prag is
-- value of which is Init_Val if present or null if not.
function Build_Simple_Declaration_With_Default
(Decl_Id : Entity_Id;
Init_Val : Entity_Id;
Typ : Entity_Id;
Default_Val : Entity_Id) return Node_Id;
(Decl_Id : Entity_Id;
Init_Val : Node_Id;
Typ : Node_Id;
Default_Val : Node_Id) return Node_Id;
-- Build a declaration the Defining_Identifier of which is Decl_Id, the
-- Object_Definition of which is Typ, the value of which is Init_Val if
-- present or Default otherwise.
@ -983,7 +983,7 @@ package body Exp_Prag is
function Build_Simple_Declaration_With_Default
(Decl_Id : Entity_Id;
Init_Val : Node_Id;
Typ : Entity_Id;
Typ : Node_Id;
Default_Val : Node_Id) return Node_Id
is
Value : Node_Id := Init_Val;
@ -2862,7 +2862,7 @@ package body Exp_Prag is
procedure Expand_Pragma_Subprogram_Variant
(Prag : Node_Id;
Subp_Id : Node_Id;
Subp_Id : Entity_Id;
Body_Decls : List_Id)
is
Curr_Decls : List_Id;

2
gcc/ada/exp_smem.adb
View File

@ -86,7 +86,7 @@ package body Exp_Smem is
function Build_Shared_Var_Proc_Call
(Loc : Source_Ptr;
E : Node_Id;
E : Entity_Id;
N : Name_Id) return Node_Id;
-- Build a call to support procedure N for shared object E (provided by the
-- instance of System.Shared_Storage.Shared_Var_Procs associated to E).

4
gcc/ada/exp_util.adb
View File

@ -4914,7 +4914,7 @@ package body Exp_Util is
-- Convert_To_Actual_Subtype --
-------------------------------
procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
procedure Convert_To_Actual_Subtype (Exp : Node_Id) is
Act_ST : Entity_Id;
begin
@ -7048,7 +7048,7 @@ package body Exp_Util is
-- Get_Index_Subtype --
-----------------------
function Get_Index_Subtype (N : Node_Id) return Node_Id is
function Get_Index_Subtype (N : Node_Id) return Entity_Id is
P_Type : Entity_Id := Etype (Prefix (N));
Indx : Node_Id;
J : Int;

12
gcc/ada/freeze.adb
View File

@ -284,11 +284,11 @@ package body Freeze is
-- Full_View or Corresponding_Record_Type.
procedure Warn_Overlay (Expr : Node_Id; Typ : Entity_Id; Nam : Node_Id);
-- Expr is the expression for an address clause for entity Nam whose type
-- is Typ. If Typ has a default initialization, and there is no explicit
-- initialization in the source declaration, check whether the address
-- clause might cause overlaying of an entity, and emit a warning on the
-- side effect that the initialization will cause.
-- Expr is the expression for an address clause for the entity denoted by
-- Nam whose type is Typ. If Typ has a default initialization, and there is
-- no explicit initialization in the source declaration, check whether the
-- address clause might cause overlaying of an entity, and emit a warning
-- on the side effect that the initialization will cause.
-------------------------------
-- Adjust_Esize_For_Alignment --
@ -10081,7 +10081,7 @@ package body Freeze is
-- Warn_Overlay --
------------------
procedure Warn_Overlay (Expr : Node_Id; Typ : Entity_Id; Nam : Entity_Id) is
procedure Warn_Overlay (Expr : Node_Id; Typ : Entity_Id; Nam : Node_Id) is
Ent : constant Entity_Id := Entity (Nam);
-- The object to which the address clause applies

2
gcc/ada/sem_aggr.adb
View File

@ -365,7 +365,7 @@ package body Sem_Aggr is
-- to the expansion phase. As an optimization, if the discrete choice
-- specifies a single value we do not delay resolution.
function Array_Aggr_Subtype (N : Node_Id; Typ : Node_Id) return Entity_Id;
function Array_Aggr_Subtype (N : Node_Id; Typ : Entity_Id) return Entity_Id;
-- This routine returns the type or subtype of an array aggregate.
--
-- N is the array aggregate node whose type we return.

2
gcc/ada/sem_attr.adb
View File

@ -12469,7 +12469,7 @@ package body Sem_Attr is
function Stream_Attribute_Available
(Typ : Entity_Id;
Nam : TSS_Name_Type;
Partial_View : Node_Id := Empty) return Boolean
Partial_View : Entity_Id := Empty) return Boolean
is
Etyp : Entity_Id := Typ;

11
gcc/ada/sem_ch8.adb
View File

@ -426,12 +426,10 @@ package body Sem_Ch8 is
-- body at the point of freezing will not work. Subp is the subprogram
-- for which N provides the Renaming_As_Body.
procedure Check_In_Previous_With_Clause
(N : Node_Id;
Nam : Node_Id);
procedure Check_In_Previous_With_Clause (N, Nam : Node_Id);
-- N is a use_package clause and Nam the package name, or N is a use_type
-- clause and Nam is the prefix of the type name. In either case, verify
-- that the package is visible at that point in the context: either it
-- that the package is visible at that point in the context: either it
-- appears in a previous with_clause, or because it is a fully qualified
-- name and the root ancestor appears in a previous with_clause.
@ -4670,10 +4668,7 @@ package body Sem_Ch8 is
-- Check_In_Previous_With_Clause --
-----------------------------------
procedure Check_In_Previous_With_Clause
(N : Node_Id;
Nam : Entity_Id)
is
procedure Check_In_Previous_With_Clause (N, Nam : Node_Id) is
Pack : constant Entity_Id := Entity (Original_Node (Nam));
Item : Node_Id;
Par : Node_Id;

2
gcc/ada/sem_prag.ads
View File

@ -429,7 +429,7 @@ package Sem_Prag is
function Get_Argument
(Prag : Node_Id;
Context_Id : Node_Id := Empty) return Node_Id;
Context_Id : Entity_Id := Empty) return Node_Id;
-- Obtain the argument of pragma Prag depending on context and the nature
-- of the pragma. The argument is extracted in the following manner:
--

2
gcc/ada/sem_util.adb
View File

@ -24709,7 +24709,7 @@ package body Sem_Util is
-- Visit_Node --
----------------
procedure Visit_Node (N : Node_Or_Entity_Id) is
procedure Visit_Node (N : Node_Id) is
begin
pragma Assert (Nkind (N) not in N_Entity);

2
gcc/ada/sem_util.ads
View File

@ -356,7 +356,7 @@ package Sem_Util is
-- carries the name of the reference discriminant.
function Build_Overriding_Spec
(Op : Node_Id;
(Op : Entity_Id;
Typ : Entity_Id) return Node_Id;
-- Build a subprogram specification for the wrapper of an inherited
-- operation with a modified pre- or postcondition (See AI12-0113).