+2010-06-14 Robert Dewar <dewar@adacore.com>
+
+ * opt.ads (Check_Policy_List): Add some clarifying comments
+ * sem_prag.adb (Analyze_Pragma, case Check): Set Pragma_Enabled flag
+ on rewritten Assert pragma.
+
+2010-06-14 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch6.adb (Check_Overriding_Indicator): Add a special check for
+ controlled operations, so that they will be treated as overriding even
+ if the overridden subprogram is marked Is_Hidden, as long as the
+ overridden subprogram's parent subprogram is not hidden.
+
+2010-06-14 Robert Dewar <dewar@adacore.com>
+
+ * debug.adb: Entry for gnatw.d no longer specific for while loops
+ * einfo.adb (First_Exit_Statement): New attribute for E_Loop
+ * einfo.ads (First_Exit_Statement): New attribute for E_Loop
+ * sem_ch5.adb (Analyze_Loop_Statement): Check_Infinite_Loop_Warning has
+ new calling sequence to include test for EXIT WHEN.
+ (Analyze_Exit_Statement): Chain EXIT statement into exit statement chain
+ * sem_warn.ads, sem_warn.adb (Check_Infinite_Loop_Warning): Now handles
+ EXIT WHEN case.
+ * sinfo.adb (Next_Exit_Statement): New attribute of N_Exit_Statement
+ node.
+ * sinfo.ads (N_Pragma): Correct comment on Sloc field (points to
+ PRAGMA, not to pragma identifier).
+ (Next_Exit_Statement): New attribute of N_Exit_Statement node
+
+2010-06-14 Robert Dewar <dewar@adacore.com>
+
+ * sem_res.adb (Resolve_Short_Circuit): Fix sloc of "assertion/check
+ would fail" msg.
+
+2010-06-14 Robert Dewar <dewar@adacore.com>
+
+ * par-ch2.adb (Scan_Pragma_Argument_Association): Clarify message for
+ missing pragma argument identifier.
+
+2010-06-14 Robert Dewar <dewar@adacore.com>
+
+ * atree.ads, atree.adb (Ekind_In): New functions
+
+2010-06-14 Robert Dewar <dewar@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Op_Expon): Optimize 2**N in stand alone context
+
+2010-06-14 Robert Dewar <dewar@adacore.com>
+
+ * usage.adb (Usage): Redo documentation of -gnatwa.
+
2010-06-14 Ed Schonberg <schonberg@adacore.com>
* sem_ch8.adb (Find_Type): The attribute 'class cannot be applied to
return N_To_E (Nodes.Table (E + 1).Nkind);
end Ekind;
+ --------------
+ -- Ekind_In --
+ --------------
+
+ function Ekind_In
+ (T : Entity_Kind;
+ V1 : Entity_Kind;
+ V2 : Entity_Kind) return Boolean
+ is
+ begin
+ return T = V1 or else
+ T = V2;
+ end Ekind_In;
+
+ function Ekind_In
+ (T : Entity_Kind;
+ V1 : Entity_Kind;
+ V2 : Entity_Kind;
+ V3 : Entity_Kind) return Boolean
+ is
+ begin
+ return T = V1 or else
+ T = V2 or else
+ T = V3;
+ end Ekind_In;
+
+ function Ekind_In
+ (T : Entity_Kind;
+ V1 : Entity_Kind;
+ V2 : Entity_Kind;
+ V3 : Entity_Kind;
+ V4 : Entity_Kind) return Boolean
+ is
+ begin
+ return T = V1 or else
+ T = V2 or else
+ T = V3 or else
+ T = V4;
+ end Ekind_In;
+
+ function Ekind_In
+ (T : Entity_Kind;
+ V1 : Entity_Kind;
+ V2 : Entity_Kind;
+ V3 : Entity_Kind;
+ V4 : Entity_Kind;
+ V5 : Entity_Kind) return Boolean
+ is
+ begin
+ return T = V1 or else
+ T = V2 or else
+ T = V3 or else
+ T = V4 or else
+ T = V5;
+ end Ekind_In;
+
+ function Ekind_In
+ (E : Entity_Id;
+ V1 : Entity_Kind;
+ V2 : Entity_Kind) return Boolean
+ is
+ begin
+ return Ekind_In (Ekind (E), V1, V2);
+ end Ekind_In;
+
+ function Ekind_In
+ (E : Entity_Id;
+ V1 : Entity_Kind;
+ V2 : Entity_Kind;
+ V3 : Entity_Kind) return Boolean
+ is
+ begin
+ return Ekind_In (Ekind (E), V1, V2, V3);
+ end Ekind_In;
+
+ function Ekind_In
+ (E : Entity_Id;
+ V1 : Entity_Kind;
+ V2 : Entity_Kind;
+ V3 : Entity_Kind;
+ V4 : Entity_Kind) return Boolean
+ is
+ begin
+ return Ekind_In (Ekind (E), V1, V2, V3, V4);
+ end Ekind_In;
+
+ function Ekind_In
+ (E : Entity_Id;
+ V1 : Entity_Kind;
+ V2 : Entity_Kind;
+ V3 : Entity_Kind;
+ V4 : Entity_Kind;
+ V5 : Entity_Kind) return Boolean
+ is
+ begin
+ return Ekind_In (Ekind (E), V1, V2, V3, V4, V5);
+ end Ekind_In;
+
------------------
-- Error_Posted --
------------------
-- Tests given Id for inequality with the Empty node. This allows notations
-- like "if Present (Statement)" as opposed to "if Statement /= Empty".
- -- Node_Kind tests, like the functions in Sinfo, but the first argument is
- -- a Node_Id, and the tested field is Nkind (N).
+ ---------------------
+ -- Node_Kind Tests --
+ ---------------------
+
+ -- These are like the functions in Sinfo, but the first argument is a
+ -- Node_Id, and the tested field is Nkind (N).
function Nkind_In
(N : Node_Id;
pragma Inline (Nkind_In);
-- Inline all above functions
+ -----------------------
+ -- Entity_Kind_Tests --
+ -----------------------
+
+ -- Utility functions to test whether an Entity_Kind value, either given
+ -- directly as the first argument, or the Ekind field of an Entity give
+ -- as the first argument, matches any of the given list of Entity_Kind
+ -- values. Return True if any match, False if no match.
+
+ function Ekind_In
+ (E : Entity_Id;
+ V1 : Entity_Kind;
+ V2 : Entity_Kind) return Boolean;
+
+ function Ekind_In
+ (E : Entity_Id;
+ V1 : Entity_Kind;
+ V2 : Entity_Kind;
+ V3 : Entity_Kind) return Boolean;
+
+ function Ekind_In
+ (E : Entity_Id;
+ V1 : Entity_Kind;
+ V2 : Entity_Kind;
+ V3 : Entity_Kind;
+ V4 : Entity_Kind) return Boolean;
+
+ function Ekind_In
+ (E : Entity_Id;
+ V1 : Entity_Kind;
+ V2 : Entity_Kind;
+ V3 : Entity_Kind;
+ V4 : Entity_Kind;
+ V5 : Entity_Kind) return Boolean;
+
+ function Ekind_In
+ (T : Entity_Kind;
+ V1 : Entity_Kind;
+ V2 : Entity_Kind) return Boolean;
+
+ function Ekind_In
+ (T : Entity_Kind;
+ V1 : Entity_Kind;
+ V2 : Entity_Kind;
+ V3 : Entity_Kind) return Boolean;
+
+ function Ekind_In
+ (T : Entity_Kind;
+ V1 : Entity_Kind;
+ V2 : Entity_Kind;
+ V3 : Entity_Kind;
+ V4 : Entity_Kind) return Boolean;
+
+ function Ekind_In
+ (T : Entity_Kind;
+ V1 : Entity_Kind;
+ V2 : Entity_Kind;
+ V3 : Entity_Kind;
+ V4 : Entity_Kind;
+ V5 : Entity_Kind) return Boolean;
+
+ pragma Inline (Ekind_In);
+ -- Inline all above functions
+
-----------------------------
-- Entity Access Functions --
-----------------------------
-- d.t Disable static allocation of library level dispatch tables
-- d.u
-- d.v Enable OK_To_Reorder_Components in variant records
- -- d.w Do not check for infinite while loops
+ -- d.w Do not check for infinite loops
-- d.x No exception handlers
-- d.y
-- d.z
-- d.v Forces the flag OK_To_Reorder_Components to be set in all record
-- base types that have at least one discriminant (v = variant).
- -- d.w This flag turns off the scanning of while loops to detect possible
+ -- d.w This flag turns off the scanning of loops to detect possible
-- infinite loops.
-- d.x No exception handlers in generated code. This causes exception
-- Normalized_First_Bit Uint8
-- Postcondition_Proc Node8
-- Return_Applies_To Node8
+ -- First_Exit_Statement Node8
-- Class_Wide_Type Node9
-- Current_Value Node9
return Node17 (Id);
end First_Entity;
+ function First_Exit_Statement (Id : E) return N is
+ begin
+ pragma Assert (Ekind (Id) = E_Loop);
+ return Node8 (Id);
+ end First_Exit_Statement;
+
function First_Index (Id : E) return N is
begin
pragma Assert (Is_Array_Type (Id) or else Is_String_Type (Id));
Set_Node17 (Id, V);
end Set_First_Entity;
+ procedure Set_First_Exit_Statement (Id : E; V : N) is
+ begin
+ pragma Assert (Ekind (Id) = E_Loop);
+ Set_Node8 (Id, V);
+ end Set_First_Exit_Statement;
+
procedure Set_First_Index (Id : E; V : N) is
begin
pragma Assert (Is_Array_Type (Id) or else Is_String_Type (Id));
when Type_Kind =>
Write_Str ("Associated_Node_For_Itype");
+ when E_Loop =>
+ Write_Str ("First_Exit_Statement");
+
when E_Package =>
Write_Str ("Dependent_Instances");
-- Points to a list of associated entities using the Next_Entity field
-- as a chain pointer with Empty marking the end of the list.
+-- First_Exit_Statement (Node8)
+-- Present in E_Loop entity. The exit statements for a loop are chained
+-- (in reverse order of appearence) using this field to point to the
+-- first entry in the chain (last exit statement in the loop). The
+-- entries are chained through the Next_Exit_Statement field of the
+-- N_Exit_Statement node with Empty marking the end of the list.
+
-- First_Formal (synthesized)
-- Applies to subprograms and subprogram types, and also in entries
-- and entry families. Returns first formal of the subprogram or entry.
-- (plus type attributes)
-- E_Loop
+ -- First_Exit_Statement (Node8)
-- Has_Exit (Flag47)
-- Has_Master_Entity (Flag21)
-- Has_Nested_Block_With_Handler (Flag101)
function Finalization_Chain_Entity (Id : E) return E;
function Finalize_Storage_Only (Id : E) return B;
function First_Entity (Id : E) return E;
+ function First_Exit_Statement (Id : E) return N;
function First_Index (Id : E) return N;
function First_Literal (Id : E) return E;
function First_Optional_Parameter (Id : E) return E;
procedure Set_Finalization_Chain_Entity (Id : E; V : E);
procedure Set_Finalize_Storage_Only (Id : E; V : B := True);
procedure Set_First_Entity (Id : E; V : E);
+ procedure Set_First_Exit_Statement (Id : E; V : N);
procedure Set_First_Index (Id : E; V : N);
procedure Set_First_Literal (Id : E; V : E);
procedure Set_First_Optional_Parameter (Id : E; V : E);
pragma Inline (Can_Use_Internal_Rep);
pragma Inline (Finalization_Chain_Entity);
pragma Inline (First_Entity);
+ pragma Inline (First_Exit_Statement);
pragma Inline (First_Index);
pragma Inline (First_Literal);
pragma Inline (First_Optional_Parameter);
pragma Inline (Set_Can_Use_Internal_Rep);
pragma Inline (Set_Finalization_Chain_Entity);
pragma Inline (Set_First_Entity);
+ pragma Inline (Set_First_Exit_Statement);
pragma Inline (Set_First_Index);
pragma Inline (Set_First_Literal);
pragma Inline (Set_First_Optional_Parameter);
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
+with Par_SCO; use Par_SCO;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
and then Is_Power_Of_2_For_Shift (Ropnd)
-- We cannot do this transformation in configurable run time mode if we
- -- have 64-bit -- integers and long shifts are not available.
+ -- have 64-bit integers and long shifts are not available.
and then
(Esize (Ltyp) <= 32
-- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
-- of the higher level node converts it into a shift.
+ -- Another case is 2 ** N in any other context. We simply convert
+ -- this to 1 * 2 ** N, and then the above transformation applies.
+
-- Note: this transformation is not applicable for a modular type with
-- a non-binary modulus in the multiplication case, since we get a wrong
-- result if the shift causes an overflow before the modular reduction.
and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
and then Is_Unsigned_Type (Exptyp)
and then not Ovflo
- and then Nkind (Parent (N)) in N_Binary_Op
then
- declare
- P : constant Node_Id := Parent (N);
- L : constant Node_Id := Left_Opnd (P);
- R : constant Node_Id := Right_Opnd (P);
+ -- First the multiply and divide cases
- begin
- if (Nkind (P) = N_Op_Multiply
- and then not Non_Binary_Modulus (Typ)
- and then
- ((Is_Integer_Type (Etype (L)) and then R = N)
- or else
- (Is_Integer_Type (Etype (R)) and then L = N))
- and then not Do_Overflow_Check (P))
-
- or else
- (Nkind (P) = N_Op_Divide
- and then Is_Integer_Type (Etype (L))
- and then Is_Unsigned_Type (Etype (L))
- and then R = N
- and then not Do_Overflow_Check (P))
- then
- Set_Is_Power_Of_2_For_Shift (N);
- return;
- end if;
- end;
+ if Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply) then
+ declare
+ P : constant Node_Id := Parent (N);
+ L : constant Node_Id := Left_Opnd (P);
+ R : constant Node_Id := Right_Opnd (P);
+
+ begin
+ if (Nkind (P) = N_Op_Multiply
+ and then not Non_Binary_Modulus (Typ)
+ and then
+ ((Is_Integer_Type (Etype (L)) and then R = N)
+ or else
+ (Is_Integer_Type (Etype (R)) and then L = N))
+ and then not Do_Overflow_Check (P))
+ or else
+ (Nkind (P) = N_Op_Divide
+ and then Is_Integer_Type (Etype (L))
+ and then Is_Unsigned_Type (Etype (L))
+ and then R = N
+ and then not Do_Overflow_Check (P))
+ then
+ Set_Is_Power_Of_2_For_Shift (N);
+ return;
+ end if;
+ end;
+
+ -- Now the other cases
+
+ elsif not Non_Binary_Modulus (Typ) then
+ Rewrite (N,
+ Make_Op_Multiply (Loc,
+ Left_Opnd => Make_Integer_Literal (Loc, 1),
+ Right_Opnd => Relocate_Node (N)));
+ Analyze_And_Resolve (N, Typ);
+ return;
+ end if;
end if;
-- Fall through if exponentiation must be done using a runtime routine
if Compile_Time_Known_Value (Left) then
+ -- Mark SCO for left condition as compile time known
+
+ if Generate_SCO and then Comes_From_Source (Left) then
+ Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True);
+ end if;
+
-- Rewrite True AND THEN Right / False OR ELSE Right to Right.
-- Any actions associated with Right will be executed unconditionally
-- and can thus be inserted into the tree unconditionally.
if Compile_Time_Known_Value (Right) then
+ -- Mark SCO for left condition as compile time known
+
+ if Generate_SCO and then Comes_From_Source (Right) then
+ Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True);
+ end if;
+
-- Change (Left and then True), (Left or else False) to Left.
-- Note that we know there are no actions associated with the right
-- operand, since we just checked for this case above.
-- GNAT
-- This points to the list of N_Pragma nodes for Check_Policy pragmas
-- that are linked through the Next_Pragma fields, with the list being
- -- terminated by Empty. The order is most recently processed first.
+ -- terminated by Empty. The order is most recently processed first. Note
+ -- that Push_Scope and Pop_Scope in Sem_Ch8 save and restore the value
+ -- of this variable, implementing the required scope control for pragmas
+ -- appearing a declarative part.
Check_Readonly_Files : Boolean := False;
-- GNATMAKE
if Identifier_Seen and not Id_Present then
Error_Msg_SC
- ("|pragma argument identifier required here (RM 2.8(4))");
+ ("|pragma argument identifier required here");
+ Error_Msg_SC
+ ("\since previous argument had identifier (RM 2.8(4))");
end if;
if Id_Present then
Check_Unset_Reference (Cond);
end if;
+ -- Chain exit statement to associated loop entity
+
+ Set_Next_Exit_Statement (N, First_Exit_Statement (Scope_Id));
+ Set_First_Exit_Statement (Scope_Id, N);
+
-- Since the exit may take us out of a loop, any previous assignment
-- statement is not useless, so clear last assignment indications. It
-- is OK to keep other current values, since if the exit statement
End_Scope;
Kill_Current_Values;
- -- Check for infinite loop. We skip this check for generated code, since
- -- it justs waste time and makes debugging the routine called harder.
+ -- Check for infinite loop. Skip check for generated code, since it
+ -- justs waste time and makes debugging the routine called harder.
+
+ -- Note that we have to wait till the body of the loop is fully analyzed
+ -- before making this call, since Check_Infinite_Loop_Warning relies on
+ -- being able to use semantic visibility information to find references.
if Comes_From_Source (N) then
Check_Infinite_Loop_Warning (N);
end;
end if;
+ -- If there is an overridden subprogram, then check that there is not
+ -- a "not overriding" indicator, and mark the subprogram as overriding.
+ -- This is not done if the overridden subprogram is marked as hidden,
+ -- which can occur for the case of inherited controlled operations
+ -- (see Derive_Subprogram), unless the inherited subprogram's parent
+ -- subprogram is not itself hidden. (Note: This condition could probably
+ -- be simplified, leaving out the testing for the specific controlled
+ -- cases, but it seems safer and clearer this way, and echoes similar
+ -- special-case tests of this kind in other places.)
+
if Present (Overridden_Subp)
- and then not Is_Hidden (Overridden_Subp)
+ and then (not Is_Hidden (Overridden_Subp)
+ or else
+ ((Chars (Overridden_Subp) = Name_Initialize
+ or else Chars (Overridden_Subp) = Name_Adjust
+ or else Chars (Overridden_Subp) = Name_Finalize)
+ and then Present (Alias (Overridden_Subp))
+ and then not Is_Hidden (Alias (Overridden_Subp))))
then
if Must_Not_Override (Spec) then
Error_Msg_Sloc := Sloc (Overridden_Subp);
end if;
Check_Arg_Is_Identifier (Arg1);
+
+ -- Indicate if pragma is enabled. The Original_Node reference here
+ -- is to deal with pragma Assert rewritten as a Check pragma.
+
Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1)));
Set_Pragma_Enabled (N, Check_On);
+ Set_Pragma_Enabled (Original_Node (N), Check_On);
-- If expansion is active and the check is not enabled then we
-- rewrite the Check as:
then
null;
else
- -- Issue warning. Note that we don't want to make this
- -- an unconditional warning, because if the assert is
- -- within deleted code we do not want the warning. But
- -- we do not want the deletion of the IF/AND-THEN to
- -- take this message with it. We achieve this by making
- -- sure that the expanded code points to the Sloc of
- -- the expression, not the original pragma.
-
- Error_Msg_N ("?assertion would fail at run-time", Orig);
+ -- Issue warning. We do not want the deletion of the
+ -- IF/AND-THEN to take this message with it. We achieve
+ -- this by making sure that the expanded code points to
+ -- the Sloc of the expression, not the original pragma.
+
+ Error_Msg_N
+ ("?assertion would fail at run-time!",
+ Expression
+ (First (Pragma_Argument_Associations (Orig))));
end if;
end;
then
null;
else
- Error_Msg_N ("?check would fail at run-time", Orig);
+ Error_Msg_N
+ ("?check would fail at run-time!",
+ Expression
+ (Last (Pragma_Argument_Associations (Orig))));
end if;
end;
end if;
-- within the body of the loop.
procedure Check_Infinite_Loop_Warning (Loop_Statement : Node_Id) is
- Iter : constant Node_Id := Iteration_Scheme (Loop_Statement);
+ Expression : Node_Id := Empty;
+ -- Set to WHILE or EXIT WHEN condition to be tested
Ref : Node_Id := Empty;
- -- Reference in iteration scheme to variable that might not be modified
+ -- Reference in Expression to variable that might not be modified
-- in loop, indicating a possible infinite loop.
Var : Entity_Id := Empty;
function Test_Ref (N : Node_Id) return Traverse_Result;
-- Test for reference to variable in question. Returns Abandon if
- -- matching reference found.
+ -- matching reference found. Used in instantiation of No_Ref_Found.
- function Find_Ref is new Traverse_Func (Test_Ref);
+ function No_Ref_Found is new Traverse_Func (Test_Ref);
-- Function to traverse body of procedure. Returns Abandon if matching
-- reference found.
function Test_Ref (N : Node_Id) return Traverse_Result is
begin
- -- Waste of time to look at iteration scheme
+ -- Waste of time to look at the expression we are testing
- if N = Iter then
+ if N = Expression then
return Skip;
-- Direct reference to variable in question
-- Start of processing for Check_Infinite_Loop_Warning
begin
- -- We need a while iteration with no condition actions. Condition
- -- actions just make things too complicated to get the warning right.
+ -- Skip processing if debug flag gnatd.w is set
- if No (Iter)
- or else No (Condition (Iter))
- or else Present (Condition_Actions (Iter))
- or else Debug_Flag_Dot_W
- then
+ if Debug_Flag_Dot_W then
+ return;
+ end if;
+
+ -- Case of WHILE loop
+
+ declare
+ Iter : constant Node_Id := Iteration_Scheme (Loop_Statement);
+
+ begin
+ if Present (Iter) and then Present (Condition (Iter)) then
+
+ -- Skip processing for while iteration with conditions actions,
+ -- since they make it too complicated to get the warning right.
+
+ if Present (Condition_Actions (Iter)) then
+ return;
+ end if;
+
+ -- Capture WHILE condition
+
+ Expression := Condition (Iter);
+ end if;
+ end;
+
+ -- Check chain of EXIT statements, we only process loops that have a
+ -- single exit condition (either a single EXIT WHEN statement, or a
+ -- WHILE loop not containing any EXIT WHEN statements).
+
+ declare
+ Ident : constant Node_Id := Identifier (Loop_Statement);
+ Exit_Stmt : Node_Id;
+
+ begin
+ -- If we don't have a proper chain set, ignore call entirely. This
+ -- happens because of previous errors.
+
+ if No (Entity (Ident))
+ or else Ekind (Entity (Ident)) /= E_Loop
+ then
+ return;
+ end if;
+
+ -- Otherwise prepare to scan list of EXIT statements
+
+ Exit_Stmt := First_Exit_Statement (Entity (Ident));
+ while Present (Exit_Stmt) loop
+
+ -- Check for EXIT WHEN
+
+ if Present (Condition (Exit_Stmt)) then
+
+ -- Quit processing if EXIT WHEN in WHILE loop, or more than
+ -- one EXIT WHEN statement present in the loop.
+
+ if Present (Expression) then
+ return;
+
+ -- Otherwise capture condition from EXIT WHEN statement
+
+ else
+ Expression := Condition (Exit_Stmt);
+ end if;
+ end if;
+
+ Exit_Stmt := Next_Exit_Statement (Exit_Stmt);
+ end loop;
+ end;
+
+ -- Return if no condition to test
+
+ if No (Expression) then
return;
end if;
-- Initial conditions met, see if condition is of right form
- Find_Var (Condition (Iter));
+ Find_Var (Expression);
-- Nothing to do if local variable from source not found. If it's a
-- renaming, it is probably renaming something too complicated to deal
-- We have a variable reference of the right form, now we scan the loop
-- body to see if it looks like it might not be modified
- if Find_Ref (Loop_Statement) = OK then
+ if No_Ref_Found (Loop_Statement) = OK then
Error_Msg_NE
("?variable& is not modified in loop body!", Ref, Var);
Error_Msg_N
Sloc_Range (Orig, Start, Dummy);
Atrue := Test_Result;
- if Present (Parent (C))
- and then Nkind (Parent (C)) = N_Op_Not
- then
+ if Present (Parent (C)) and then Nkind (Parent (C)) = N_Op_Not then
Atrue := not Atrue;
end if;
procedure Check_Infinite_Loop_Warning (Loop_Statement : Node_Id);
-- N is the node for a loop statement. This procedure checks if a warning
- -- should be given for a possible infinite loop, and if so issues it.
+ -- for a possible infinite loop should be given for a suspicious WHILE or
+ -- EXIT WHEN condition.
procedure Check_Low_Bound_Tested (Expr : Node_Id);
-- Expr is the node for a comparison operation. This procedure checks if
return Node2 (N);
end Next_Entity;
+ function Next_Exit_Statement
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Exit_Statement);
+ return Node3 (N);
+ end Next_Exit_Statement;
+
function Next_Implicit_With
(N : Node_Id) return Node_Id is
begin
Set_Node2 (N, Val); -- semantic field, no parent set
end Set_Next_Entity;
+ procedure Set_Next_Exit_Statement
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Exit_Statement);
+ Set_Node3 (N, Val); -- semantic field, no parent set
+ end Set_Next_Exit_Statement;
+
procedure Set_Next_Implicit_With
(N : Node_Id; Val : Node_Id) is
begin
-- scope are chained, and this field is used as the forward pointer for
-- this list. See Einfo for further details.
+ -- Next_Exit_Statement (Node3-Sem)
+ -- Present in N_Exit_Statement nodes. The exit statements for a loop are
+ -- chained (in reverse order of appearence) from the First_Exit_Statement
+ -- field of the E_Loop entity for the loop. Next_Exit_Statement points to
+ -- the next entry on this chain (Empty = end of list).
+
-- Next_Implicit_With (Node3-Sem)
-- Present in N_With_Clause. Part of a chain of with_clauses generated
-- in rtsfind to indicate implicit dependencies on predefined units. Used
-- which are explicitly documented.
-- N_Pragma
- -- Sloc points to pragma identifier
+ -- Sloc points to PRAGMA
-- Next_Pragma (Node1-Sem)
-- Pragma_Argument_Associations (List2) (set to No_List if none)
-- Debug_Statement (Node3) (set to Empty if not Debug, Assert)
-- Is_Null_Loop (Flag16)
-- Suppress_Loop_Warnings (Flag17)
+ -- Note: the parser fills in the Identifier field if there is an
+ -- explicit loop identifier. Otherwise the parser leaves this field
+ -- set to Empty, and then the semantic processing for a loop statement
+ -- creates an identifier, setting the Has_Created_Identifier flag to
+ -- True. So after semantic anlaysis, the Identifier is always set,
+ -- referencing an identifier whose entity has an Ekind of E_Loop.
+
--------------------------
-- 5.5 Iteration Scheme --
--------------------------
-- N_Exit_Statement
-- Sloc points to EXIT
-- Name (Node2) (set to Empty if no loop name present)
- -- Condition (Node1) (set to Empty if no when part present)
+ -- Condition (Node1) (set to Empty if no WHEN part present)
+ -- Next_Exit_Statement (Node3-Sem): Next exit on chain
-------------------------
-- 5.9 Goto Statement --
function Next_Entity
(N : Node_Id) return Node_Id; -- Node2
+ function Next_Exit_Statement
+ (N : Node_Id) return Node_Id; -- Node3
+
function Next_Implicit_With
(N : Node_Id) return Node_Id; -- Node3
procedure Set_Next_Entity
(N : Node_Id; Val : Node_Id); -- Node2
+ procedure Set_Next_Exit_Statement
+ (N : Node_Id; Val : Node_Id); -- Node3
+
procedure Set_Next_Implicit_With
(N : Node_Id; Val : Node_Id); -- Node3
pragma Inline (Name);
pragma Inline (Names);
pragma Inline (Next_Entity);
+ pragma Inline (Next_Exit_Statement);
pragma Inline (Next_Implicit_With);
pragma Inline (Next_Named_Actual);
pragma Inline (Next_Pragma);
pragma Inline (Set_Name);
pragma Inline (Set_Names);
pragma Inline (Set_Next_Entity);
+ pragma Inline (Set_Next_Exit_Statement);
pragma Inline (Set_Next_Implicit_With);
pragma Inline (Set_Next_Named_Actual);
pragma Inline (Set_Next_Pragma);
Write_Switch_Char ("wxx");
Write_Line ("Enable selected warning modes, xx = list of parameters:");
- Write_Line (" a turn on all optional info/warnings " &
- "(except dhl.ot.w)");
+ Write_Line (" a turn on all info/warnings marked below with +");
Write_Line (" A turn off all optional info/warnings");
- Write_Line (" .a* turn on warnings for failing assertion");
+ Write_Line (" .a*+ turn on warnings for failing assertion");
Write_Line (" .A turn off warnings for failing assertion");
- Write_Line (" b turn on warnings for bad fixed value " &
+ Write_Line (" b+ turn on warnings for bad fixed value " &
"(not multiple of small)");
Write_Line (" B* turn off warnings for bad fixed value " &
"(not multiple of small)");
- Write_Line (" .b* turn on warnings for biased representation");
+ Write_Line (" .b*+ turn on warnings for biased representation");
Write_Line (" .B turn off warnings for biased representation");
- Write_Line (" c turn on warnings for constant conditional");
+ Write_Line (" c+ turn on warnings for constant conditional");
Write_Line (" C* turn off warnings for constant conditional");
- Write_Line (" .c turn on warnings for unrepped components");
+ Write_Line (" .c+ turn on warnings for unrepped components");
Write_Line (" .C* turn off warnings for unrepped components");
Write_Line (" d turn on warnings for implicit dereference");
Write_Line (" D* turn off warnings for implicit dereference");
Write_Line (" e treat all warnings (but not info) as errors");
Write_Line (" .e turn on every optional info/warning " &
"(no exceptions)");
- Write_Line (" f turn on warnings for unreferenced formal");
+ Write_Line (" f+ turn on warnings for unreferenced formal");
Write_Line (" F* turn off warnings for unreferenced formal");
- Write_Line (" g* turn on warnings for unrecognized pragma");
+ Write_Line (" g*+ turn on warnings for unrecognized pragma");
Write_Line (" G turn off warnings for unrecognized pragma");
Write_Line (" h turn on warnings for hiding variable");
Write_Line (" H* turn off warnings for hiding variable");
- Write_Line (" i* turn on warnings for implementation unit");
+ Write_Line (" i*+ turn on warnings for implementation unit");
Write_Line (" I turn off warnings for implementation unit");
Write_Line (" .i turn on warnings for overlapping actuals");
Write_Line (" .I* turn off warnings for overlapping actuals");
- Write_Line (" j turn on warnings for obsolescent " &
+ Write_Line (" j+ turn on warnings for obsolescent " &
"(annex J) feature");
Write_Line (" J* turn off warnings for obsolescent " &
"(annex J) feature");
- Write_Line (" k turn on warnings on constant variable");
+ Write_Line (" k+ turn on warnings on constant variable");
Write_Line (" K* turn off warnings on constant variable");
Write_Line (" l turn on warnings for missing " &
"elaboration pragma");
Write_Line (" L* turn off warnings for missing " &
"elaboration pragma");
- Write_Line (" m turn on warnings for variable assigned " &
+ Write_Line (" m+ turn on warnings for variable assigned " &
"but not read");
Write_Line (" M* turn off warnings for variable assigned " &
"but not read");
"but not read");
Write_Line (" .O* turn off warnings for out parameters assigned " &
"but not read");
- Write_Line (" p turn on warnings for ineffective pragma " &
+ Write_Line (" p+ turn on warnings for ineffective pragma " &
"Inline in frontend");
Write_Line (" P* turn off warnings for ineffective pragma " &
"Inline in frontend");
- Write_Line (" .p turn on warnings for suspicious parameter " &
+ Write_Line (" .p+ turn on warnings for suspicious parameter " &
"order");
Write_Line (" .P* turn off warnings for suspicious parameter " &
"order");
- Write_Line (" q* turn on warnings for questionable " &
+ Write_Line (" q*+ turn on warnings for questionable " &
"missing parenthesis");
Write_Line (" Q turn off warnings for questionable " &
"missing parenthesis");
- Write_Line (" r turn on warnings for redundant construct");
+ Write_Line (" r+ turn on warnings for redundant construct");
Write_Line (" R* turn off warnings for redundant construct");
- Write_Line (" .r turn on warnings for object renaming function");
+ Write_Line (" .r+ turn on warnings for object renaming function");
Write_Line (" .R* turn off warnings for object renaming function");
Write_Line (" s suppress all info/warnings");
Write_Line (" t turn on warnings for tracking deleted code");
Write_Line (" T* turn off warnings for tracking deleted code");
- Write_Line (" u turn on warnings for unused entity");
+ Write_Line (" u+ turn on warnings for unused entity");
Write_Line (" U* turn off warnings for unused entity");
- Write_Line (" v* turn on warnings for unassigned variable");
+ Write_Line (" v*+ turn on warnings for unassigned variable");
Write_Line (" V turn off warnings for unassigned variable");
- Write_Line (" .v* turn on info messages for reverse bit order");
+ Write_Line (" .v*+ turn on info messages for reverse bit order");
Write_Line (" .V turn off info messages for reverse bit order");
- Write_Line (" w* turn on warnings for wrong low bound assumption");
+ Write_Line (" w*+ turn on warnings for wrong low bound assumption");
Write_Line (" W turn off warnings for wrong low bound " &
"assumption");
Write_Line (" .w turn on warnings on pragma Warnings Off");
Write_Line (" .W* turn off warnings on pragma Warnings Off");
- Write_Line (" x* turn on warnings for export/import");
+ Write_Line (" x*+ turn on warnings for export/import");
Write_Line (" X turn off warnings for export/import");
- Write_Line (" .x turn on warnings for non-local exception");
+ Write_Line (" .x+ turn on warnings for non-local exception");
Write_Line (" .X* turn off warnings for non-local exception");
- Write_Line (" y* turn on warnings for Ada 2005 incompatibility");
+ Write_Line (" y*+ turn on warnings for Ada 2005 incompatibility");
Write_Line (" Y turn off warnings for Ada 2005 incompatibility");
- Write_Line (" z* turn on warnings for suspicious " &
+ Write_Line (" z*+ turn on warnings for suspicious " &
"unchecked conversion");
Write_Line (" Z turn off warnings for suspicious " &
"unchecked conversion");
Write_Line (" * indicates default in above list");
+ Write_Line (" + indicates warning flag included in -gnatwa");
-- Line for -gnatW switch
projects / platform / upstream / gcc.git / commitdiff