Skip to content

R
riscv-gcc-1
Commit 61770974 by Hristian Kirtchev Committed by Pierre-Marie de Rodat
Options

[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
parent e78c79ff
Showing with 99 additions and 88 deletions
gcc/ada/ChangeLog
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>
* sem_res.adb (Resolve_Allocator): Do not complain about the
......
gcc/ada/checks.adb
......@@ -1873,40 +1873,36 @@ package body Checks is
pragma Assert (Do_Division_Check (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
if Expander_Active
and then not Backend_Divide_Checks_On_Target
and then Check_Needed (Right, Division_Check)
then
-- 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.
if Do_Division_Check (N) then
Set_Do_Division_Check (N, False);
-- 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.
if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then
if Is_Floating_Point_Type (Etype (N)) then
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));
and then Do_Division_Check (N)
then
Set_Do_Division_Check (N, False);
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;
if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then
if Is_Floating_Point_Type (Etype (N)) then
Opnd := Make_Real_Literal (Loc, Ureal_0);
else
Opnd := Make_Integer_Literal (Loc, 0);
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 Apply_Division_Check;
......@@ -3552,6 +3548,7 @@ package body Checks is
and then not GNATprove_Mode
then
Apply_Float_Conversion_Check (Expr, Target_Type);
else
Apply_Scalar_Range_Check
(Expr, Target_Type, Fixed_Int => Conv_OK);
......
gcc/ada/contracts.adb
......@@ -888,8 +888,8 @@ package body Contracts is
if not Is_Library_Level_Entity (Obj_Id) then
Error_Msg_N
("volatile variable & must be declared at library level",
Obj_Id);
("volatile variable & must be declared at library level "
& "(SPARK RM 7.1.3(3))", Obj_Id);
-- An object of a discriminated type cannot be effectively
-- volatile except for protected objects (SPARK RM 7.1.3(5)).
......
gcc/ada/exp_aggr.adb
......@@ -7242,21 +7242,19 @@ package body Exp_Aggr is
-- constraint error.
declare
Comp : Entity_Id;
Comp : constant Entity_Id := First (Choices (C));
Indx : Node_Id;
begin
Comp := First (Choices (C));
if Present (Etype (Comp))
and then Is_Array_Type (Etype (Comp))
then
Indx := First_Index (Etype (Comp));
while Present (Indx) loop
if Nkind (Type_Low_Bound (Etype (Indx)))
= N_Raise_Constraint_Error
or else Nkind (Type_High_Bound (Etype (Indx)))
= N_Raise_Constraint_Error
if Nkind (Type_Low_Bound (Etype (Indx))) =
N_Raise_Constraint_Error
or else Nkind (Type_High_Bound (Etype (Indx))) =
N_Raise_Constraint_Error
then
return False;
end if;
......@@ -7276,10 +7274,11 @@ package body Exp_Aggr is
-- the machine.)
if Is_Tagged_Type (Etype (Expr_Q))
and then (Nkind (Expr_Q) = N_Type_Conversion
or else (Is_Entity_Name (Expr_Q)
and then
Ekind (Entity (Expr_Q)) in Formal_Kind))
and then
(Nkind (Expr_Q) = N_Type_Conversion
or else
(Is_Entity_Name (Expr_Q)
and then Ekind (Entity (Expr_Q)) in Formal_Kind))
and then Tagged_Type_Expansion
then
Static_Components := False;
......
gcc/ada/exp_ch5.adb
......@@ -1533,7 +1533,7 @@ package body Exp_Ch5 is
A :=
Make_Assignment_Statement (Loc,
Name =>
Name =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Lhs),
Selector_Name =>
......
gcc/ada/exp_disp.adb
......@@ -7202,18 +7202,19 @@ package body Exp_Disp is
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Address_Array), Loc),
Constraint =>
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc, 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)))))))));
High_Bound =>
Make_Integer_Literal (Loc,
DT_Entry_Count
(First_Tag_Component (Typ)))))))));
Append_To (Result,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => DT_Prims_Acc,
Type_Definition =>
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (DT_Prims, Loc))));
......
gcc/ada/make.adb
......@@ -1421,9 +1421,9 @@ package body Make is
--------------------------
procedure Check_Linker_Options
(E_Stamp : Time_Stamp_Type;
O_File : out File_Name_Type;
O_Stamp : out Time_Stamp_Type)
(E_Stamp : Time_Stamp_Type;
O_File : out File_Name_Type;
O_Stamp : out Time_Stamp_Type)
is
procedure Check_File (File : File_Name_Type);
-- 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 not Queue.Insert
((File => Sfile,
Unit => No_Unit_Name,
Index => 0))
((File => Sfile,
Unit => No_Unit_Name,
Index => 0))
then
if Is_In_Obsoleted (Sfile) then
Executable_Obsolete := True;
......
gcc/ada/sem_ch4.adb
......@@ -8928,44 +8928,49 @@ package body Sem_Ch4 is
(Anc_Type : Entity_Id;
Error : out Boolean)
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
(Typ : Entity_Id) return Boolean;
-- Predicate to verify that the first formal of a class-wide
-- candidate matches the type of the prefix.
(Subp_Id : Entity_Id;
Typ : Entity_Id) return Boolean;
-- Predicate to verify that the first foramal of class-wide
-- subprogram Subp_Id matches type Typ of the prefix.
------------------------
-- First_Formal_Match --
------------------------
function First_Formal_Match
(Typ : Entity_Id) return Boolean
(Subp_Id : Entity_Id;
Typ : Entity_Id) return Boolean
is
Ctrl : constant Entity_Id := First_Formal (Candidate);
Ctrl : constant Entity_Id := First_Formal (Subp_Id);
begin
return Present (Ctrl)
and then
(Base_Type (Etype (Ctrl)) = Typ
or else
(Ekind (Etype (Ctrl)) = E_Anonymous_Access_Type
and then
Base_Type
(Designated_Type (Etype (Ctrl))) = Typ));
return
Present (Ctrl)
and then
(Base_Type (Etype (Ctrl)) = Typ
or else
(Ekind (Etype (Ctrl)) = E_Anonymous_Access_Type
and then
Base_Type (Designated_Type (Etype (Ctrl))) =
Typ));
end First_Formal_Match;
begin
Error := False;
-- Local variables
Cls_Type := Class_Wide_Type (Anc_Type);
CW_Typ : constant Entity_Id := Class_Wide_Type (Anc_Type);
Hom := Current_Entity (Subprog);
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
Error := False;
-- Find a non-hidden operation whose first parameter is of the
-- class-wide type, a subtype thereof, or an anonymous access
......@@ -8973,6 +8978,7 @@ package body Sem_Ch4 is
-- even if hidden (it may be hidden because the instantiation
-- is expanded after the containing package has been analyzed).
Hom := Current_Entity (Subprog);
while Present (Hom) loop
if Ekind_In (Hom, E_Procedure, E_Function)
and then Present (Renamed_Entity (Hom))
......@@ -8983,10 +8989,10 @@ package body Sem_Ch4 is
Candidate := Hom;
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 Scope (Candidate) = Scope (Base_Type (Anc_Type))
and then First_Formal_Match (Cls_Type)
and then First_Formal_Match (Candidate, CW_Typ)
then
-- If the context is a procedure call, ignore functions
-- in the name of the call.
......@@ -9006,16 +9012,16 @@ package body Sem_Ch4 is
goto Next_Hom;
end if;
Set_Etype (Call_Node, Any_Type);
Set_Etype (Call_Node, Any_Type);
Set_Is_Overloaded (Call_Node, False);
Success := False;
if No (Matching_Op) then
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
(N => Call_Node,
......@@ -9040,7 +9046,7 @@ package body Sem_Ch4 is
-- Check for this case before reporting a real ambiguity.
if Present
(Valid_Candidate (Success, Call_Node, Candidate))
(Valid_Candidate (Success, Call_Node, Candidate))
and then Nkind (Call_Node) /= N_Function_Call
and then Candidate /= Matching_Op
then
......
gcc/ada/sem_eval.adb
......@@ -5688,8 +5688,8 @@ package body Sem_Eval 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);
Typ : constant Entity_Id := Etype (N);
begin
-- If we want to raise CE in the condition of a N_Raise_CE node, we
......
gcc/ada/sem_res.adb
......@@ -5015,9 +5015,10 @@ package body Sem_Res is
if In_Instance_Body then
Error_Msg_Warn := SPARK_Mode /= On;
Error_Msg_N
("type in allocator has deeper level than "
& "designated class-wide type<<", E);
("type in allocator has deeper level than designated "
& "class-wide type<<", E);
Error_Msg_N ("\Program_Error [<<", E);
Rewrite (N,
Make_Raise_Program_Error (Sloc (N),
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.
elsif not Is_Generic_Type (Exp_Typ) then
Error_Msg_N ("type in allocator has deeper level than "
& "designated class-wide type", E);
Error_Msg_N
("type in allocator has deeper level than designated "
& "class-wide type", E);
end if;
end if;
end;
......
gcc/ada/usage.adb
......@@ -461,6 +461,7 @@ begin
Write_Line (" I turn off checking for in params");
Write_Line (" m turn on 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 off checking for operators/attributes");
Write_Line (" p turn on checking for parameters");
......@@ -471,7 +472,6 @@ begin
Write_Line (" S turn off checking for subscripts");
Write_Line (" t turn on 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
......
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