git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[Ada] Minor reformattings 

2018-07-31  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada

	* checks.adb, contracts.adb, exp_aggr.adb, exp_ch5.adb,
	exp_disp.adb, make.adb, sem_ch4.adb, sem_eval.adb, sem_res.adb,
	usage.adb: Minor reformatting.

From-SVN: r263089
This commit is contained in:
Hristian Kirtchev 2018-07-31 09:55:16 +00:00 committed by Pierre-Marie de Rodat
parent e78c79ff53
commit 617709748b
11 changed files with 100 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/ada/ChangeLog
View File

@ -1,3 +1,9 @@
2018-07-31 Hristian Kirtchev <kirtchev@adacore.com>
* checks.adb, contracts.adb, exp_aggr.adb, exp_ch5.adb,
exp_disp.adb, make.adb, sem_ch4.adb, sem_eval.adb, sem_res.adb,
usage.adb: Minor reformatting.
2018-07-31 Bob Duff <duff@adacore.com> 2018-07-31 Bob Duff <duff@adacore.com>
* sem_res.adb (Resolve_Allocator): Do not complain about the * sem_res.adb (Resolve_Allocator): Do not complain about the

49
gcc/ada/checks.adb
View File

@ -1873,40 +1873,36 @@ package body Checks is
pragma Assert (Do_Division_Check (N)); pragma Assert (Do_Division_Check (N));
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Right : constant Node_Id := Right_Opnd (N); Right : constant Node_Id := Right_Opnd (N);
Opnd : Node_Id;
begin begin
if Expander_Active if Expander_Active
and then not Backend_Divide_Checks_On_Target and then not Backend_Divide_Checks_On_Target
and then Check_Needed (Right, Division_Check) and then Check_Needed (Right, Division_Check)
-- See if division by zero possible, and if so generate test. This
-- part of the test is not controlled by the -gnato switch, since it
-- is a Division_Check and not an Overflow_Check.
and then Do_Division_Check (N)
then then
-- See if division by zero possible, and if so generate test. This Set_Do_Division_Check (N, False);
-- part of the test is not controlled by the -gnato switch, since
-- it is a Division_Check and not an Overflow_Check.
if Do_Division_Check (N) then if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then
Set_Do_Division_Check (N, False); if Is_Floating_Point_Type (Etype (N)) then
Opnd := Make_Real_Literal (Loc, Ureal_0);
if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then else
if Is_Floating_Point_Type (Etype (N)) then Opnd := Make_Integer_Literal (Loc, 0);
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
Reason => CE_Divide_By_Zero));
else
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
Right_Opnd => Make_Integer_Literal (Loc, 0)),
Reason => CE_Divide_By_Zero));
end if;
end if; end if;
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
Right_Opnd => Opnd),
Reason => CE_Divide_By_Zero));
end if; end if;
end if; end if;
end Apply_Division_Check; end Apply_Division_Check;
@ -3552,6 +3548,7 @@ package body Checks is
and then not GNATprove_Mode and then not GNATprove_Mode
then then
Apply_Float_Conversion_Check (Expr, Target_Type); Apply_Float_Conversion_Check (Expr, Target_Type);
else else
Apply_Scalar_Range_Check Apply_Scalar_Range_Check
(Expr, Target_Type, Fixed_Int => Conv_OK); (Expr, Target_Type, Fixed_Int => Conv_OK);

4
gcc/ada/contracts.adb
View File

@ -888,8 +888,8 @@ package body Contracts is
if not Is_Library_Level_Entity (Obj_Id) then if not Is_Library_Level_Entity (Obj_Id) then
Error_Msg_N Error_Msg_N
("volatile variable & must be declared at library level", ("volatile variable & must be declared at library level "
Obj_Id); & "(SPARK RM 7.1.3(3))", Obj_Id);
-- An object of a discriminated type cannot be effectively -- An object of a discriminated type cannot be effectively
-- volatile except for protected objects (SPARK RM 7.1.3(5)). -- volatile except for protected objects (SPARK RM 7.1.3(5)).

21
gcc/ada/exp_aggr.adb
View File

@ -7242,21 +7242,19 @@ package body Exp_Aggr is
-- constraint error. -- constraint error.
declare declare
Comp : Entity_Id; Comp : constant Entity_Id := First (Choices (C));
Indx : Node_Id; Indx : Node_Id;
begin begin
Comp := First (Choices (C));
if Present (Etype (Comp)) if Present (Etype (Comp))
and then Is_Array_Type (Etype (Comp)) and then Is_Array_Type (Etype (Comp))
then then
Indx := First_Index (Etype (Comp)); Indx := First_Index (Etype (Comp));
while Present (Indx) loop while Present (Indx) loop
if Nkind (Type_Low_Bound (Etype (Indx))) if Nkind (Type_Low_Bound (Etype (Indx))) =
= N_Raise_Constraint_Error N_Raise_Constraint_Error
or else Nkind (Type_High_Bound (Etype (Indx))) or else Nkind (Type_High_Bound (Etype (Indx))) =
= N_Raise_Constraint_Error N_Raise_Constraint_Error
then then
return False; return False;
end if; end if;
@ -7276,10 +7274,11 @@ package body Exp_Aggr is
-- the machine.) -- the machine.)
if Is_Tagged_Type (Etype (Expr_Q)) if Is_Tagged_Type (Etype (Expr_Q))
and then (Nkind (Expr_Q) = N_Type_Conversion and then
or else (Is_Entity_Name (Expr_Q) (Nkind (Expr_Q) = N_Type_Conversion
and then or else
Ekind (Entity (Expr_Q)) in Formal_Kind)) (Is_Entity_Name (Expr_Q)
and then Ekind (Entity (Expr_Q)) in Formal_Kind))
and then Tagged_Type_Expansion and then Tagged_Type_Expansion
then then
Static_Components := False; Static_Components := False;

2
gcc/ada/exp_ch5.adb
View File

@ -1533,7 +1533,7 @@ package body Exp_Ch5 is
A := A :=
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => Name =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Lhs), Prefix => Duplicate_Subexpr (Lhs),
Selector_Name => Selector_Name =>

11
gcc/ada/exp_disp.adb
View File

@ -7202,18 +7202,19 @@ package body Exp_Disp is
Make_Subtype_Indication (Loc, Make_Subtype_Indication (Loc,
Subtype_Mark => Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Address_Array), Loc), New_Occurrence_Of (RTE (RE_Address_Array), Loc),
Constraint => Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc, New_List ( Make_Index_Or_Discriminant_Constraint (Loc, New_List (
Make_Range (Loc, Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 1), Low_Bound => Make_Integer_Literal (Loc, 1),
High_Bound => Make_Integer_Literal (Loc, High_Bound =>
DT_Entry_Count Make_Integer_Literal (Loc,
(First_Tag_Component (Typ))))))))); DT_Entry_Count
(First_Tag_Component (Typ)))))))));
Append_To (Result, Append_To (Result,
Make_Full_Type_Declaration (Loc, Make_Full_Type_Declaration (Loc,
Defining_Identifier => DT_Prims_Acc, Defining_Identifier => DT_Prims_Acc,
Type_Definition => Type_Definition =>
Make_Access_To_Object_Definition (Loc, Make_Access_To_Object_Definition (Loc,
Subtype_Indication => Subtype_Indication =>
New_Occurrence_Of (DT_Prims, Loc)))); New_Occurrence_Of (DT_Prims, Loc))));

12
gcc/ada/make.adb
View File

@ -1421,9 +1421,9 @@ package body Make is
-------------------------- --------------------------
procedure Check_Linker_Options procedure Check_Linker_Options
(E_Stamp : Time_Stamp_Type; (E_Stamp : Time_Stamp_Type;
O_File : out File_Name_Type; O_File : out File_Name_Type;
O_Stamp : out Time_Stamp_Type) O_Stamp : out Time_Stamp_Type)
is is
procedure Check_File (File : File_Name_Type); procedure Check_File (File : File_Name_Type);
-- Update O_File and O_Stamp if the given file is younger than E_Stamp -- Update O_File and O_Stamp if the given file is younger than E_Stamp
@ -1865,9 +1865,9 @@ package body Make is
if Add_It then if Add_It then
if not Queue.Insert if not Queue.Insert
((File => Sfile, ((File => Sfile,
Unit => No_Unit_Name, Unit => No_Unit_Name,
Index => 0)) Index => 0))
then then
if Is_In_Obsoleted (Sfile) then if Is_In_Obsoleted (Sfile) then
Executable_Obsolete := True; Executable_Obsolete := True;

70
gcc/ada/sem_ch4.adb
View File

@ -8928,51 +8928,57 @@ package body Sem_Ch4 is
(Anc_Type : Entity_Id; (Anc_Type : Entity_Id;
Error : out Boolean) Error : out Boolean)
is is
Candidate : Entity_Id;
-- If homonym is a renaming, examine the renamed program
Cls_Type : Entity_Id;
Hom : Entity_Id;
Hom_Ref : Node_Id;
Success : Boolean;
function First_Formal_Match function First_Formal_Match
(Typ : Entity_Id) return Boolean; (Subp_Id : Entity_Id;
-- Predicate to verify that the first formal of a class-wide Typ : Entity_Id) return Boolean;
-- candidate matches the type of the prefix. -- Predicate to verify that the first foramal of class-wide
-- subprogram Subp_Id matches type Typ of the prefix.
------------------------ ------------------------
-- First_Formal_Match -- -- First_Formal_Match --
------------------------ ------------------------
function First_Formal_Match function First_Formal_Match
(Typ : Entity_Id) return Boolean (Subp_Id : Entity_Id;
Typ : Entity_Id) return Boolean
is is
Ctrl : constant Entity_Id := First_Formal (Candidate); Ctrl : constant Entity_Id := First_Formal (Subp_Id);
begin begin
return Present (Ctrl) return
and then Present (Ctrl)
(Base_Type (Etype (Ctrl)) = Typ and then
or else (Base_Type (Etype (Ctrl)) = Typ
(Ekind (Etype (Ctrl)) = E_Anonymous_Access_Type or else
and then (Ekind (Etype (Ctrl)) = E_Anonymous_Access_Type
Base_Type and then
(Designated_Type (Etype (Ctrl))) = Typ)); Base_Type (Designated_Type (Etype (Ctrl))) =
Typ));
end First_Formal_Match; end First_Formal_Match;
-- Local variables
CW_Typ : constant Entity_Id := Class_Wide_Type (Anc_Type);
Candidate : Entity_Id;
-- If homonym is a renaming, examine the renamed program
Hom : Entity_Id;
Hom_Ref : Node_Id;
Success : Boolean;
-- Start of processing for Traverse_Homonyms
begin begin
Error := False; Error := False;
Cls_Type := Class_Wide_Type (Anc_Type);
Hom := Current_Entity (Subprog);
-- Find a non-hidden operation whose first parameter is of the -- Find a non-hidden operation whose first parameter is of the
-- class-wide type, a subtype thereof, or an anonymous access -- class-wide type, a subtype thereof, or an anonymous access
-- to same. If in an instance, the operation can be considered -- to same. If in an instance, the operation can be considered
-- even if hidden (it may be hidden because the instantiation -- even if hidden (it may be hidden because the instantiation
-- is expanded after the containing package has been analyzed). -- is expanded after the containing package has been analyzed).
Hom := Current_Entity (Subprog);
while Present (Hom) loop while Present (Hom) loop
if Ekind_In (Hom, E_Procedure, E_Function) if Ekind_In (Hom, E_Procedure, E_Function)
and then Present (Renamed_Entity (Hom)) and then Present (Renamed_Entity (Hom))
@ -8983,10 +8989,10 @@ package body Sem_Ch4 is
Candidate := Hom; Candidate := Hom;
end if; end if;
if Ekind_In (Candidate, E_Procedure, E_Function) if Ekind_In (Candidate, E_Function, E_Procedure)
and then (not Is_Hidden (Candidate) or else In_Instance) and then (not Is_Hidden (Candidate) or else In_Instance)
and then Scope (Candidate) = Scope (Base_Type (Anc_Type)) and then Scope (Candidate) = Scope (Base_Type (Anc_Type))
and then First_Formal_Match (Cls_Type) and then First_Formal_Match (Candidate, CW_Typ)
then then
-- If the context is a procedure call, ignore functions -- If the context is a procedure call, ignore functions
-- in the name of the call. -- in the name of the call.
@ -9006,16 +9012,16 @@ package body Sem_Ch4 is
goto Next_Hom; goto Next_Hom;
end if; end if;
Set_Etype (Call_Node, Any_Type); Set_Etype (Call_Node, Any_Type);
Set_Is_Overloaded (Call_Node, False); Set_Is_Overloaded (Call_Node, False);
Success := False; Success := False;
if No (Matching_Op) then if No (Matching_Op) then
Hom_Ref := New_Occurrence_Of (Candidate, Sloc (Subprog)); Hom_Ref := New_Occurrence_Of (Candidate, Sloc (Subprog));
Set_Etype (Call_Node, Any_Type);
Set_Parent (Call_Node, Parent (Node_To_Replace));
Set_Name (Call_Node, Hom_Ref); Set_Etype (Call_Node, Any_Type);
Set_Name (Call_Node, Hom_Ref);
Set_Parent (Call_Node, Parent (Node_To_Replace));
Analyze_One_Call Analyze_One_Call
(N => Call_Node, (N => Call_Node,
@ -9040,7 +9046,7 @@ package body Sem_Ch4 is
-- Check for this case before reporting a real ambiguity. -- Check for this case before reporting a real ambiguity.
if Present if Present
(Valid_Candidate (Success, Call_Node, Candidate)) (Valid_Candidate (Success, Call_Node, Candidate))
and then Nkind (Call_Node) /= N_Function_Call and then Nkind (Call_Node) /= N_Function_Call
and then Candidate /= Matching_Op and then Candidate /= Matching_Op
then then

2
gcc/ada/sem_eval.adb
View File

@ -5688,8 +5688,8 @@ package body Sem_Eval is
------------------------- -------------------------
procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
Typ : constant Entity_Id := Etype (N);
Stat : constant Boolean := Is_Static_Expression (N); Stat : constant Boolean := Is_Static_Expression (N);
Typ : constant Entity_Id := Etype (N);
begin begin
-- If we want to raise CE in the condition of a N_Raise_CE node, we -- If we want to raise CE in the condition of a N_Raise_CE node, we

10
gcc/ada/sem_res.adb
View File

@ -5015,9 +5015,10 @@ package body Sem_Res is
if In_Instance_Body then if In_Instance_Body then
Error_Msg_Warn := SPARK_Mode /= On; Error_Msg_Warn := SPARK_Mode /= On;
Error_Msg_N Error_Msg_N
("type in allocator has deeper level than " ("type in allocator has deeper level than designated "
& "designated class-wide type<<", E); & "class-wide type<<", E);
Error_Msg_N ("\Program_Error [<<", E); Error_Msg_N ("\Program_Error [<<", E);
Rewrite (N, Rewrite (N,
Make_Raise_Program_Error (Sloc (N), Make_Raise_Program_Error (Sloc (N),
Reason => PE_Accessibility_Check_Failed)); Reason => PE_Accessibility_Check_Failed));
@ -5028,8 +5029,9 @@ package body Sem_Res is
-- type. A run-time check will be performed in the instance. -- type. A run-time check will be performed in the instance.
elsif not Is_Generic_Type (Exp_Typ) then elsif not Is_Generic_Type (Exp_Typ) then
Error_Msg_N ("type in allocator has deeper level than " Error_Msg_N
& "designated class-wide type", E); ("type in allocator has deeper level than designated "
& "class-wide type", E);
end if; end if;
end if; end if;
end; end;

2
gcc/ada/usage.adb
View File

@ -461,6 +461,7 @@ begin
Write_Line (" I turn off checking for in params"); Write_Line (" I turn off checking for in params");
Write_Line (" m turn on checking for in out params"); Write_Line (" m turn on checking for in out params");
Write_Line (" M turn off checking for in out params"); Write_Line (" M turn off checking for in out params");
Write_Line (" n turn off all validity checks (including RM)");
Write_Line (" o turn on checking for operators/attributes"); Write_Line (" o turn on checking for operators/attributes");
Write_Line (" O turn off checking for operators/attributes"); Write_Line (" O turn off checking for operators/attributes");
Write_Line (" p turn on checking for parameters"); Write_Line (" p turn on checking for parameters");
@ -471,7 +472,6 @@ begin
Write_Line (" S turn off checking for subscripts"); Write_Line (" S turn off checking for subscripts");
Write_Line (" t turn on checking for tests"); Write_Line (" t turn on checking for tests");
Write_Line (" T turn off checking for tests"); Write_Line (" T turn off checking for tests");
Write_Line (" n turn off all validity checks (including RM)");
-- Lines for -gnatw switch -- Lines for -gnatw switch