+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
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;
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);
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)).
-- 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;
-- 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;
A :=
Make_Assignment_Statement (Loc,
- Name =>
+ Name =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Lhs),
Selector_Name =>
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))));
--------------------------
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
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;
(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
-- 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))
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.
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,
-- 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
-------------------------
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
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));
-- 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;
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");
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
projects / gcc.git / commitdiff