-- --
-- B o d y --
-- --
--- Copyright (C) 2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Days : Long_Integer;
Seconds : Duration;
Leap_Seconds : Integer;
+ pragma Warnings (Off, Seconds); -- temporary ???
+ pragma Warnings (Off, Leap_Seconds); -- temporary ???
+ pragma Unreferenced (Seconds, Leap_Seconds);
begin
Arithmetic_Operations.Difference
(Left, Right, Days, Seconds, Leap_Seconds);
with Ada.Unchecked_Conversion;
+pragma Warnings (Off); -- temp till we fix out param warnings ???
+
package body Ada.Calendar is
--------------------------
---------
function Day (Date : Time) return Day_Number is
+ D : Day_Number;
Y : Year_Number;
M : Month_Number;
- D : Day_Number;
S : Day_Duration;
+ pragma Unreferenced (Y, M, S);
begin
Split (Date, Y, M, D, S);
return D;
M : Month_Number;
D : Day_Number;
S : Day_Duration;
+ pragma Unreferenced (Y, D, S);
begin
Split (Date, Y, M, D, S);
return M;
M : Month_Number;
D : Day_Number;
S : Day_Duration;
+ pragma Unreferenced (Y, M, D);
begin
Split (Date, Y, M, D, S);
return S;
Ss : Duration;
Le : Boolean;
+ pragma Unreferenced (H, M, Se, Ss, Le);
+
begin
-- Even though the input time zone is UTC (0), the flag Is_Ada_05 will
-- ensure that Split picks up the local time zone.
M : Month_Number;
D : Day_Number;
S : Day_Duration;
+ pragma Unreferenced (M, D, S);
begin
Split (Date, Y, M, D, S);
return Y;
Su : Duration;
Le : Boolean;
+ pragma Unreferenced (Ds, H, Mi, Se, Su, Le);
+
Day_Count : Long_Integer;
Res_Dur : Time_Dur;
Res_N : Time_Rep;
with Ada.Calendar; use Ada.Calendar;
with Ada.Calendar.Time_Zones; use Ada.Calendar.Time_Zones;
+pragma Warnings (Off); -- temp till we fix out param warnings ???
+
package body Ada.Calendar.Formatting is
--------------------------
Ss : Second_Duration;
Le : Boolean;
+ pragma Unreferenced (Y, Mo, H, Mi);
+
begin
Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le, Time_Zone);
return D;
Ss : Second_Duration;
Le : Boolean;
+ pragma Unreferenced (Y, Mo, D, Mi);
+
begin
Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le, Time_Zone);
return H;
Se : Second_Number;
Ss : Second_Duration;
Le : Boolean;
+
+ pragma Unreferenced (Y, Mo, D, H);
+
begin
Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le, Time_Zone);
return Mi;
Se : Second_Number;
Ss : Second_Duration;
Le : Boolean;
+
+ pragma Unreferenced (Y, D, H, Mi);
+
begin
Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le, Time_Zone);
return Mo;
Se : Second_Number;
Ss : Second_Duration;
Le : Boolean;
+
+ pragma Unreferenced (Y, Mo, D, H, Mi);
+
begin
Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le);
return Se;
return Day_Duration (Hour * 3_600) +
Day_Duration (Minute * 60) +
Day_Duration (Second) +
- Sub_Second;
+ Sub_Second;
end Seconds_Of;
-----------
Se : Second_Number;
Ss : Second_Duration;
Le : Boolean;
+
+ pragma Unreferenced (Y, Mo, D, H, Mi);
+
begin
Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le);
return Ss;
Ss : Second_Duration;
Le : Boolean;
+ pragma Unreferenced (Mo, D, H, Mi);
+
begin
Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le, Time_Zone);
return Y;
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Container.Last := null;
Container.Length := 0;
+ pragma Warnings (Off);
Free (X);
+ pragma Warnings (On);
end Clear;
--------------
if RI.Node.Element < LI.Node.Element then
declare
RJ : Cursor := RI;
+ pragma Warnings (Off, RJ);
begin
RI.Node := RI.Node.Next;
Splice (Target, LI, Source, RJ);
Count : Count_Type := 1)
is
Position : Cursor;
+ pragma Unreferenced (Position);
begin
Insert (Container, Before, New_Item, Position, Count);
end Insert;
declare
X : Buckets_Access := HT.Buckets;
+ pragma Warnings (Off, X);
begin
HT.Buckets := New_Buckets (Length => NN);
Free_Buckets (X);
Rehash : declare
Dst_Buckets : Buckets_Access := New_Buckets (Length => NN);
Src_Buckets : Buckets_Access := HT.Buckets;
+ pragma Warnings (Off, Src_Buckets);
L : Count_Type renames HT.Length;
LL : constant Count_Type := L;
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Clear (Container : in out List) is
X : Node_Access;
+ pragma Warnings (Off, X);
begin
if Container.Length = 0 then
if RI.Node.Element.all < LI.Node.Element.all then
declare
RJ : Cursor := RI;
+ pragma Warnings (Off, RJ);
begin
RI.Node := RI.Node.Next;
Splice (Target, LI, Source, RJ);
Count : Count_Type := 1)
is
Position : Cursor;
+ pragma Unreferenced (Position);
begin
Insert (Container, Before, New_Item, Position, Count);
end Insert;
New_Item : Element_Type)
is
Position : Cursor;
+ pragma Unreferenced (Position);
+
Inserted : Boolean;
begin
declare
K : Key_Type renames Position.Node.Key.all;
+
E : Element_Type renames Position.Node.Element.all;
+ pragma Unreferenced (E);
+
begin
Process (K, E);
+
exception
when others =>
L := L - 1;
New_Item : Element_Type)
is
Position : Cursor;
+ pragma Unreferenced (Position);
+
Inserted : Boolean;
begin
Element_Keys.Find (Container.HT, New_Item);
X : Element_Access;
+ pragma Warnings (Off, X);
begin
if Node = null then
------------
function To_Set (New_Item : Element_Type) return Set is
- HT : Hash_Table_Type;
+ HT : Hash_Table_Type;
+
Node : Node_Access;
Inserted : Boolean;
+ pragma Unreferenced (Node, Inserted);
begin
Insert (HT, New_Item, Node, Inserted);
Tgt_Node : Node_Access;
Success : Boolean;
+ pragma Unreferenced (Tgt_Node, Success);
-- Start of processing for Process
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Key : Key_Type;
New_Item : Element_Type)
is
-
Position : Cursor;
+ pragma Unreferenced (Position);
+
Inserted : Boolean;
begin
declare
K : Key_Type renames Position.Node.Key.all;
+
E : Element_Type renames Position.Node.Element.all;
+ pragma Unreferenced (E);
begin
Process (K, E);
+
exception
when others =>
L := L - 1;
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Insert (Container : in out Set; New_Item : Element_Type) is
Position : Cursor;
+ pragma Unreferenced (Position);
begin
Insert (Container, New_Item, Position);
end Insert;
------------
function To_Set (New_Item : Element_Type) return Set is
- Tree : Tree_Type;
- Node : Node_Access;
-
+ Tree : Tree_Type;
+ Node : Node_Access;
+ pragma Unreferenced (Node);
begin
Insert_Sans_Hint (Tree, New_Item, Node);
return Set'(Controlled with Tree);
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Insert (Container : in out Set; New_Item : Element_Type) is
Position : Cursor;
+ pragma Unreferenced (Position);
+
Inserted : Boolean;
+
begin
Insert (Container, New_Item, Position, Inserted);
Src_Node : Node_Access;
Dst_Node : out Node_Access)
is
- Success : Boolean;
+ Success : Boolean;
+ pragma Unreferenced (Success);
function New_Node return Node_Access;
Element_Keys.Find (Container.Tree, New_Item);
X : Element_Access;
+ pragma Warnings (Off, X);
begin
if Node = null then
------------
function To_Set (New_Item : Element_Type) return Set is
- Tree : Tree_Type;
+ Tree : Tree_Type;
+
Node : Node_Access;
Inserted : Boolean;
+ pragma Unreferenced (Node, Inserted);
begin
Insert_Sans_Hint (Tree, New_Item, Node, Inserted);
New_Item : Element_Type)
is
Position : Cursor;
+ pragma Unreferenced (Position);
+
Inserted : Boolean;
begin
declare
K : Key_Type renames Position.Node.Key;
E : Element_Type renames Position.Node.Element;
+ pragma Unreferenced (E);
begin
Process (K, E);
exception
New_Item : Element_Type)
is
Position : Cursor;
+ pragma Unreferenced (Position);
+
Inserted : Boolean;
begin
------------
function To_Set (New_Item : Element_Type) return Set is
- HT : Hash_Table_Type;
+ HT : Hash_Table_Type;
+
Node : Node_Access;
Inserted : Boolean;
+ pragma Unreferenced (Node, Inserted);
begin
Insert (HT, New_Item, Node, Inserted);
Tgt_Node : Node_Access;
Success : Boolean;
+ pragma Unreferenced (Tgt_Node, Success);
-- Start of processing for Process
Position : in out Cursor;
Count : Count_Type := 1)
is
+ pragma Warnings (Off, Position);
+
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
Position : in out Cursor;
Count : Count_Type := 1)
is
+ pragma Warnings (Off, Position);
+
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
New_Item : Element_Type)
is
Position : Cursor;
+ pragma Unreferenced (Position);
+
Inserted : Boolean;
begin
declare
K : Key_Type renames Position.Node.Key;
+
E : Element_Type renames Position.Node.Element;
+ pragma Unreferenced (E);
begin
Process (K, E);
+
exception
when others =>
L := L - 1;
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Insert (Container : in out Set; New_Item : Element_Type) is
Position : Cursor;
+ pragma Unreferenced (Position);
begin
Insert (Container, New_Item, Position);
end Insert;
------------
function To_Set (New_Item : Element_Type) return Set is
- Tree : Tree_Type;
- Node : Node_Access;
-
+ Tree : Tree_Type;
+ Node : Node_Access;
+ pragma Unreferenced (Node);
begin
Insert_Sans_Hint (Tree, New_Item, Node);
return Set'(Controlled with Tree);
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
New_Item : Element_Type)
is
Position : Cursor;
+ pragma Unreferenced (Position);
+
Inserted : Boolean;
begin
Dst_Node : out Node_Access)
is
Success : Boolean;
+ pragma Unreferenced (Success);
function New_Node return Node_Access;
pragma Inline (New_Node);
Tree : Tree_Type;
Node : Node_Access;
Inserted : Boolean;
-
+ pragma Unreferenced (Node, Inserted);
begin
Insert_Sans_Hint (Tree, New_Item, Node, Inserted);
return Set'(Controlled with Tree);
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Generic_Delete_Tree (X : in out Node_Access) is
Y : Node_Access;
+ pragma Warnings (Off, Y);
begin
while X /= null loop
Y := Right (X);
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Count : Count_Type := 1)
is
Position : Cursor;
-
+ pragma Unreferenced (Position);
begin
Insert (Container, Before, New_Item, Position, Count);
end Insert;
declare
I_Next : constant Cursor := Next (I);
+
J_Copy : Cursor := J;
+ pragma Warnings (Off, J_Copy);
begin
if I_Next = J then
else
declare
J_Next : constant Cursor := Next (J);
+
I_Copy : Cursor := I;
+ pragma Warnings (Off, I_Copy);
begin
if J_Next = I then
-- --
-- B o d y --
-- --
--- Copyright (C) 2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Vectors : out Real_Matrix)
is
N : constant Natural := Length (A);
- E : Real_Vector (1 .. N);
Tau : Real_Vector (1 .. N);
L_Work : Real_Vector (1 .. 1);
Info : aliased Integer;
+ E : Real_Vector (1 .. N);
+ pragma Warnings (Off, E);
+
begin
if Values'Length /= N then
raise Constraint_Error with "wrong length for output vector";
Info => Info'Access);
declare
- Work : Real_Vector (1 .. Integer'Max (Integer (L_Work (1)), 2 * N));
+ Work : Real_Vector (1 .. Integer'Max (Integer (L_Work (1)), 2 * N));
+ pragma Warnings (Off, Work);
+
Comp_Z : aliased constant Character := 'V';
begin
Values : out Real_Vector)
is
N : constant Natural := Length (A);
- B : Real_Matrix (1 .. N, 1 .. N);
- E : Real_Vector (1 .. N);
- Tau : Real_Vector (1 .. N);
L_Work : Real_Vector (1 .. 1);
Info : aliased Integer;
+ B : Real_Matrix (1 .. N, 1 .. N);
+ Tau : Real_Vector (1 .. N);
+ E : Real_Vector (1 .. N);
+ pragma Warnings (Off, B);
+ pragma Warnings (Off, Tau);
+ pragma Warnings (Off, E);
+
begin
if Values'Length /= N then
raise Constraint_Error with "wrong length for output vector";
declare
Work : Real_Vector (1 .. Integer'Min (Integer (L_Work (1)), 4 * N));
+ pragma Warnings (Off, Work);
begin
-- Reduce matrix to tridiagonal form
declare
Work : Real_Vector (1 .. Integer (L_Work (1)));
+ pragma Warnings (Off, Work);
+
begin
-- Compute inverse from LU decomposition
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
function Euclid (P, Q : Int) return Int is
X, Y, GCD : Int;
-
+ pragma Unreferenced (Y, GCD);
begin
Euclid (P, Q, X, Y, GCD);
return X;
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
pragma Assert (Tree.Lock = 0);
Root : Node_Access := Tree.Root;
+ pragma Warnings (Off, Root);
begin
Tree.Root := null;
R_Node : Node_Access := Right.First;
Dst_Node : Node_Access;
+ pragma Warnings (Off, Dst_Node);
begin
if Left'Address = Right'Address then
R_Node : Node_Access := Right.First;
Dst_Node : Node_Access;
+ pragma Warnings (Off, Dst_Node);
begin
if Left'Address = Right'Address then
Src : Node_Access := Source.First;
New_Tgt_Node : Node_Access;
+ pragma Warnings (Off, New_Tgt_Node);
begin
if Target.Busy > 0 then
R_Node : Node_Access := Right.First;
Dst_Node : Node_Access;
+ pragma Warnings (Off, Dst_Node);
begin
if Left'Address = Right'Address then
Ptr : in out Integer)
is
Junk : Boolean;
-
+ pragma Unreferenced (Junk);
begin
Load_Extended_Digits (File, Buf, Ptr, Junk);
end Load_Extended_Digits;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Ptr : in out Integer)
is
Junk : Boolean;
-
+ pragma Unreferenced (Junk);
begin
Load_Extended_Digits (File, Buf, Ptr, Junk);
end Load_Extended_Digits;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Ptr : in out Integer)
is
Junk : Boolean;
-
+ pragma Unreferenced (Junk);
begin
Load_Extended_Digits (File, Buf, Ptr, Junk);
end Load_Extended_Digits;
-----------------------
procedure Gen_Output_File_C (Filename : String) is
-
Bfile : Name_Id;
- -- Name of generated bind file
+ pragma Warnings (Off, Bfile);
+ -- Name of generated bind file (not referenced)
begin
Create_Binder_Output (Filename, 'c', Bfile);
if Use_Pragma_Linker_Constructor then
WBI ("extern void " & Ada_Init_Name.all &
" (void) __attribute__((constructor));");
-
else
WBI ("extern void " & Ada_Init_Name.all & " (void);");
end if;
LOK : Boolean;
Rlo : Uint;
Rhi : Uint;
- ROK : Boolean;
+ ROK : Boolean;
+
+ pragma Warnings (Off, Lhi);
+ -- Don't actually use this value
begin
if Expander_Active
Num_Saved_Checks := 0;
- for J in 1 .. Saved_Checks_TOS loop
+ -- Note: the Int'Min here avoids any possibility of J being out of
+ -- range when called from e.g. Conditional_Statements_Begin.
+
+ for J in 1 .. Int'Min (Saved_Checks_TOS, Saved_Checks_Stack'Last) loop
Saved_Checks_Stack (J) := 0;
end loop;
end Kill_All_Checks;
L_Index : Node_Id;
R_Index : Node_Id;
- L_Low : Node_Id;
- L_High : Node_Id;
- R_Low : Node_Id;
- R_High : Node_Id;
begin
L_Index := First_Index (T_Typ);
or else
Nkind (R_Index) = N_Raise_Constraint_Error)
then
- Get_Index_Bounds (L_Index, L_Low, L_High);
- Get_Index_Bounds (R_Index, R_Low, R_High);
-
-- Deal with compile time length check. Note that we
-- skip this in the access case, because the access
-- value may be null, so we cannot know statically.
Evolve_Or_Else
(Cond,
Range_Equal_E_Cond (Exptyp, T_Typ, Indx));
-
else
Evolve_Or_Else
(Cond, Range_E_Cond (Exptyp, T_Typ, Indx));
-- Directly_Designated_Type Node20
-- Discriminant_Checking_Func Node20
-- Discriminant_Default_Value Node20
- -- Last_Assignment Node20
-- Last_Entity Node20
-- Register_Exception_Call Node20
-- Scalar_Range Node20
-- DT_Offset_To_Top_Func Node25
-- Task_Body_Procedure Node25
- -- Dispatch_Table_Wrapper Node16
+ -- Dispatch_Table_Wrapper Node26
+ -- Last_Assignment Node26
-- Overridden_Operation Node26
-- Package_Instantiation Node26
-- Related_Interface Node26
(Ekind (Id) = E_Constant
or else Ekind (Id) = E_Variable
or else Ekind (Id) = E_Generic_In_Out_Parameter
- or else Ekind (Id) in E_In_Parameter .. E_In_Out_Parameter);
+ or else Is_Formal (Id));
return Node17 (Id);
end Actual_Subtype;
function Last_Assignment (Id : E) return N is
begin
- pragma Assert (Ekind (Id) = E_Variable);
- return Node20 (Id);
+ pragma Assert (Is_Assignable (Id));
+ return Node26 (Id);
end Last_Assignment;
function Last_Entity (Id : E) return E is
return Ekind (Id) in Array_Kind;
end Is_Array_Type;
+ function Is_Assignable (Id : E) return B is
+ begin
+ return Ekind (Id) in Assignable_Kind;
+ end Is_Assignable;
+
function Is_Class_Wide_Type (Id : E) return B is
begin
return Ekind (Id) in Class_Wide_Kind;
(Ekind (Id) = E_Constant
or else Ekind (Id) = E_Variable
or else Ekind (Id) = E_Generic_In_Out_Parameter
- or else Ekind (Id) in E_In_Parameter .. E_In_Out_Parameter);
+ or else Is_Formal (Id));
Set_Node17 (Id, V);
end Set_Actual_Subtype;
procedure Set_Last_Assignment (Id : E; V : N) is
begin
- pragma Assert (Ekind (Id) = E_Variable);
- Set_Node20 (Id, V);
+ pragma Assert (Is_Assignable (Id));
+ Set_Node26 (Id, V);
end Set_Last_Assignment;
procedure Set_Last_Entity (Id : E; V : E) is
-- Normal case, search enclosing scopes
+ -- Note: the test for Present (S) should not be required, it is a
+ -- defence against an ill-formed tree.
+
S := Scope (Id);
- while S /= Standard_Standard
- and then not Is_Dynamic_Scope (S)
loop
- S := Scope (S);
+ -- If we somehow got an empty value for Scope, the tree must be
+ -- malformed. Rather than blow up we return Standard in this case.
+
+ if No (S) then
+ return Standard_Standard;
+
+ -- Quit if we get to standard or a dynamic scope
+
+ elsif S = Standard_Standard
+ or else Is_Dynamic_Scope (S)
+ then
+ return S;
+
+ -- Otherwise keep climbing
+
+ else
+ S := Scope (S);
+ end if;
end loop;
return S;
when E_Exception =>
Write_Str ("Register_Exception_Call");
- when E_Variable =>
- Write_Str ("Last_Assignment");
-
when others =>
Write_Str ("Field20??");
end case;
E_Record_Type_With_Private =>
Write_Str ("Dispatch_Table_Wrapper");
+ when E_In_Out_Parameter |
+ E_Out_Parameter |
+ E_Variable =>
+ Write_Str ("Last_Assignment");
+
when others =>
Write_Str ("Field26??");
end case;
-- initialization, it may or may not be set if the type does have
-- preelaborable initialization.
--- Last_Assignment (Node20)
--- Present in entities for variables. Set for a local variable to point
--- to the left side of an assignment statement assigning a value to the
--- variable. Cleared if the value of the variable is referenced. Used to
--- warn about dubious assignment statements whose value is not used.
+-- Last_Assignment (Node26)
+-- Present in entities for variables, and OUT or IN OUT formals. Set for
+-- a local variable or formal to point to the left side of an assignment
+-- statement assigning a value to the variable. Cleared if the value of
+-- the entity is referenced. Used to warn about dubious assignment
+-- statements whose value is not used.
-- Last_Entity (Node20)
-- Present in all entities which act as scopes to which a list of
-- Objects --
-------------
- E_Variable,
- -- Variables created by an object declaration with no constant keyword
-
E_Component,
-- Components of a record declaration, private declarations of
-- protected objects.
E_Loop_Parameter,
-- A loop parameter created by a for loop
+ E_Variable,
+ -- Variables created by an object declaration with no constant keyword
+
------------------------
-- Parameter Entities --
------------------------
-- Parameters are also objects
- E_In_Parameter,
- -- An in parameter of a subprogram or entry
-
E_Out_Parameter,
-- An out parameter of a subprogram or entry
E_In_Out_Parameter,
-- An in-out parameter of a subprogram or entry
+ E_In_Parameter,
+ -- An in parameter of a subprogram or entry
+
--------------------------------
-- Generic Parameter Entities --
--------------------------------
-- E_String_Subtype
E_String_Literal_Subtype;
+ subtype Assignable_Kind is Entity_Kind range
+ E_Variable ..
+ -- E_Out_Parameter
+ E_In_Out_Parameter;
+
subtype Class_Wide_Kind is Entity_Kind range
E_Class_Wide_Type ..
E_Class_Wide_Subtype;
E_Floating_Point_Subtype;
subtype Formal_Kind is Entity_Kind range
- E_In_Parameter ..
- -- E_Out_Parameter
- E_In_Out_Parameter;
+ E_Out_Parameter ..
+ -- E_In_Out_Parameter
+ E_In_Parameter;
subtype Formal_Object_Kind is Entity_Kind range
E_Generic_In_Out_Parameter ..
E_Floating_Point_Subtype;
subtype Object_Kind is Entity_Kind range
- E_Variable ..
- -- E_Component
+ E_Component ..
-- E_Constant
-- E_Discriminant
-- E_Loop_Parameter
- -- E_In_Parameter
+ -- E_Variable
-- E_Out_Parameter
-- E_In_Out_Parameter
+ -- E_In_Parameter
-- E_Generic_In_Out_Parameter
E_Generic_In_Parameter;
-- Extra_Formal (Node15)
-- Unset_Reference (Node16)
-- Actual_Subtype (Node17)
+
-- Renamed_Object (Node18)
-- Spec_Entity (Node19)
-- Default_Value (Node20)
-- Default_Expr_Function (Node21)
-- Protected_Formal (Node22)
-- Extra_Constrained (Node23)
+ -- Last_Assignment (Node26) (OUT, IN-OUT only)
-- Has_Initial_Value (Flag219)
-- Is_Controlling_Formal (Flag97)
-- Is_Optional_Parameter (Flag134)
-- Actual_Subtype (Node17)
-- Renamed_Object (Node18)
-- Size_Check_Code (Node19)
- -- Last_Assignment (Node20)
-- Interface_Name (Node21)
-- Shared_Var_Assign_Proc (Node22)
-- Extra_Constrained (Node23)
-- Debug_Renaming_Link (Node25)
+ -- Last_Assignment (Node26)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
function Is_Access_Type (Id : E) return B;
function Is_Access_Protected_Subprogram_Type (Id : E) return B;
function Is_Array_Type (Id : E) return B;
+ function Is_Assignable (Id : E) return B;
function Is_Class_Wide_Type (Id : E) return B;
function Is_Composite_Type (Id : E) return B;
function Is_Concurrent_Body (Id : E) return B;
pragma Inline (Is_Access_Protected_Subprogram_Type);
pragma Inline (Is_Aliased);
pragma Inline (Is_Array_Type);
+ pragma Inline (Is_Assignable);
pragma Inline (Is_Asynchronous);
pragma Inline (Is_Atomic);
pragma Inline (Is_Bit_Packed_Array);
function Compose (RT : R; Fraction : T; Exponent : UI) return T is
Arg_Frac : T;
Arg_Exp : UI;
+ pragma Warnings (Off, Arg_Exp);
begin
if UR_Is_Zero (Fraction) then
return Fraction;
function Exponent (RT : R; X : T) return UI is
X_Frac : UI;
X_Exp : UI;
+ pragma Warnings (Off, X_Frac);
begin
if UR_Is_Zero (X) then
return Uint_0;
function Fraction (RT : R; X : T) return T is
X_Frac : T;
X_Exp : UI;
+ pragma Warnings (Off, X_Exp);
begin
if UR_Is_Zero (X) then
return X;
K : UI;
P_Even : Boolean;
+ pragma Warnings (Off, Arg_Frac);
+
begin
if UR_Is_Positive (X) then
Sign_X := Ureal_1;
if Ekind (Formal) /= E_In_Parameter
and then Is_Entity_Name (Actual)
+ and then Present (Entity (Actual))
then
- Kill_Current_Values (Entity (Actual));
+ declare
+ Ent : constant Entity_Id := Entity (Actual);
+ Sav : Node_Id;
+
+ begin
+ -- For an OUT parameter that is an assignable entity, we do not
+ -- want to clobber the Last_Assignment field, since if it is
+ -- set, it was precisely because it is indeed an OUT parameter!
+
+ if Ekind (Formal) = E_Out_Parameter
+ and then Is_Assignable (Ent)
+ then
+ Sav := Last_Assignment (Ent);
+ Kill_Current_Values (Ent);
+ Set_Last_Assignment (Ent, Sav);
+
+ -- For all other cases, just kill the current values
+
+ else
+ Kill_Current_Values (Ent);
+ end if;
+ end;
end if;
-- If the formal is class wide and the actual is an aggregate, force
-- ensure the correct replacement of the object declaration by the
-- object renaming declaration to avoid homograph conflicts (since
-- the object declaration's defining identifier was already entered
- -- in current scope).
+ -- in current scope). The Next_Entity links of the two entities also
+ -- have to be swapped since the entities are part of the return
+ -- scope's entity list and the list structure would otherwise be
+ -- corrupted.
+
+ declare
+ Renaming_Def_Id : constant Entity_Id :=
+ Defining_Identifier (Object_Decl);
+ Next_Entity_Temp : constant Entity_Id :=
+ Next_Entity (Renaming_Def_Id);
+ begin
+ Set_Chars (Renaming_Def_Id, Chars (Obj_Def_Id));
+
+ -- Swap next entity links in preparation for exchanging entities
- Set_Chars (Defining_Identifier (Object_Decl), Chars (Obj_Def_Id));
- Exchange_Entities (Defining_Identifier (Object_Decl), Obj_Def_Id);
+ Set_Next_Entity (Renaming_Def_Id, Next_Entity (Obj_Def_Id));
+ Set_Next_Entity (Obj_Def_Id, Next_Entity_Temp);
+
+ Exchange_Entities (Renaming_Def_Id, Obj_Def_Id);
+ end;
end if;
-- If the object entity has a class-wide Etype, then we need to change
Rnn : Entity_Id;
Code : List_Id;
+ pragma Warnings (Off, Rnn);
+
begin
Build_Double_Divide_Code (N, X, Y, Z, Qnn, Rnn, Code);
Insert_Actions (N, Code);
Rnn : Entity_Id;
Code : List_Id;
+ pragma Warnings (Off, Rnn);
+
begin
Build_Scaled_Divide_Code (N, X, Y, Z, Qnn, Rnn, Code);
Insert_Actions (N, Code);
function Is_Out_Actual (N : Node_Id) return Boolean;
-- In a similar manner, this function determines if N appears as an
-- OUT or IN OUT parameter to a procedure call. If the result is
- -- True, then Insert_Node is set to point to the assignment.
+ -- True, then Insert_Node is set to point to the call.
---------------------
-- Add_Read_Before --
-------------------
function Is_Out_Actual (N : Node_Id) return Boolean is
- Parnt : constant Node_Id := Parent (N);
- Formal : Entity_Id;
- Call : Node_Id;
- Actual : Node_Id;
+ Kind : Entity_Kind;
+ Call : Node_Id;
begin
- if (Nkind (Parnt) = N_Indexed_Component
- or else
- Nkind (Parnt) = N_Selected_Component)
- and then N = Prefix (Parnt)
- then
- return Is_Out_Actual (Parnt);
-
- elsif Nkind (Parnt) = N_Parameter_Association
- and then N = Explicit_Actual_Parameter (Parnt)
- then
- Call := Parent (Parnt);
-
- elsif Nkind (Parnt) = N_Procedure_Call_Statement then
- Call := Parnt;
+ Find_Actual_Mode (N, Kind, Call);
+ if Kind = E_Out_Parameter or else Kind = E_In_Out_Parameter then
+ Insert_Node := Call;
+ return True;
else
return False;
end if;
-
- -- Fall here if we are definitely a parameter
-
- Actual := First_Actual (Call);
- Formal := First_Formal (Entity (Name (Call)));
-
- loop
- if Actual = N then
- if Ekind (Formal) /= E_In_Parameter then
- Insert_Node := Call;
- return True;
- else
- return False;
- end if;
-
- else
- Actual := Next_Actual (Actual);
- Formal := Next_Formal (Formal);
- end if;
- end loop;
end Is_Out_Actual;
---------------------------
if Last_In_Table = 0 then
declare
Discard : Boolean;
-
+ pragma Warnings (Off, Discard);
begin
Delete_File (File_Name, Discard);
end;
procedure Freeze_Record_Type (Rec : Entity_Id) is
Comp : Entity_Id;
IR : Node_Id;
- Junk : Boolean;
ADC : Node_Id;
Prev : Entity_Id;
+ Junk : Boolean;
+ pragma Warnings (Off, Junk);
+
Unplaced_Component : Boolean := False;
-- Set True if we find at least one component with no component
-- clause (used to warn about useless Pack pragmas).
and then Known_RM_Size (E)
then
declare
+ SizC : constant Node_Id := Size_Clause (E);
+
Discard : Boolean;
- SizC : constant Node_Id := Size_Clause (E);
+ pragma Warnings (Off, Discard);
begin
-- It is not clear if it is possible to have no size
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2006 AdaCore --
+-- Copyright (C) 2000-2007, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Split_Line (Session : Session_Type) is
Fields : Field_Table.Instance renames Session.Data.Fields;
+ pragma Unreferenced (Fields);
begin
Field_Table.Init (Fields);
Split.Current_Line (Session.Data.Separators.all, Session);
Month : Month_Number;
Day : Day_Number;
Day_Secs : Day_Duration;
+ pragma Unreferenced (Day_Secs);
begin
Split (Date, Year, Month, Day, Day_Secs);
return Julian_Day (Year, Month, Day) - Julian_Day (Year, 1, 1) + 1;
Month : Month_Number;
Day : Day_Number;
Day_Secs : Day_Duration;
+ pragma Unreferenced (Day_Secs);
begin
Split (Date, Year, Month, Day, Day_Secs);
return Day_Name'Val ((Julian_Day (Year, Month, Day)) mod 7);
Minute : Minute_Number;
Second : Second_Number;
Sub_Second : Second_Duration;
+ pragma Unreferenced (Year, Month, Day, Minute, Second, Sub_Second);
begin
Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
return Hour;
Minute : Minute_Number;
Second : Second_Number;
Sub_Second : Second_Duration;
+ pragma Unreferenced (Year, Month, Day, Hour, Second, Sub_Second);
begin
Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
return Minute;
Minute : Minute_Number;
Second : Second_Number;
Sub_Second : Second_Duration;
+ pragma Unreferenced (Year, Month, Day, Hour, Minute, Sub_Second);
begin
Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
return Second;
Minute : Minute_Number;
Second : Second_Number;
Sub_Second : Second_Duration;
+ pragma Unreferenced (Year, Month, Day, Hour, Minute, Second);
begin
Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
return Sub_Second;
Second : Second_Number;
Sub_Second : Second_Duration := 0.0) return Time
is
+
Day_Secs : constant Day_Duration :=
Day_Duration (Hour * 3_600) +
Day_Duration (Minute * 60) +
Shift : Week_In_Year_Number;
Start_Week : Week_In_Year_Number;
+ pragma Unreferenced (Hour, Minute, Second, Sub_Second);
+
function Is_Leap (Year : Year_Number) return Boolean;
-- Return True if Year denotes a leap year. Leap centential years are
-- properly handled.
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2005, AdaCore --
+-- Copyright (C) 2001-2007, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
--------------------
procedure Read_Directory (Directory : Dir_Name_Str) is
- Dir : Dir_Type;
Buffer : String (1 .. 2_048);
Last : Natural;
+ Dir : Dir_Type;
+ pragma Warnings (Off, Dir);
+
begin
Open (Dir, Directory);
is
File_Regexp : constant Regexp.Regexp :=
Regexp.Compile (File_Pattern, Glob => True);
- Dir : Dir_Type;
+
+ Dir : Dir_Type;
+ pragma Warnings (Off, Dir);
+
Buffer : String (1 .. 2_048);
Last : Natural;
procedure Close (Descriptor : in out Process_Descriptor) is
Status : Integer;
+ pragma Unreferenced (Status);
begin
Close (Descriptor, Status);
end Close;
Full_Buffer : Boolean := False)
is
Matched : GNAT.Regpat.Match_Array (0 .. 0);
-
+ pragma Warnings (Off, Matched);
begin
Expect (Descriptor, Result, Regexp, Matched, Timeout, Full_Buffer);
end Expect;
Full_Buffer : Boolean := False)
is
Patterns : Compiled_Regexp_Array (Regexps'Range);
- Matched : GNAT.Regpat.Match_Array (0 .. 0);
+
+ Matched : GNAT.Regpat.Match_Array (0 .. 0);
+ pragma Warnings (Off, Matched);
begin
for J in Regexps'Range loop
Full_Buffer : Boolean := False)
is
Matched : GNAT.Regpat.Match_Array (0 .. 0);
-
+ pragma Warnings (Off, Matched);
begin
Expect (Descriptor, Result, Regexps, Matched, Timeout, Full_Buffer);
end Expect;
Full_Buffer : Boolean := False)
is
Matched : GNAT.Regpat.Match_Array (0 .. 0);
-
+ pragma Warnings (Off, Matched);
begin
Expect (Result, Regexps, Matched, Timeout, Full_Buffer);
end Expect;
declare
Result : Expect_Match;
+ pragma Unreferenced (Result);
begin
-- This loop runs until the call to Expect raises Process_Died
Empty_Buffer : Boolean := False)
is
Line_Feed : aliased constant String := (1 .. 1 => ASCII.LF);
- Result : Expect_Match;
Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
+ Result : Expect_Match;
Discard : Natural;
+ pragma Warnings (Off, Result);
pragma Warnings (Off, Discard);
begin
Pipe3 : not null access Pipe_Type)
is
Status : Boolean;
+ pragma Unreferenced (Status);
begin
-- Create the pipes
(Subject : VString;
Pat : Pattern) return Boolean
is
- Start : Natural;
- Stop : Natural;
S : String_Access;
L : Natural;
+ Start : Natural;
+ Stop : Natural;
+ pragma Unreferenced (Stop);
+
begin
Get_String (Subject, S, L);
Pat : Pattern) return Boolean
is
Start, Stop : Natural;
+ pragma Unreferenced (Stop);
+
subtype String1 is String (1 .. Subject'Length);
begin
(Subject : VString;
Pat : Pattern)
is
+ S : String_Access;
+ L : Natural;
+
Start : Natural;
Stop : Natural;
- S : String_Access;
- L : Natural;
+ pragma Unreferenced (Start, Stop);
begin
Get_String (Subject, S, L);
Pat : Pattern)
is
Start, Stop : Natural;
+ pragma Unreferenced (Start, Stop);
+
subtype String1 is String (1 .. Subject'Length);
+
begin
if Debug_Mode then
XMatchD (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
(Subject : VString;
Pat : PString)
is
+ S : String_Access;
+ L : Natural;
+
Start : Natural;
Stop : Natural;
- S : String_Access;
- L : Natural;
+ pragma Unreferenced (Start, Stop);
begin
Get_String (Subject, S, L);
Pat : PString)
is
Start, Stop : Natural;
+ pragma Unreferenced (Start, Stop);
+
subtype String1 is String (1 .. Subject'Length);
begin
Parm : Void_Ptr;
Code : Code_Proc)
is
+ pragma Unreferenced (Parm);
pragma Priority (Prio);
pragma Storage_Size (Stsz);
end Thread;
File.Table (Input).Name.all & ASCII.Nul;
Length : File_Offset;
Buffer : String_Access;
- Success : Boolean;
Result : String_Access;
+ Success : Boolean;
+ pragma Warnings (Off, Success);
+
begin
FD := Open_Read (Name'Address, Binary);
-- Used for various Interfaces.C_Streams calls
Closing_Status : Boolean;
+ pragma Warnings (Off, Closing_Status);
-- For call to Close
GNAT_Static : Boolean := False;
-- convenient to eliminate the redundancy by keying the
-- compilation mode on a single switch, namely --RTS.
- -- Pass -mrtp to the linker if --RTS=rtp was passed.
+ -- Pass -mrtp to the linker if --RTS=rtp was passed
if Linker_Path = Gcc_Path
and then Arg'Length > 8
Linker_Options.Table (Linker_Options.Last) :=
new String'("-mrtp");
- -- Pass -fsjlj to the linker if --RTS=sjlj was passed.
+ -- Pass -fsjlj to the linker if --RTS=sjlj was passed
elsif Linker_Path = Gcc_Path
and then Arg'Length > 9
with Table; use Table;
with Widechar; use Widechar;
-with GNAT.Heap_Sort_A;
+with GNAT.Heap_Sort_G;
package body Lib.Xref is
------------------------
procedure Generate_Reference
- (E : Entity_Id;
- N : Node_Id;
- Typ : Character := 'r';
- Set_Ref : Boolean := True;
- Force : Boolean := False)
+ (E : Entity_Id;
+ N : Node_Id;
+ Typ : Character := 'r';
+ Set_Ref : Boolean := True;
+ Force : Boolean := False)
is
Indx : Nat;
Nod : Node_Id;
Def : Source_Ptr;
Ent : Entity_Id;
+ Kind : Entity_Kind;
+ Call : Node_Id;
+ -- Arguments used in call to Find_Actual_Mode
+
function Is_On_LHS (Node : Node_Id) return Boolean;
-- Used to check if a node is on the left hand side of an assignment.
-- The following cases are handled:
--
- -- Variable Node is a direct descendant of an assignment statement.
+ -- Variable Node is a direct descendant of left hand side of an
+ -- assignment statement.
+ --
+ -- Prefix Of an indexed or selected component that is present in
+ -- a subtree rooted by an assignment statement. There is
+ -- no restriction of nesting of components, thus cases
+ -- such as A.B (C).D are handled properly. However a prefix
+ -- of a dereference (either implicit or explicit) is never
+ -- considered as on a LHS.
--
- -- Prefix Of an indexed or selected component that is present in a
- -- subtree rooted by an assignment statement. There is no
- -- restriction of nesting of components, thus cases such as
- -- A.B (C).D are handled properly.
- -- However a prefix of a dereference (either implicit or
- -- explicit) is never considered as on a LHS.
+ -- Out param Same as above cases, but OUT parameter
---------------
-- Is_On_LHS --
-- Sem_Util.May_Be_Lvalue
-- Sem_Util.Known_To_Be_Assigned
-- Exp_Ch2.Expand_Entry_Parameter.In_Assignment_Context
+ -- Exp_Smem.Is_Out_Actual
function Is_On_LHS (Node : Node_Id) return Boolean is
- N : Node_Id := Node;
+ N : Node_Id;
+ P : Node_Id;
+ K : Node_Kind;
begin
-- Only identifiers are considered, is this necessary???
- if Nkind (N) /= N_Identifier then
+ if Nkind (Node) /= N_Identifier then
return False;
end if;
- -- Reach the assignment statement subtree root. In the case of a
- -- variable being a direct descendant of an assignment statement,
- -- the loop is skiped.
+ -- Immediat return if appeared as OUT parameter
- while Nkind (Parent (N)) /= N_Assignment_Statement loop
+ if Kind = E_Out_Parameter then
+ return True;
+ end if;
- -- Check whether the parent is a component and the current node
- -- is its prefix, but return False if the current node has an
- -- access type, as in that case the selected or indexed component
- -- is an implicit dereference, and the LHS is the designated
- -- object, not the access object.
+ -- Search for assignment statement subtree root
+
+ N := Node;
+ loop
+ P := Parent (N);
+ K := Nkind (P);
+
+ if K = N_Assignment_Statement then
+ return Name (P) = N;
+
+ -- Check whether the parent is a component and the current node is
+ -- its prefix, but return False if the current node has an access
+ -- type, as in that case the selected or indexed component is an
+ -- implicit dereference, and the LHS is the designated object, not
+ -- the access object.
-- ??? case of a slice assignment?
-- dereference. If the dereference is on an LHS, this causes a
-- false positive.
- if (Nkind (Parent (N)) = N_Selected_Component
- or else
- Nkind (Parent (N)) = N_Indexed_Component)
- and then Prefix (Parent (N)) = N
+ elsif (K = N_Selected_Component or else K = N_Indexed_Component)
+ and then Prefix (P) = N
and then not (Present (Etype (N))
and then
Is_Access_Type (Etype (N)))
then
- N := Parent (N);
+ N := P;
+
+ -- All other cases, definitely not on left side
+
else
return False;
end if;
begin
pragma Assert (Nkind (E) in N_Entity);
+ Find_Actual_Mode (N, Kind, Call);
-- Check for obsolescent reference to package ASCII. GNAT treats this
-- element of annex J specially since in practice, programs make a lot
if (Ekind (E) = E_Variable or else Is_Formal (E))
and then Is_On_LHS (N)
then
- Set_Referenced_As_LHS (E);
+ -- If we have the OUT parameter case and the warning mode for
+ -- OUT parameters is not set, treat this as an ordinary reference
+ -- since we don't want warnings about it being unset.
+
+ if Kind = E_Out_Parameter and not Warn_On_Out_Parameter_Unread then
+ Set_Referenced (E);
+
+ -- For other cases, set referenced on LHS
+
+ else
+ Set_Referenced_As_LHS (E);
+ end if;
-- Check for a reference in a pragma that should not count as a
-- making the variable referenced for warning purposes.
then
null;
- -- Any other occurrence counts as referencing the entity
+ -- All other cases
else
- Set_Referenced (E);
+ -- Special processing for IN OUT and OUT parameters, where we
+ -- have an implicit assignment to a simple variable.
+
+ if (Kind = E_Out_Parameter or else Kind = E_In_Out_Parameter)
+ and then Is_Entity_Name (N)
+ and then Present (Entity (N))
+ and then Is_Assignable (Entity (N))
+ then
+ -- Record implicit assignment unless we have an intrinsic
+ -- subprogram, which is most likely an instantiation of
+ -- Unchecked_Deallocation which we do not want to consider
+ -- as an assignment since it generates false positives. We
+ -- also exclude the case of an IN OUT parameter to a procedure
+ -- called Free, since we suspect similar semantics.
+
+ if Is_Entity_Name (Name (Call))
+ and then not Is_Intrinsic_Subprogram (Entity (Name (Call)))
+ and then (Kind /= E_In_Out_Parameter
+ or else Chars (Name (Call)) /= Name_Free)
+ then
+ Set_Referenced_As_LHS (E);
+ end if;
+
+ -- For IN OUT case, treat as also being normal reference
+
+ if Kind = E_In_Out_Parameter then
+ Set_Referenced (E);
+ end if;
+
+ -- Any other occurrence counts as referencing the entity
+
+ else
+ Set_Referenced (E);
+
+ -- If variable, this is an OK reference after an assignment
+ -- so we can clear the Last_Assignment indication.
- if Ekind (E) = E_Variable then
- Set_Last_Assignment (E, Empty);
+ if Is_Assignable (E) then
+ Set_Last_Assignment (E, Empty);
+ end if;
end if;
end if;
Handle_Orphan_Type_References : declare
J : Nat;
Tref : Entity_Id;
- L, R : Character;
Indx : Nat;
Ent : Entity_Id;
Loc : Source_Ptr;
+ L, R : Character;
+ pragma Warnings (Off, L);
+ pragma Warnings (Off, R);
+
procedure New_Entry (E : Entity_Id);
-- Make an additional entry into the Xref table for a type entity
-- that is related to the current entity (parent, type ancestor,
procedure Move (From : Natural; To : Natural);
-- Move procedure for Sort call
+ package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
+
--------
-- Lt --
--------
-- Sort the references
- GNAT.Heap_Sort_A.Sort
- (Integer (Nrefs),
- Move'Unrestricted_Access,
- Lt'Unrestricted_Access);
+ Sorting.Sort (Integer (Nrefs));
-- Eliminate duplicate entries
for Refno in 1 .. Nrefs loop
Output_One_Ref : declare
P2 : Source_Ptr;
+ Ent : Entity_Id;
+
WC : Char_Code;
Err : Boolean;
- Ent : Entity_Id;
+ pragma Warnings (Off, WC);
+ pragma Warnings (Off, Err);
XE : Xref_Entry renames Xrefs.Table (Rnums (Refno));
-- The current entry to be accessed
-- For a type that implements multiple interfaces, there is an
-- entry of the form LR=<> for each of the interfaces appearing
- -- in the type declaration.
+ -- in the type declaration. In the data structures of ali.ads,
+ -- the type that the entity extends (or the first interface if
+ -- there is no such type) is stored in Xref_Entity_Record.Tref*,
+ -- additional interfaces are stored in the list of references
+ -- with a special type of Interface_Reference.
-- For an array type, there is an entry of the form LR=<> for
-- each of the index types appearing in the type declaration.
-- The index types follow the entry for the component type.
+ -- In the data structures of ali.ads, however, the list of index
+ -- types are output in the list of references with a special
+ -- Rtype set to Array_Index_Reference.
-- In the above list LR shows the brackets used in the output,
-- which has one of the two following forms:
-- a renaming of a predefined operator.
procedure Generate_Reference
- (E : Entity_Id;
- N : Node_Id;
- Typ : Character := 'r';
- Set_Ref : Boolean := True;
- Force : Boolean := False);
+ (E : Entity_Id;
+ N : Node_Id;
+ Typ : Character := 'r';
+ Set_Ref : Boolean := True;
+ Force : Boolean := False);
-- This procedure is called to record a reference. N is the location
-- of the reference and E is the referenced entity. Typ is one of:
--
-- the node N is not an identifier, defining identifier, or expanded name
-- the type is 'p' and the entity is not in the extended main source
--
- -- If all these conditions are met, then the Is_Referenced flag of E
- -- is set (unless Set_Ref is False) and a cross-reference entry is
- -- recorded for later output when Output_References is called.
+ -- If all these conditions are met, then the Is_Referenced flag of E is set
+ -- (unless Set_Ref is False) and a cross-reference entry is recorded for
+ -- later output when Output_References is called.
--
-- Note: the dummy space entry is for the convenience of some callers,
-- who find it easier to pass a space to suppress the entry than to do
-- a specific test. The call has no effect if the type is a space.
--
- -- The parameter Set_Ref is normally True, and indicates that in
- -- addition to generating a cross-reference, the Referenced flag
- -- of the specified entity should be set. If this parameter is
- -- False, then setting of the Referenced flag is inhibited.
+ -- The parameter Set_Ref is normally True, and indicates that in addition
+ -- to generating a cross-reference, the Referenced flag of the specified
+ -- entity should be set. If this parameter is False, then setting of the
+ -- Referenced flag is inhibited.
--
- -- The parameter Force is set to True to force a reference to be
- -- generated even if Comes_From_Source is false. This is used for
- -- certain implicit references, and also for end label references.
+ -- The parameter Force is set to True to force a reference to be generated
+ -- even if Comes_From_Source is false. This is used for certain implicit
+ -- references, and also for end label references.
procedure Generate_Reference_To_Formals (E : Entity_Id);
-- Add a reference to the definition of each formal on the line for
procedure Delete_Mapping_Files is
Success : Boolean;
+ pragma Warnings (Off, Success);
begin
if not Debug.Debug_Flag_N then
if The_Mapping_File_Names /= null then
procedure Delete_Temp_Config_Files is
Success : Boolean;
+ pragma Warnings (Off, Success);
+
begin
if (not Debug.Debug_Flag_N) and Main_Project /= No_Project then
for Project in Project_Table.First ..
-- The path name of the mapping file
Discard : Boolean;
+ pragma Warnings (Off, Discard);
procedure Check_Mains;
-- Check that the main subprograms do exist and that they all
Get_Name_String (Source_File);
Saved_Verbosity : constant Verbosity := Current_Verbosity;
Project : Project_Id := No_Project;
- Path_Name : Path_Name_Type := No_Path;
Data : Project_Data;
+ Path_Name : Path_Name_Type := No_Path;
+ pragma Warnings (Off, Path_Name);
+
begin
-- Call Get_Reference to know the ultimate extending project of
-- the source. Call it with verbosity default to avoid verbose
Time_Stamp : Time_Stamp_Type;
Saved_Last_Argument : Natural;
First_Object : Natural;
- Discard : Boolean;
+
+ Discard : Boolean;
+ pragma Warnings (Off, Discard);
begin
Check_Archive_Builder;
declare
Dep_File : Ada.Text_IO.File_Type;
Result : Expect_Match;
- Status : Integer;
+
+ Status : Integer;
+ pragma Warnings (Off, Status);
begin
-- Create the dependency file
-- Objects plus the export table (.exp) file
Success : Boolean;
+ pragma Warnings (Off, Success);
begin
if not Quiet then
procedure Ada_Build_Reloc_DLL is
Success : Boolean;
+ pragma Warnings (Off, Success);
begin
if not Quiet then
procedure Build_Non_Reloc_DLL is
Success : Boolean;
+ pragma Warnings (Off, Success);
begin
if not Quiet then
procedure Ada_Build_Non_Reloc_DLL is
Success : Boolean;
+ pragma Warnings (Off, Success);
begin
if not Quiet then
-- Designates the full library path name. Either DLL_Name or
-- Archive_Name, depending on the library kind.
- Success : Boolean := False;
+ Success : Boolean;
+ pragma Warnings (Off, Success);
-- Used to call Delete_File
begin
Last : Natural;
Disregard : Boolean;
+ pragma Warnings (Off, Disregard);
DLL_Name : aliased constant String :=
Lib_Filename.all & "." & DLL_Ext;
Last : Natural;
Disregard : Boolean;
+ pragma Warnings (Off, Disregard);
begin
Open (Dir, ".");
----------
procedure Copy (File_Name : File_Name_Type) is
- Success : Boolean := False;
+ Success : Boolean;
+ pragma Warnings (Off, Success);
begin
Unit_Loop :
Newpath : System.Address) return Integer;
pragma Import (C, Symlink, "__gnat_symlink");
- Success : Boolean;
Version_Path : String_Access;
- Result : Integer;
- pragma Unreferenced (Result);
+ Success : Boolean;
+ Result : Integer;
+ pragma Unreferenced (Success, Result);
begin
if Is_Absolute_Path (Lib_Version) then
-- other GNAT tools. The comments indicate which options are used by which
-- programs (GNAT, GNATBIND, GNATLINK, GNATMAKE, GPRMAKE, etc).
+with Debug;
with Hostparm; use Hostparm;
with Types; use Types;
-- GNATMAKE, GNATCLEAN, GPRMAKE
-- GNATMAKE, GPRMAKE: set to True to skip bind and link steps (except when
-- Bind_Only is True).
- -- GNATCLEAN: set to True to only the files produced by the compiler are to
- -- be deleted, but not the library files or executable files.
+ -- GNATCLEAN: set to True to delete only the files produced by the compiler
+ -- but not the library files or the executable files.
Config_File : Boolean := True;
-- GNAT
-- then elaboration flag checks are to be generated in the binder
-- generated file.
+ Inspector_Mode : Boolean renames Debug.Debug_Flag_Dot_II;
+ -- GNAT
+ -- True if compiling in inspector mode (-gnatd.I switch).
+ -- Only relevant when VM_Target /= None. The compiler will attempt to
+ -- generate code even in case of unsupported construct, so that the byte
+ -- code can be used by static analysis tools.
+
Follow_Links : Boolean := False;
-- GNATMAKE
-- Set to True (-eL) to process the project files in trusted mode
Warn_On_Modified_Unread : Boolean := False;
-- GNAT
-- Set to True to generate warnings if a variable is assigned but is never
- -- read. The default is that this warning is suppressed. Also controls
- -- warnings about assignments whose value is never read.
+ -- read. The default is that this warning is suppressed.
+
+ Warn_On_Out_Parameter_Unread : Boolean := False;
+ -- GNAT
+ -- Set to True to generate warnings if a variable is modified by being
+ -- passed as to an IN OUT or OUT formal, but the resulting value is never
+ -- read. The default is that this warning is suppressed.
Warn_On_No_Value_Assigned : Boolean := True;
-- GNAT
Ch : Character;
Status : Boolean;
+ pragma Warnings (Off, Status);
-- For the call to Close
begin
-- Allocated text buffer
Status : Boolean;
+ pragma Warnings (Off, Status);
-- For the calls to Close
begin
Actual_Len : Integer;
Status : Boolean;
+ pragma Warnings (Off, Status);
-- For the call to Close
begin
procedure Write_With_Check (A : Address; N : Integer) is
Ignore : Boolean;
+ pragma Warnings (Off, Ignore);
begin
if N = Write (Output_FD, A, N) then
procedure Skip_Declaration (S : List_Id) is
Dummy_Done : Boolean;
-
+ pragma Warnings (Off, Dummy_Done);
begin
P_Declarative_Items (S, Dummy_Done, False);
end Skip_Declaration;
declare
Discard : Boolean;
+ pragma Warnings (Off, Discard);
begin
Delete_File
(Source_List_Path (1 .. Source_List_Last),
declare
Discard : Boolean;
+ pragma Warnings (Off, Discard);
begin
-- Delete the file if it already exists
procedure Delete_All_Temp_Files is
Dont_Care : Boolean;
+ pragma Warnings (Off, Dont_Care);
begin
if not Debug.Debug_Flag_N then
for Index in 1 .. Temp_Files.Last loop
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
function Compose (Fraction : T; Exponent : UI) return T is
Arg_Frac : T;
Arg_Exp : UI;
+ pragma Unreferenced (Arg_Exp);
begin
Decompose (Fraction, Arg_Frac, Arg_Exp);
return Scaling (Arg_Frac, Exponent);
function Exponent (X : T) return UI is
X_Frac : T;
X_Exp : UI;
+ pragma Unreferenced (X_Frac);
begin
Decompose (X, X_Frac, X_Exp);
return X_Exp;
function Fraction (X : T) return T is
X_Frac : T;
X_Exp : UI;
+ pragma Unreferenced (X_Exp);
begin
Decompose (X, X_Frac, X_Exp);
return X_Frac;
B : T;
Arg : T;
P : T;
- Arg_Frac : T;
P_Frac : T;
Sign_X : T;
IEEE_Rem : T;
K : UI;
P_Even : Boolean;
+ Arg_Frac : T;
+ pragma Unreferenced (Arg_Frac);
+
begin
if Y = 0.0 then
raise Constraint_Error;
return Boolean
is
V1, V2 : Natural;
+ pragma Unreferenced (V2);
begin
Form_Parameter (Form, Keyword, V1, V2);
------------
function GM_Day (Date : OS_Time) return Day_Type is
+ D : Day_Type;
+
+ pragma Warnings (Off);
Y : Year_Type;
Mo : Month_Type;
- D : Day_Type;
H : Hour_Type;
Mn : Minute_Type;
S : Second_Type;
+ pragma Warnings (On);
begin
GM_Split (Date, Y, Mo, D, H, Mn, S);
-------------
function GM_Hour (Date : OS_Time) return Hour_Type is
+ H : Hour_Type;
+
+ pragma Warnings (Off);
Y : Year_Type;
Mo : Month_Type;
D : Day_Type;
- H : Hour_Type;
Mn : Minute_Type;
S : Second_Type;
+ pragma Warnings (On);
begin
GM_Split (Date, Y, Mo, D, H, Mn, S);
---------------
function GM_Minute (Date : OS_Time) return Minute_Type is
+ Mn : Minute_Type;
+
+ pragma Warnings (Off);
Y : Year_Type;
Mo : Month_Type;
D : Day_Type;
H : Hour_Type;
- Mn : Minute_Type;
S : Second_Type;
+ pragma Warnings (On);
begin
GM_Split (Date, Y, Mo, D, H, Mn, S);
--------------
function GM_Month (Date : OS_Time) return Month_Type is
- Y : Year_Type;
Mo : Month_Type;
+
+ pragma Warnings (Off);
+ Y : Year_Type;
D : Day_Type;
H : Hour_Type;
Mn : Minute_Type;
S : Second_Type;
+ pragma Warnings (On);
begin
GM_Split (Date, Y, Mo, D, H, Mn, S);
---------------
function GM_Second (Date : OS_Time) return Second_Type is
+ S : Second_Type;
+
+ pragma Warnings (Off);
Y : Year_Type;
Mo : Month_Type;
D : Day_Type;
H : Hour_Type;
Mn : Minute_Type;
- S : Second_Type;
+ pragma Warnings (On);
begin
GM_Split (Date, Y, Mo, D, H, Mn, S);
function GM_Year (Date : OS_Time) return Year_Type is
Y : Year_Type;
+
+ pragma Warnings (Off);
Mo : Month_Type;
D : Day_Type;
H : Hour_Type;
Mn : Minute_Type;
S : Second_Type;
+ pragma Warnings (On);
begin
GM_Split (Date, Y, Mo, D, H, Mn, S);
(Program_Name : String;
Args : Argument_List) return Process_Id
is
- Junk : Integer;
Pid : Process_Id;
-
+ Junk : Integer;
+ pragma Warnings (Off, Junk);
begin
Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
return Pid;
(Program_Name : String;
Args : Argument_List) return Integer
is
- Junk : Process_Id;
Result : Integer;
+ Junk : Process_Id;
+ pragma Warnings (Off, Junk);
begin
Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
return Result;
return Class;
end Parse_Posix_Character_Class;
+ -- Local Declarations
+
+ Result : Pointer;
+
Expr_Flags : Expression_Flags;
- Result : Pointer;
+ pragma Unreferenced (Expr_Flags);
-- Start of processing for Compile
is
Size : Program_Size;
Dummy : Pattern_Matcher (0);
+ pragma Unreferenced (Dummy);
begin
Compile (Dummy, Expression, Size, Flags);
Flags : Regexp_Flags := No_Flags)
is
Size : Program_Size;
+ pragma Unreferenced (Size);
begin
Compile (Matcher, Expression, Size, Flags);
end Compile;
is
PM : Pattern_Matcher (Size);
Finalize_Size : Program_Size;
-
+ pragma Unreferenced (Finalize_Size);
begin
if Size = 0 then
Match (Compile (Expression), Data, Matches, Data_First, Data_Last);
Data_Last : Positive := Positive'Last) return Natural
is
PM : Pattern_Matcher (Size);
- Final_Size : Program_Size; -- unused
-
+ Final_Size : Program_Size;
+ pragma Unreferenced (Final_Size);
begin
if Size = 0 then
return Match (Compile (Expression), Data, Data_First, Data_Last);
is
Matches : Match_Array (0 .. 0);
PM : Pattern_Matcher (Size);
- Final_Size : Program_Size; -- unused
-
+ Final_Size : Program_Size;
+ pragma Unreferenced (Final_Size);
begin
if Size = 0 then
Match (Compile (Expression), Data, Matches, Data_First, Data_Last);
task body Timer_Server is
function Get_Next_Wakeup_Time return Duration;
-- Used to initialize Next_Wakeup_Time, but also to ensure that
- -- Make_Independent is called during the elaboration of this task
+ -- Make_Independent is called during the elaboration of this task.
--------------------------
-- Get_Next_Wakeup_Time --
return Duration'Last;
end Get_Next_Wakeup_Time;
+ -- Local Declarations
+
Next_Wakeup_Time : Duration := Get_Next_Wakeup_Time;
Timedout : Boolean;
Yielded : Boolean;
Dequeued : Delay_Block_Access;
Dequeued_Task : Task_Id;
+ pragma Unreferenced (Timedout, Yielded);
+
begin
Timer_Server_ID := STPO.Self;
Timer_Attention := False;
Now := STPO.Monotonic_Clock;
-
while Timer_Queue.Succ.Resume_Time <= Now loop
-- Dequeue the waiting task from the front of the queue
Check_Time : Duration := Monotonic_Clock;
Rel_Time : Duration;
Abs_Time : Duration;
- Result : Integer;
+
+ Result : Integer;
+ pragma Unreferenced (Result);
Local_Timedout : Boolean;
Check_Time : Duration := Monotonic_Clock;
Rel_Time : Duration;
Abs_Time : Duration;
- Timedout : Boolean;
- Result : Integer;
- pragma Warnings (Off, Integer);
+ Timedout : Boolean;
+ Result : Integer;
+ pragma Unreferenced (Timedout, Result);
begin
if Single_Lock then
pragma Unreferenced (Sig);
T : constant Task_Id := Self;
- Result : Interfaces.C.int;
Old_Set : aliased sigset_t;
+ Result : Interfaces.C.int;
+ pragma Warnings (Off, Result);
+
begin
-- It is not safe to raise an exception when using ZCX and the GCC
-- exception handling mechanism.
Old_Set : aliased sigset_t;
Result : Interfaces.C.int;
+ pragma Warnings (Off, Result);
begin
-- It is not safe to raise an exception when using ZCX and the GCC
-- Signal the condition variable when AST fires
procedure Timer_Sleep_AST (ID : Address) is
- Result : Interfaces.C.int;
+ Result : Interfaces.C.int;
+ pragma Warnings (Off, Result);
Self_ID : constant Task_Id := To_Task_Id (ID);
begin
Self_ID.Common.LL.AST_Pending := False;
pragma Unreferenced (signo);
Self_ID : constant Task_Id := Self;
- Result : int;
Old_Set : aliased sigset_t;
+ Result : int;
+ pragma Warnings (Off, Result);
+
begin
-- It is not safe to raise an exception when using ZCX and the GCC
-- exception handling mechanism.
procedure Stop_All_Tasks_Handler;
-- Stop all the tasks by traversing All_Tasks_Lists and calling
-- System.Task_Primitives.Operations.Stop_All_Task. This function
- -- can be used in a interrupt handler.
+ -- can be used in an interrupt handler.
procedure Stop_All_Tasks;
-- Stop all the tasks by traversing All_Tasks_Lists and calling
Uninterpreted_Data : System.Address)
is
Rendezvous_Successful : Boolean;
+ pragma Unreferenced (Rendezvous_Successful);
begin
-- If pragma Detect_Blocking is active then Program_Error must be
Self_Id : constant Task_Id := STPO.Self;
Level : ATC_Level;
Entry_Call : Entry_Call_Link;
- Yielded : Boolean;
+
+ Yielded : Boolean;
+ pragma Unreferenced (Yielded);
begin
-- If pragma Detect_Blocking is active then Program_Error must be
procedure Finalize_Global_Tasks is
Self_ID : constant Task_Id := STPO.Self;
+
Ignore : Boolean;
+ pragma Unreferenced (Ignore);
begin
if Self_ID.Deferral_Level = 0 then
(Entry_Call : Entry_Call_Link;
With_Abort : Boolean);
pragma Inline (Update_For_Queue_To_PO);
- -- Update the state of an existing entry call to reflect
- -- the fact that it is being enqueued, based on
- -- whether the current queuing action is with or without abort.
- -- Call this only while holding the PO's lock.
- -- It returns with the PO's lock still held.
+ -- Update the state of an existing entry call to reflect the fact that it
+ -- is being enqueued, based on whether the current queuing action is with
+ -- or without abort. Call this only while holding the PO's lock. It returns
+ -- with the PO's lock still held.
procedure Requeue_Call
(Self_Id : Task_Id;
-- Cancel_Protected_Entry_Call --
---------------------------------
- -- Compiler interface only. Do not call from within the RTS.
- -- This should have analogous effect to Cancel_Task_Entry_Call,
- -- setting the value of Block.Cancelled instead of returning
- -- the parameter value Cancelled.
+ -- Compiler interface only (do not call from within the RTS)
+
+ -- This should have analogous effect to Cancel_Task_Entry_Call, setting
+ -- the value of Block.Cancelled instead of returning the parameter value
+ -- Cancelled.
- -- The effect should be idempotent, since the call may already
- -- have been dequeued.
+ -- The effect should be idempotent, since the call may already have been
+ -- dequeued.
- -- source code:
+ -- Source code:
-- select r.e;
-- ...A...
-- ...B...
-- end select;
- -- expanded code:
+ -- Expanded code:
-- declare
-- X : protected_entry_index := 1;
-- B80b : communication_block;
-- communication_blockIP (B80b);
+
-- begin
-- begin
-- A79b : label
-- end if;
-- return;
-- end _clean;
+
-- begin
-- protected_entry_call (rTV!(r)._object'unchecked_access, X,
-- null_address, asynchronous_call, B80b, objectF => 0);
-- at end
-- _clean;
-- end A79b;
+
-- exception
-- when _abort_signal =>
-- abort_undefer.all;
-- null;
-- end;
+
-- if not cancelled (B80b) then
-- x := ...A...
-- end if;
-- Abort_Signal should be raised and ATC will take us to the at-end
-- handler, which will call _clean.
- -- If the entry call returns with the call already completed,
- -- we can skip this, and use the "if enqueued()" to go past
- -- the at-end handler, but we will still call _clean.
+ -- If the entry call returns with the call already completed, we can skip
+ -- this, and use the "if enqueued()" to go past the at-end handler, but we
+ -- will still call _clean.
- -- If the abortable part completes before the entry call is Done,
- -- it will call _clean.
+ -- If the abortable part completes before the entry call is Done, it will
+ -- call _clean.
-- If the entry call or the abortable part raises an exception,
-- we will still call _clean, but the value of Cancelled should not matter.
-- Whoever calls _clean first gets to decide whether the call
-- has been "cancelled".
- -- Enqueued should be true if there is any chance that the call
- -- is still on a queue. It seems to be safe to make it True if
- -- the call was Onqueue at some point before return from
- -- Protected_Entry_Call.
+ -- Enqueued should be true if there is any chance that the call is still on
+ -- a queue. It seems to be safe to make it True if the call was Onqueue at
+ -- some point before return from Protected_Entry_Call.
-- Cancelled should be true iff the abortable part completed
-- and succeeded in cancelling the entry call before it completed.
-- ?????
- -- The need for Enqueued is less obvious.
- -- The "if enqueued ()" tests are not necessary, since both
- -- Cancel_Protected_Entry_Call and Protected_Entry_Call must
- -- do the same test internally, with locking. The one that
- -- makes cancellation conditional may be a useful heuristic
- -- since at least 1/2 the time the call should be off-queue
- -- by that point. The other one seems totally useless, since
- -- Protected_Entry_Call must do the same check and then
- -- possibly wait for the call to be abortable, internally.
+ -- The need for Enqueued is less obvious. The "if enqueued ()" tests are
+ -- not necessary, since Cancel_Protected_Entry_Call/Protected_Entry_Call
+ -- must do the same test internally, with locking. The one that makes
+ -- cancellation conditional may be a useful heuristic since at least 1/2
+ -- the time the call should be off-queue by that point. The other one seems
+ -- totally useless, since Protected_Entry_Call must do the same check and
+ -- then possibly wait for the call to be abortable, internally.
-- We can check Call.State here without locking the caller's mutex,
-- since the call must be over after returning from Wait_For_Completion.
pragma Debug
(Debug.Trace (STPO.Self, "Exceptional_Complete_Entry_Body", 'P'));
- -- We must have abort deferred, since we are inside
- -- a protected operation.
+ -- We must have abort deferred, since we are inside a protected
+ -- operation.
if Entry_Call /= null then
- -- The call was not requeued.
+
+ -- The call was not requeued
Entry_Call.Exception_To_Raise := Ex;
if Ex /= Ada.Exceptions.Null_Id then
+
-- An exception was raised and abort was deferred, so adjust
-- before propagating, otherwise the task will stay with deferral
-- enabled for its remaining life.
-- Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or
-- PO_Service_Entries on return.
+
end if;
if Runtime_Traces then
if Barrier_Value then
- -- Not abortable while service is in progress.
+ -- Not abortable while service is in progress
if Entry_Call.State = Now_Abortable then
Entry_Call.State := Was_Abortable;
E := Protected_Entry_Index (Entry_Call.E);
- -- Not abortable while service is in progress.
+ -- Not abortable while service is in progress
if Entry_Call.State = Now_Abortable then
Entry_Call.State := Was_Abortable;
end if;
pragma Debug
- (Debug.Trace (Self_ID, "POSE: start entry body", 'P'));
- Object.Entry_Bodies (
- Object.Find_Body_Index (Object.Compiler_Info, E)).Action (
- Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);
+ (Debug.Trace (Self_ID, "POSE: start entry body", 'P'));
+
+ Object.Entry_Bodies
+ (Object.Find_Body_Index (Object.Compiler_Info, E)).Action
+ (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);
+
exception
when others =>
Queuing.Broadcast_Program_Error
function Protected_Count
(Object : Protection_Entries'Class;
- E : Protected_Entry_Index)
- return Natural
+ E : Protected_Entry_Index) return Natural
is
begin
return Queuing.Count_Waiting (Object.Entry_Queues (E));
-- Protected_Entry_Call --
--------------------------
- -- Compiler interface only. Do not call from within the RTS.
+ -- Compiler interface only (do not call from within the RTS)
-- select r.e;
-- ...A...
-- X : protected_entry_index := 1;
-- B85b : communication_block;
-- communication_blockIP (B85b);
+
-- begin
-- protected_entry_call (rTV!(r)._object'unchecked_access, X,
-- null_address, conditional_call, B85b, objectF => 0);
+
-- if cancelled (B85b) then
-- ...B...
-- else
if Entry_Call.State >= Done then
- -- Once State >= Done it will not change any more.
+ -- Once State >= Done it will not change any more
if Single_Lock then
STPO.Lock_RTS;
return;
else
- -- In this case we cannot conclude anything,
- -- since State can change concurrently.
+ -- In this case we cannot conclude anything, since State can change
+ -- concurrently.
+
null;
end if;
- -- Now for the general case.
+ -- Now for the general case
if Mode = Asynchronous_Call then
- -- Try to avoid an expensive call.
+ -- Try to avoid an expensive call
if not Initially_Abortable then
if Single_Lock then
STPO.Lock_RTS;
Entry_Calls.Wait_For_Completion (Entry_Call);
STPO.Unlock_RTS;
+
else
STPO.Write_Lock (Self_ID);
Entry_Calls.Wait_For_Completion (Entry_Call);
if Ceiling_Violation then
Object.Call_In_Progress := null;
- Queuing.Broadcast_Program_Error
- (Self_Id, Object, Entry_Call);
+ Queuing.Broadcast_Program_Error (Self_Id, Object, Entry_Call);
else
PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call);
else
-- Requeue is to same protected object
- -- ??? Try to compensate apparent failure of the
- -- scheduler on some OS (e.g VxWorks) to give higher
- -- priority tasks a chance to run (see CXD6002).
+ -- ??? Try to compensate apparent failure of the scheduler on some
+ -- OS (e.g VxWorks) to give higher priority tasks a chance to run
+ -- (see CXD6002).
STPO.Yield (False);
if Entry_Call.With_Abort
and then Entry_Call.Cancellation_Attempted
then
- -- If this is a requeue with abort and someone tried
- -- to cancel this call, cancel it at this point.
+ -- If this is a requeue with abort and someone tried to cancel
+ -- this call, cancel it at this point.
Entry_Call.State := Cancelled;
return;
if Single_Lock then
STPO.Unlock_RTS;
end if;
+
else
Queuing.Enqueue
(New_Object.Entry_Queues (E), Entry_Call);
-- Requeue_Protected_Entry --
-----------------------------
- -- Compiler interface only. Do not call from within the RTS.
+ -- Compiler interface only (do not call from within the RTS)
-- entry e when b is
-- begin
-- Requeue_Task_To_Protected_Entry --
-------------------------------------
- -- Compiler interface only.
+ -- Compiler interface only (do not call from within the RTS)
-- accept e1 do
-- ...A...
-- A79b : address;
-- L78b : label
+
-- begin
-- accept_call (1, A79b);
-- ...A...
-- goto L78b;
-- <<L78b>>
-- complete_rendezvous;
+
-- exception
-- when all others =>
-- exceptional_complete_rendezvous (get_gnat_exception);
-- Timed_Protected_Entry_Call --
--------------------------------
- -- Compiler interface only. Do not call from within the RTS.
+ -- Compiler interface only (do not call from within the RTS)
procedure Timed_Protected_Entry_Call
(Object : Protection_Entries_Access;
Self_Id : constant Task_Id := STPO.Self;
Entry_Call : Entry_Call_Link;
Ceiling_Violation : Boolean;
- Yielded : Boolean;
+
+ Yielded : Boolean;
+ pragma Unreferenced (Yielded);
begin
if Self_Id.ATC_Nesting_Level = ATC_Level'Last then
STPO.Write_Lock (Self_Id);
end if;
- -- Try to avoid waiting for completed or cancelled calls.
+ -- Try to avoid waiting for completed or cancelled calls
if Entry_Call.State >= Done then
Utilities.Exit_One_ATC_Level (Self_Id);
is
Self_Id : constant Task_Id := Entry_Call.Self;
Timedout : Boolean;
+
Yielded : Boolean;
+ pragma Unreferenced (Yielded);
use type Ada.Exceptions.Exception_Id;
-- Timed_Protected_Single_Entry_Call --
---------------------------------------
- -- Compiler interface only. Do not call from within the RTS.
+ -- Compiler interface only (do not call from within the RTS)
procedure Timed_Protected_Single_Entry_Call
(Object : Protection_Entry_Access;
Analyze_And_Resolve (Expression (N), Standard_String);
end if;
end if;
+
+ Kill_Current_Values (Last_Assignment_Only => True);
end Analyze_Raise_Statement;
-----------------------------
-- generate bogus warnings when an assignment is rewritten as
-- another assignment, and gets tied up with itself.
+ -- Note: we don't use Record_Last_Assignment here, because we
+ -- have lots of other stuff to do under control of this test.
+
if Warn_On_Modified_Unread
- and then Ekind (Ent) = E_Variable
+ and then Is_Assignable (Ent)
and then Comes_From_Source (N)
and then In_Extended_Main_Source_Unit (Ent)
then
Dont_Care : Boolean;
Others_Present : Boolean;
+ pragma Warnings (Off, Last_Choice);
+ pragma Warnings (Off, Dont_Care);
+ -- Don't care about assigned values
+
Statements_Analyzed : Boolean := False;
-- Set True if at least some statement sequences get analyzed.
-- If False on exit, means we had a serious error that prevented
-- a call to Number_Of_Choices to get the right number of entries.
Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N));
+ pragma Warnings (Off, Case_Table);
-- Start of processing for Analyze_Case_Statement
begin
Check_Unreachable_Code (N);
+ Kill_Current_Values (Last_Assignment_Only => True);
Analyze (Label);
Label_Ent := Entity (Label);
Hhi : Uint;
HOK : Boolean;
+ pragma Warnings (Off, Hlo);
+
begin
Determine_Range (L, LOK, Llo, Lhi);
Determine_Range (H, HOK, Hlo, Hhi);
E := FE;
while Present (E) and then E /= Id loop
- if Ekind (E) = E_Variable then
+ if Is_Assignable (E) then
Set_Never_Set_In_Source (E, False);
Set_Is_True_Constant (E, False);
Set_Current_Value (E, Empty);
-- entity requires special handling because it may be use-visible
-- but hides directly visible entities defined outside the instance.
+ function Is_Actual_Parameter return Boolean;
+ -- This function checks if the node N is an identifier that is an actual
+ -- parameter of a procedure call. If so it returns True, otherwise it
+ -- return False. The reason for this check is that at this stage we do
+ -- not know what procedure is being called if the procedure might be
+ -- overloaded, so it is premature to go setting referenced flags or
+ -- making calls to Generate_Reference. We will wait till Resolve_Actuals
+ -- for that processing
+
function Known_But_Invisible (E : Entity_Id) return Boolean;
-- This function determines whether the entity E (which is not
-- visible) can reasonably be considered to be known to the writer
end if;
end From_Actual_Package;
+ -------------------------
+ -- Is_Actual_Parameter --
+ -------------------------
+
+ function Is_Actual_Parameter return Boolean is
+ begin
+ return
+ Nkind (N) = N_Identifier
+ and then
+ (Nkind (Parent (N)) = N_Procedure_Call_Statement
+ or else
+ (Nkind (Parent (N)) = N_Parameter_Association
+ and then N = Explicit_Actual_Parameter (Parent (N))
+ and then Nkind (Parent (Parent (N))) =
+ N_Procedure_Call_Statement));
+ end Is_Actual_Parameter;
+
-------------------------
-- Known_But_Invisible --
-------------------------
-- If no homonyms were visible, the entity is unambiguous
if not Is_Overloaded (N) then
- Generate_Reference (E, N);
+ if not Is_Actual_Parameter then
+ Generate_Reference (E, N);
+ end if;
end if;
-- Case of non-overloadable entity, set the entity providing that
if Nkind (Parent (N)) = N_Label then
declare
R : constant Boolean := Referenced (E);
-
begin
- Generate_Reference (E, N);
- Set_Referenced (E, R);
+ if not Is_Actual_Parameter then
+ Generate_Reference (E, N);
+ Set_Referenced (E, R);
+ end if;
end;
-- Normal case, not a label: generate reference
-- determine whether this reference modifies the denoted object
-- (because implicit derefences cannot be identified prior to
-- full type resolution).
+ --
+ -- ??? The Is_Actual_Parameter routine takes care of one of these
+ -- cases but there are others probably
else
- Generate_Reference (E, N);
+ if not Is_Actual_Parameter then
+ Generate_Reference (E, N);
+ end if;
+
Check_Nested_Access (E);
end if;
when Pragma_Convention => Convention : declare
C : Convention_Id;
E : Entity_Id;
+ pragma Warnings (Off, C);
+ pragma Warnings (Off, E);
begin
Check_Arg_Order ((Name_Convention, Name_Entity));
Check_Ada_83_Warning;
C : Convention_Id;
Def_Id : Entity_Id;
+ pragma Warnings (Off, C);
+
begin
Check_Ada_83_Warning;
Check_Arg_Order
-- [, [Link_Name =>] static_string_EXPRESSION ]);
when Pragma_External => External : declare
- C : Convention_Id;
- Def_Id : Entity_Id;
+ Def_Id : Entity_Id;
+
+ C : Convention_Id;
+ pragma Warnings (Off, C);
+
begin
GNAT_Pragma;
Check_Arg_Order
-- initialization of individual components within the init proc itself.
-- Could be optimized away perhaps?
+ function Is_Definite_Access_Type (E : Entity_Id) return Boolean;
+ -- Determine whether E is an access type declared by an access
+ -- declaration, and not an (anonymous) allocator type.
+
function Is_Predefined_Op (Nam : Entity_Id) return Boolean;
-- Utility to check whether the name in the call is a predefined
-- operator, in which case the call is made into an operator node.
end if;
end Check_Parameterless_Call;
+ -----------------------------
+ -- Is_Definite_Access_Type --
+ -----------------------------
+
+ function Is_Definite_Access_Type (E : Entity_Id) return Boolean is
+ Btyp : constant Entity_Id := Base_Type (E);
+ begin
+ return Ekind (Btyp) = E_Access_Type
+ or else (Ekind (Btyp) = E_Access_Subprogram_Type
+ and then Comes_From_Source (Btyp));
+ end Is_Definite_Access_Type;
+
----------------------
-- Is_Predefined_Op --
----------------------
type Kind_Test is access function (E : Entity_Id) return Boolean;
- function Is_Definite_Access_Type (E : Entity_Id) return Boolean;
- -- Determine whether E is an access type declared by an access decla-
- -- ration, and not an (anonymous) allocator type.
-
function Operand_Type_In_Scope (S : Entity_Id) return Boolean;
-- If the operand is not universal, and the operator is given by a
-- expanded name, verify that the operand has an interpretation with
-- Find a type of the given class in the package Pack that contains
-- the operator.
- -----------------------------
- -- Is_Definite_Access_Type --
- -----------------------------
-
- function Is_Definite_Access_Type (E : Entity_Id) return Boolean is
- Btyp : constant Entity_Id := Base_Type (E);
- begin
- return Ekind (Btyp) = E_Access_Type
- or else (Ekind (Btyp) = E_Access_Subprogram_Type
- and then Comes_From_Source (Btyp));
- end Is_Definite_Access_Type;
-
---------------------------
-- Operand_Type_In_Scope --
---------------------------
A_Typ : Entity_Id;
F_Typ : Entity_Id;
Prev : Node_Id := Empty;
+ Orig_A : Node_Id;
procedure Check_Prefixed_Call;
-- If the original node is an overloaded call in prefix notation,
end if;
end if;
- if Ekind (F) /= E_In_Parameter
- and then not Is_OK_Variable_For_Out_Formal (A)
- then
- Error_Msg_NE ("actual for& must be a variable", A, F);
+ -- For IN parameter, this is where we generate a reference after
+ -- resolution is complete.
+
+ if Ekind (F) = E_In_Parameter then
+ Orig_A := Original_Node (A);
+
+ if Is_Entity_Name (Orig_A)
+ and then Present (Entity (Orig_A))
+ then
+ Generate_Reference (Entity (Orig_A), Orig_A);
+ end if;
+
+ -- Case of OUT or IN OUT parameter
+
+ else
+ -- Validate the form of the actual. Note that the call to
+ -- Is_OK_Variable_For_Out_Formal generates the required
+ -- reference in this case.
+
+ if not Is_OK_Variable_For_Out_Formal (A) then
+ Error_Msg_NE ("actual for& must be a variable", A, F);
+ end if;
+
+ -- For an Out parameter, check for useless assignment. Note
+ -- that we can't set Last_Assignment this early, because we
+ -- may kill current values in Resolve_Call, and that call
+ -- would clobber the Last_Assignment field.
+
+ if Ekind (F) = E_Out_Parameter then
+ if Warn_On_Out_Parameter_Unread
+ and then Is_Entity_Name (A)
+ and then Present (Entity (A))
+ then
+ Warn_On_Useless_Assignment (Entity (A), Sloc (A));
+ end if;
+ end if;
+
+ -- What's the following about???
if Is_Entity_Name (A) then
Kill_Checks (Entity (A));
Kill_Current_Values;
end if;
+ -- If we are warning about unread out parameters, this is the place to
+ -- set Last_Assignment for out parameters. We have to do this after the
+ -- above call to Kill_Current_Values (since that call clears the
+ -- Last_Assignment field of all local variables).
+
+ if Warn_On_Out_Parameter_Unread
+ and then Comes_From_Source (N)
+ and then In_Extended_Main_Source_Unit (N)
+ then
+ declare
+ F : Entity_Id;
+ A : Node_Id;
+
+ begin
+ F := First_Formal (Nam);
+ A := First_Actual (N);
+ while Present (F) and then Present (A) loop
+ if Ekind (F) = E_Out_Parameter
+ and then Is_Entity_Name (A)
+ and then Present (Entity (A))
+ and then Safe_To_Capture_Value (N, Entity (A))
+ then
+ Set_Last_Assignment (Entity (A), A);
+ end if;
+
+ Next_Formal (F);
+ Next_Actual (A);
+ end loop;
+ end;
+ end if;
+
-- If the subprogram is a primitive operation, check whether or not
-- it is a correct dispatching call.
Check_Intrinsic_Call (N);
end if;
+ -- All done, evaluate call and deal with elaboration issues
+
Eval_Call (N);
Check_Elab_Call (N);
end Resolve_Call;
and then Is_Overloaded (Name (N))
then
declare
- I : Interp_Index;
It : Interp;
+
+ Itn : Interp_Index;
+ pragma Warnings (Off, Itn);
+
begin
- Get_First_Interp (Name (N), I, It);
+ Get_First_Interp (Name (N), Itn, It);
Add_Entry (It.Nam, Etype (N));
end;
if Dynamic_Scope = Standard_Standard then
return Empty;
+ elsif Dynamic_Scope = Empty then
+ return Empty;
+
elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
end if;
end Explain_Limited_Type;
+ ----------------------
+ -- Find_Actual_Mode --
+ ----------------------
+
+ procedure Find_Actual_Mode
+ (N : Node_Id;
+ Kind : out Entity_Kind;
+ Call : out Node_Id)
+ is
+ Parnt : constant Node_Id := Parent (N);
+ Formal : Entity_Id;
+ Actual : Node_Id;
+
+ begin
+ if (Nkind (Parnt) = N_Indexed_Component
+ or else
+ Nkind (Parnt) = N_Selected_Component)
+ and then N = Prefix (Parnt)
+ then
+ Find_Actual_Mode (Parnt, Kind, Call);
+ return;
+
+ elsif Nkind (Parnt) = N_Parameter_Association
+ and then N = Explicit_Actual_Parameter (Parnt)
+ then
+ Call := Parent (Parnt);
+
+ elsif Nkind (Parnt) = N_Procedure_Call_Statement then
+ Call := Parnt;
+
+ else
+ Kind := E_Void;
+ Call := Empty;
+ return;
+ end if;
+
+ -- If we have a call to a subprogram look for the parametere
+
+ if Is_Entity_Name (Name (Call))
+ and then Present (Entity (Name (Call)))
+ and then Is_Overloadable (Entity (Name (Call)))
+ then
+ -- Fall here if we are definitely a parameter
+
+ Actual := First_Actual (Call);
+ Formal := First_Formal (Entity (Name (Call)));
+ while Present (Formal) and then Present (Actual) loop
+ if Actual = N then
+ Kind := Ekind (Formal);
+ return;
+ else
+ Actual := Next_Actual (Actual);
+ Formal := Next_Formal (Formal);
+ end if;
+ end loop;
+ end if;
+
+ -- Fall through here if we did not find matching actual
+
+ Kind := E_Void;
+ Call := Empty;
+ end Find_Actual_Mode;
+
-------------------------------------
-- Find_Corresponding_Discriminant --
-------------------------------------
Comp_List : Node_Id;
Discr : Entity_Id;
Discr_Val : Node_Id;
+
Report_Errors : Boolean;
+ pragma Warnings (Off, Report_Errors);
begin
if Serious_Errors_Detected > 0 then
-- Kill_Current_Values --
-------------------------
- procedure Kill_Current_Values (Ent : Entity_Id) is
+ procedure Kill_Current_Values
+ (Ent : Entity_Id;
+ Last_Assignment_Only : Boolean := False)
+ is
begin
- if Is_Object (Ent) then
+ if Is_Assignable (Ent) then
+ Set_Last_Assignment (Ent, Empty);
+ end if;
+
+ if not Last_Assignment_Only and then Is_Object (Ent) then
Kill_Checks (Ent);
Set_Current_Value (Ent, Empty);
- if Ekind (Ent) = E_Variable then
- Set_Last_Assignment (Ent, Empty);
- end if;
-
if not Can_Never_Be_Null (Ent) then
Set_Is_Known_Non_Null (Ent, False);
end if;
end if;
end Kill_Current_Values;
- procedure Kill_Current_Values is
+ procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is
S : Entity_Id;
procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
begin
Ent := E;
while Present (Ent) loop
- Kill_Current_Values (Ent);
+ Kill_Current_Values (Ent, Last_Assignment_Only);
Next_Entity (Ent);
end loop;
end Kill_Current_Values_For_Entity_Chain;
begin
-- Kill all saved checks, a special case of killing saved values
- Kill_All_Checks;
+ if not Last_Assignment_Only then
+ Kill_All_Checks;
+ end if;
-- Loop through relevant scopes, which includes the current scope and
-- any parent scopes if the current scope is a block or a package.
and then Nkind (Expression (Parent (Entity (P))))
= N_Reference
then
- -- Case of a reference to a value on which
- -- side effects have been removed.
+ -- Case of a reference to a value on which side effects have
+ -- been removed.
Exp := Prefix (Expression (Parent (Entity (P))));
goto Continue;
-- adds additional continuation lines to the message explaining
-- why type T is limited. Messages are placed at node N.
+ procedure Find_Actual_Mode
+ (N : Node_Id;
+ Kind : out Entity_Kind;
+ Call : out Node_Id);
+ -- Determines if the node N is an actual parameter of a procedure call. If
+ -- so, then Kind is E_In_Parameter, E_Out_Parameter, E_In_Out_Parameter on
+ -- return as appropriate, and Call is set to the node for the corresponding
+ -- call. If the node N is not an actual parameter, then Kind = E_Void, Call
+ -- = Empty. Note that this only applies to procedure calls, for function
+ -- calls, the result is always E_Void.
+
function Find_Corresponding_Discriminant
(Id : Node_Id;
Typ : Entity_Id) return Entity_Id;
-- here is for something actually declared as volatile, not for an object
-- that gets treated as volatile (see Einfo.Treat_As_Volatile).
- procedure Kill_Current_Values;
+ procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False);
-- This procedure is called to clear all constant indications from all
-- entities in the current scope and in any parent scopes if the current
-- scope is a block or a package (and that recursion continues to the top
-- Kill_All_Checks, since this is a special case of needing to forget saved
-- values. This procedure also clears Is_Known_Non_Null flags in variables,
-- constants or parameters since these are also not known to be valid.
-
- procedure Kill_Current_Values (Ent : Entity_Id);
+ --
+ -- The Last_Assignment_Only flag is set True to clear only Last_Assignment
+ -- fields and leave other fields unchanged. This is used when we encounter
+ -- an unconditional flow of control change (return, goto, raise). In such
+ -- cases we don't need to clear the current values, since it may be that
+ -- the flow of control change occurs in a conditional context, and if it
+ -- is not taken, then it is just fine to keep the current values. But the
+ -- Last_Assignment field is different, if we have a sequence assign-to-v,
+ -- conditional-return, assign-to-v, we do not want to complain that the
+ -- second assignment clobbers the first.
+
+ procedure Kill_Current_Values
+ (Ent : Entity_Id;
+ Last_Assignment_Only : Boolean := False);
-- This performs the same processing as described above for the form with
-- no argument, but for the specific entity given. The call has no effect
- -- if the entity Ent is not for an object.
+ -- if the entity Ent is not for an object. Again, Last_Assignment_Only is
+ -- set if you want to clear only the Last_Assignment field (see above).
procedure Kill_Size_Check_Code (E : Entity_Id);
-- Called when an address clause or pragma Import is applied to an
or else
(Check_Unreferenced_Formals and then Is_Formal (E1))
or else
- (Warn_On_Modified_Unread
- and then Referenced_As_LHS_Check_Spec (E1)))
+ ((Warn_On_Modified_Unread
+ or Warn_On_Out_Parameter_Unread)
+ and then Referenced_As_LHS_Check_Spec (E1)))
-- Labels, and enumeration literals, and exceptions. The
-- warnings are also placed on local packages that cannot be
when 'C' =>
Warn_On_Unrepped_Components := False;
+ when 'o' =>
+ Warn_On_Out_Parameter_Unread := True;
+
+ when 'O' =>
+ Warn_On_Out_Parameter_Unread := False;
+
when 'r' =>
Warn_On_Object_Renames_Function := True;
Warn_On_No_Value_Assigned := False;
Warn_On_Non_Local_Exception := False;
Warn_On_Obsolescent_Feature := False;
+ Warn_On_Out_Parameter_Unread := False;
Warn_On_Questionable_Missing_Parens := False;
Warn_On_Redundant_Constructs := False;
Warn_On_Object_Renames_Function := False;
Body_E : Entity_Id := Empty)
is
E : Entity_Id := Spec_E;
+
begin
if not Referenced_Check_Spec (E) and then not Warnings_Off (E) then
case Ekind (E) is
and then No (Address_Clause (E))
and then not Is_Volatile (E)
then
- if Warn_On_Modified_Unread
+ if (Warn_On_Modified_Unread or Warn_On_Out_Parameter_Unread)
and then not Is_Imported (E)
and then not Is_Return_Object (E)
-- last assignment field set, with warnings enabled, and which is
-- not imported or exported.
- if Ekind (Ent) = E_Variable
+ if Is_Assignable (Ent)
and then not Is_Return_Object (Ent)
and then Present (Last_Assignment (Ent))
and then not Warnings_Off (Ent)
elsif Nkind (P) = N_Subprogram_Body
or else Nkind (P) = N_Package_Body
then
+ -- Case of assigned value never referenced
+
if Loc = No_Location then
- Error_Msg_NE
- ("?useless assignment to&, value never referenced!",
- Last_Assignment (Ent), Ent);
+
+ -- Don't give this for OUT and IN OUT formals, since
+ -- clearly caller may reference the assigned value.
+
+ if Ekind (Ent) = E_Variable then
+ Error_Msg_NE
+ ("?useless assignment to&, value never referenced!",
+ Last_Assignment (Ent), Ent);
+ end if;
+
+ -- Case of assigned value overwritten
+
else
Error_Msg_Sloc := Loc;
Error_Msg_NE
Last_Assignment (Ent), Ent);
end if;
+ -- Clear last assignment indication and we are done
+
Set_Last_Assignment (Ent, Empty);
return;
Loc : Source_Ptr := No_Location);
-- Called to check if we have a case of a useless assignment to the given
-- entity Ent, as indicated by a non-empty Last_Assignment field. This call
- -- should only be made if Warn_On_Modified_Unread is True, and if Ent is in
- -- the extended main source unit. Loc is No_Location for the end of block
- -- call (warning msg says value unreferenced), or the it is the location of
- -- an overwriting assignment (warning msg points to this assignment).
+ -- should only be made if at least one of the flags Warn_On_Modified_Unread
+ -- or Warn_On_Out_Parameter_Unread is True, and if Ent is in the extended
+ -- main source unit. Loc is No_Location for the end of block call (warning
+ -- message says value unreferenced), or the it is the location of an
+ -- overwriting assignment (warning message points to this assignment).
procedure Warn_On_Useless_Assignments (E : Entity_Id);
pragma Inline (Warn_On_Useless_Assignments);
-- N_Allocator
-- Sloc points to NEW
-- Expression (Node3) subtype indication or qualified expression
- -- Null_Exclusion_Present (Flag11)
-- Storage_Pool (Node1-Sem)
-- Procedure_To_Call (Node2-Sem)
-- Coextensions (Elist4-Sem)
+ -- Null_Exclusion_Present (Flag11)
-- No_Initialization (Flag13-Sem)
-- Is_Static_Coextension (Flag14-Sem)
-- Do_Storage_Check (Flag17-Sem)
S : Source_File_Record renames Source_File.Table (Dfile);
Src : Source_Buffer_Ptr;
+ pragma Warnings (Off, S);
+
begin
Trim_Lines_Table (Dfile);
Close_Debug_File;
procedure Set_Style_Check_Options (Options : String) is
OK : Boolean;
EC : Natural;
+ pragma Warnings (Off, EC);
begin
Set_Style_Check_Options (Options, OK, EC);
pragma Assert (OK);
begin
if Result (Result'First) = ' ' then
return Result (Result'First + 1 .. Result'Last);
-
else
return Result;
end if;
EOF : constant Character := ASCII.SUB;
-- The character SUB (16#1A#) is used in DOS and other systems derived
- -- from DOS (OS/2, NT etc) to signal the end of a text file. Internally
+ -- from DOS (XP, NT etc) to signal the end of a text file. Internally
-- all source files are ended by an EOF character, even on Unix systems.
-- An EOF character acts as the end of file only as the last character
-- of a source buffer, in any other position, it is treated as a blank
-gnatwn ^ /WARNINGS=NORMAL
-gnatwo ^ /WARNINGS=OVERLAYS
-gnatwO ^ /WARNINGS=NOOVERLAYS
+-gnatw.o ^ /WARNINGS=OUT_PARAM_UNREF
+-gnatw.O ^ /WARNINGS=NOOUT_PARAM_UNREF
-gnatwp ^ /WARNINGS=INEFFECTIVE_INLINE
-gnatwP ^ /WARNINGS=NOINEFFECTIVE_INLINE
-gnatwq ^ /WARNINGS=MISSING_PARENS
function UI_Div (Left, Right : Uint) return Uint is
Quotient : Uint;
Remainder : Uint;
+ pragma Warnings (Off, Remainder);
begin
UI_Div_Rem
(Left, Right,
declare
Remainder_V : UI_Vector (1 .. R_Length);
Discard_Int : Int;
+ pragma Warnings (Off, Discard_Int);
begin
UI_Div_Vector
(Dividend (Dividend'Last - R_Length + 1 .. Dividend'Last),
end if;
declare
- Quotient, Remainder : Uint;
+ Remainder : Uint;
+ Quotient : Uint;
+ pragma Warnings (Off, Quotient);
begin
UI_Div_Rem
(Left, Right, Quotient, Remainder,
Write_Switch_Char ("wxx");
Write_Line ("Enable selected warning modes, xx = list of parameters:");
- Write_Line (" a turn on all optional warnings (except d,h,l,t)");
+ Write_Line (" a turn on all optional warnings (except d h l .o)");
Write_Line (" A turn off all optional warnings");
Write_Line (" b turn on warnings for bad fixed value " &
"(not multiple of small)");
Write_Line (" n* normal warning mode (cancels -gnatws/-gnatwe)");
Write_Line (" o* turn on warnings for address clause overlay");
Write_Line (" O turn off warnings for address clause overlay");
+ Write_Line (" .o turn on warnings for out parameter assigned " &
+ "but not read");
+ Write_Line (" .O* turn off warnings for out parameter assigned " &
+ "but not read");
Write_Line (" p turn on warnings for ineffective pragma " &
"Inline in frontend");
Write_Line (" P* turn off warnings for ineffective pragma " &
procedure Set_Validity_Check_Options (Options : String) is
OK : Boolean;
EC : Natural;
-
+ pragma Warnings (Off, OK);
+ pragma Warnings (Off, EC);
begin
Set_Validity_Check_Options (Options, OK, EC);
end Set_Validity_Check_Options;
"!-gnatws,!-gnatwe " &
"ALL " &
"-gnatwa " &
+ "OPTIONAL " &
+ "-gnatwa " &
+ "NOOPTIONAL " &
+ "-gnatwA " &
"NOALL " &
"-gnatwA " &
"ALL_GCC " &
"-gnatw.c " &
"NOMISSING_COMPONENT_CLAUSES " &
"-gnatw.C " &
- "CONSTANT_VARIABLES " &
- "-gnatwk " &
- "NOCONSTANT_VARIABLES " &
- "-gnatwK " &
"IMPLICIT_DEREFERENCE " &
"-gnatwd " &
"NO_IMPLICIT_DEREFERENCE " &
"-gnatwD " &
- "ELABORATION " &
- "-gnatwl " &
- "NOELABORATION " &
- "-gnatwL " &
"ERRORS " &
"-gnatwe " &
+ "UNREFERENCED_FORMALS " &
+ "-gnatwf " &
+ "NOUNREFERENCED_FORMALS " &
+ "-gnatwF " &
+ "UNRECOGNIZED_PRAGMAS " &
+ "-gnatwg " &
+ "NOUNRECOGNIZED_PRAGMAS " &
+ "-gnatwG " &
"HIDING " &
"-gnatwh " &
"NOHIDING " &
"-gnatwi " &
"NOIMPLEMENTATION " &
"-gnatwI " &
- "INEFFECTIVE_INLINE " &
- "-gnatwp " &
- "NOINEFFECTIVE_INLINE " &
- "-gnatwP " &
- "MISSING_PARENS " &
- "-gnatwq " &
- "NOMISSING_PARENS " &
- "-gnatwQ " &
+ "OBSOLESCENT " &
+ "-gnatwj " &
+ "NOOBSOLESCENT " &
+ "-gnatwJ " &
+ "CONSTANT_VARIABLES " &
+ "-gnatwk " &
+ "NOCONSTANT_VARIABLES " &
+ "-gnatwK " &
+ "ELABORATION " &
+ "-gnatwl " &
+ "NOELABORATION " &
+ "-gnatwL " &
"MODIFIED_UNREF " &
"-gnatwm " &
"NOMODIFIED_UNREF " &
"-gnatwM " &
"NORMAL " &
"-gnatwn " &
- "OBSOLESCENT " &
- "-gnatwj " &
- "NOOBSOLESCENT " &
- "-gnatwJ " &
- "OPTIONAL " &
- "-gnatwa " &
- "NOOPTIONAL " &
- "-gnatwA " &
"OVERLAYS " &
"-gnatwo " &
"NOOVERLAYS " &
"-gnatwO " &
+ "OUT_PARAM_UNREF " &
+ "-gnatw.o " &
+ "NOOUT_PARAM_UNREF " &
+ "-gnatw.O " &
+ "INEFFECTIVE_INLINE " &
+ "-gnatwp " &
+ "NOINEFFECTIVE_INLINE " &
+ "-gnatwP " &
+ "MISSING_PARENS " &
+ "-gnatwq " &
+ "NOMISSING_PARENS " &
+ "-gnatwQ " &
"REDUNDANT " &
"-gnatwr " &
"NOREDUNDANT " &
"-gnatwR " &
+ "OBJECT_RENAMES " &
+ "-gnatw.r " &
+ "NOOBJECT_RENAMES " &
+ "-gnatw.R " &
"SUPPRESS " &
"-gnatws " &
"DELETED_CODE " &
"-gnatwT " &
"UNINITIALIZED " &
"-Wuninitialized " &
- "UNREFERENCED_FORMALS " &
- "-gnatwf " &
- "NOUNREFERENCED_FORMALS " &
- "-gnatwF " &
- "UNRECOGNIZED_PRAGMAS " &
- "-gnatwg " &
- "NOUNRECOGNIZED_PRAGMAS " &
- "-gnatwG " &
"UNUSED " &
"-gnatwu " &
"NOUNUSED " &
-- NOOBSOLESCENT Disables warnings on use of obsolescent
-- features.
--
- -- OPTIONAL Activate all optional warning messages.
- -- See other options under this qualifier
- -- for details on optional warning messages
- -- that can be individually controlled. The
- -- one exception is that /WARNINGS=OPTIONAL
- -- doesn't activate warnings for hiding
- -- variables (/WARNINGS=HIDING), so if this
- -- warning is required it must be explicitly
- -- set.
- --
- -- NOOPTIONAL Suppress all optional warning messages.
- -- See other options under this qualifier
- -- for details on optional warning messages
- -- that can be individually controlled.
+ -- OBJECT_RENAME Activate warnings for non limited objects
+ -- renaming parameterless functions.
+ --
+ -- NOOBJECT_RENAME Suppress warnings for non limited objects
+ -- renaming parameterless functions.
+ --
+ -- OPTIONAL Equivalent to ALL.
+ --
+ -- NOOPTIONAL Equivalent to NOALL.
--
-- OVERLAYS Activate warnings for possibly unintended
-- initialization effects of defining address
projects / gcc.git / commitdiff