diff options
Diffstat (limited to 'gcc')
93 files changed, 1055 insertions, 415 deletions
diff --git a/gcc/ada/a-calari.adb b/gcc/ada/a-calari.adb index bf1e103dedf..198f3d5cd11 100644 --- a/gcc/ada/a-calari.adb +++ b/gcc/ada/a-calari.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -70,6 +70,9 @@ package body Ada.Calendar.Arithmetic is 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); diff --git a/gcc/ada/a-calend-vms.adb b/gcc/ada/a-calend-vms.adb index bcfc3dd49bf..fb5ac13cfe8 100644 --- a/gcc/ada/a-calend-vms.adb +++ b/gcc/ada/a-calend-vms.adb @@ -37,6 +37,8 @@ with System.Aux_DEC; use System.Aux_DEC; with Ada.Unchecked_Conversion; +pragma Warnings (Off); -- temp till we fix out param warnings ??? + package body Ada.Calendar is -------------------------- diff --git a/gcc/ada/a-calend.adb b/gcc/ada/a-calend.adb index eb77eac37b2..dfe97ac277d 100644 --- a/gcc/ada/a-calend.adb +++ b/gcc/ada/a-calend.adb @@ -467,10 +467,11 @@ 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; @@ -508,6 +509,7 @@ package body Ada.Calendar is M : Month_Number; D : Day_Number; S : Day_Duration; + pragma Unreferenced (Y, D, S); begin Split (Date, Y, M, D, S); return M; @@ -522,6 +524,7 @@ package body Ada.Calendar is M : Month_Number; D : Day_Number; S : Day_Duration; + pragma Unreferenced (Y, M, D); begin Split (Date, Y, M, D, S); return S; @@ -544,6 +547,8 @@ package body Ada.Calendar is 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. @@ -631,6 +636,7 @@ package body Ada.Calendar is M : Month_Number; D : Day_Number; S : Day_Duration; + pragma Unreferenced (M, D, S); begin Split (Date, Y, M, D, S); return Y; @@ -822,6 +828,8 @@ package body Ada.Calendar is Su : Duration; Le : Boolean; + pragma Unreferenced (Ds, H, Mi, Se, Su, Le); + Day_Count : Long_Integer; Res_Dur : Time_Dur; Res_N : Time_Rep; diff --git a/gcc/ada/a-calfor.adb b/gcc/ada/a-calfor.adb index d16f18730ba..9804e220828 100644 --- a/gcc/ada/a-calfor.adb +++ b/gcc/ada/a-calfor.adb @@ -34,6 +34,8 @@ 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 -------------------------- @@ -93,6 +95,8 @@ 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; @@ -124,6 +128,8 @@ package body Ada.Calendar.Formatting is 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; @@ -345,6 +351,9 @@ package body Ada.Calendar.Formatting is 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; @@ -366,6 +375,9 @@ package body Ada.Calendar.Formatting is 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; @@ -384,6 +396,9 @@ package body Ada.Calendar.Formatting is 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; @@ -413,7 +428,7 @@ package body Ada.Calendar.Formatting is return Day_Duration (Hour * 3_600) + Day_Duration (Minute * 60) + Day_Duration (Second) + - Sub_Second; + Sub_Second; end Seconds_Of; ----------- @@ -613,6 +628,9 @@ package body Ada.Calendar.Formatting is 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; @@ -923,6 +941,8 @@ package body Ada.Calendar.Formatting is 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; diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb index 611bfb09b5d..68222ce2d49 100644 --- a/gcc/ada/a-cdlili.adb +++ b/gcc/ada/a-cdlili.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -175,7 +175,9 @@ package body Ada.Containers.Doubly_Linked_Lists is Container.Last := null; Container.Length := 0; + pragma Warnings (Off); Free (X); + pragma Warnings (On); end Clear; -------------- @@ -491,6 +493,7 @@ package body Ada.Containers.Doubly_Linked_Lists is 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); @@ -664,6 +667,7 @@ package body Ada.Containers.Doubly_Linked_Lists is Count : Count_Type := 1) is Position : Cursor; + pragma Unreferenced (Position); begin Insert (Container, Before, New_Item, Position, Count); end Insert; diff --git a/gcc/ada/a-chtgop.adb b/gcc/ada/a-chtgop.adb index 94a646e3250..dd97c2ebb05 100644 --- a/gcc/ada/a-chtgop.adb +++ b/gcc/ada/a-chtgop.adb @@ -583,6 +583,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is declare X : Buckets_Access := HT.Buckets; + pragma Warnings (Off, X); begin HT.Buckets := New_Buckets (Length => NN); Free_Buckets (X); @@ -628,6 +629,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is 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; diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb index cf9cdcfc39d..4bd0db77b03 100644 --- a/gcc/ada/a-cidlli.adb +++ b/gcc/ada/a-cidlli.adb @@ -7,7 +7,7 @@ -- -- -- 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- -- @@ -162,6 +162,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is procedure Clear (Container : in out List) is X : Node_Access; + pragma Warnings (Off, X); begin if Container.Length = 0 then @@ -539,6 +540,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is 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); @@ -735,6 +737,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Count : Count_Type := 1) is Position : Cursor; + pragma Unreferenced (Position); begin Insert (Container, Before, New_Item, Position, Count); end Insert; diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index 2a3e1b58c1d..45dfe984d51 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -568,6 +568,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is New_Item : Element_Type) is Position : Cursor; + pragma Unreferenced (Position); + Inserted : Boolean; begin @@ -965,9 +967,13 @@ package body Ada.Containers.Indefinite_Hashed_Maps is 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; diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb index 8de25a84efc..235f6e36806 100644 --- a/gcc/ada/a-cihase.adb +++ b/gcc/ada/a-cihase.adb @@ -703,6 +703,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is New_Item : Element_Type) is Position : Cursor; + pragma Unreferenced (Position); + Inserted : Boolean; begin @@ -1138,6 +1140,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Element_Keys.Find (Container.HT, New_Item); X : Element_Access; + pragma Warnings (Off, X); begin if Node = null then @@ -1471,9 +1474,11 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ------------ 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); @@ -1523,6 +1528,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Tgt_Node : Node_Access; Success : Boolean; + pragma Unreferenced (Tgt_Node, Success); -- Start of processing for Process diff --git a/gcc/ada/a-ciorma.adb b/gcc/ada/a-ciorma.adb index 794fc44771b..4372ad404f0 100644 --- a/gcc/ada/a-ciorma.adb +++ b/gcc/ada/a-ciorma.adb @@ -7,7 +7,7 @@ -- -- -- 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- -- @@ -707,8 +707,9 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Key : Key_Type; New_Item : Element_Type) is - Position : Cursor; + pragma Unreferenced (Position); + Inserted : Boolean; begin @@ -1301,10 +1302,13 @@ package body Ada.Containers.Indefinite_Ordered_Maps is 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; diff --git a/gcc/ada/a-ciormu.adb b/gcc/ada/a-ciormu.adb index f097fdc833b..93e1c841efa 100644 --- a/gcc/ada/a-ciormu.adb +++ b/gcc/ada/a-ciormu.adb @@ -7,7 +7,7 @@ -- -- -- 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- -- @@ -1052,6 +1052,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is procedure Insert (Container : in out Set; New_Item : Element_Type) is Position : Cursor; + pragma Unreferenced (Position); begin Insert (Container, New_Item, Position); end Insert; @@ -1794,9 +1795,9 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is ------------ 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); diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index 51a882a93ab..e12abaca00b 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -7,7 +7,7 @@ -- -- -- 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- -- @@ -964,7 +964,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is 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); @@ -1032,7 +1035,8 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Src_Node : Node_Access; Dst_Node : out Node_Access) is - Success : Boolean; + Success : Boolean; + pragma Unreferenced (Success); function New_Node return Node_Access; @@ -1434,6 +1438,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Element_Keys.Find (Container.Tree, New_Item); X : Element_Access; + pragma Warnings (Off, X); begin if Node = null then @@ -1687,9 +1692,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ------------ 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); diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index d4b8cff88f3..d8f7ff95d77 100644 --- a/gcc/ada/a-cohama.adb +++ b/gcc/ada/a-cohama.adb @@ -520,6 +520,8 @@ package body Ada.Containers.Hashed_Maps is New_Item : Element_Type) is Position : Cursor; + pragma Unreferenced (Position); + Inserted : Boolean; begin @@ -850,6 +852,7 @@ package body Ada.Containers.Hashed_Maps is declare K : Key_Type renames Position.Node.Key; E : Element_Type renames Position.Node.Element; + pragma Unreferenced (E); begin Process (K, E); exception diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb index e0db89d5b0c..a3de9502734 100644 --- a/gcc/ada/a-cohase.adb +++ b/gcc/ada/a-cohase.adb @@ -645,6 +645,8 @@ package body Ada.Containers.Hashed_Sets is New_Item : Element_Type) is Position : Cursor; + pragma Unreferenced (Position); + Inserted : Boolean; begin @@ -1329,9 +1331,11 @@ package body Ada.Containers.Hashed_Sets is ------------ 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); @@ -1375,6 +1379,7 @@ package body Ada.Containers.Hashed_Sets is Tgt_Node : Node_Access; Success : Boolean; + pragma Unreferenced (Tgt_Node, Success); -- Start of processing for Process diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index 8233a4e9b90..c97f4eb2406 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -620,6 +620,8 @@ package body Ada.Containers.Indefinite_Vectors is 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"; diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index 64c2a16aa6e..5cbfa0915af 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -425,6 +425,8 @@ package body Ada.Containers.Vectors is 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"; diff --git a/gcc/ada/a-coorma.adb b/gcc/ada/a-coorma.adb index f6823d4f7b2..01074d58512 100644 --- a/gcc/ada/a-coorma.adb +++ b/gcc/ada/a-coorma.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -595,6 +595,8 @@ package body Ada.Containers.Ordered_Maps is New_Item : Element_Type) is Position : Cursor; + pragma Unreferenced (Position); + Inserted : Boolean; begin @@ -1181,10 +1183,13 @@ package body Ada.Containers.Ordered_Maps is 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; diff --git a/gcc/ada/a-coormu.adb b/gcc/ada/a-coormu.adb index 8000c991110..07f42a35261 100644 --- a/gcc/ada/a-coormu.adb +++ b/gcc/ada/a-coormu.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -983,6 +983,7 @@ package body Ada.Containers.Ordered_Multisets is procedure Insert (Container : in out Set; New_Item : Element_Type) is Position : Cursor; + pragma Unreferenced (Position); begin Insert (Container, New_Item, Position); end Insert; @@ -1700,9 +1701,9 @@ package body Ada.Containers.Ordered_Multisets is ------------ 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); diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index 3cd02332c3c..8a75ee485ae 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -891,6 +891,8 @@ package body Ada.Containers.Ordered_Sets is New_Item : Element_Type) is Position : Cursor; + pragma Unreferenced (Position); + Inserted : Boolean; begin @@ -955,6 +957,7 @@ package body Ada.Containers.Ordered_Sets is Dst_Node : out Node_Access) is Success : Boolean; + pragma Unreferenced (Success); function New_Node return Node_Access; pragma Inline (New_Node); @@ -1591,7 +1594,7 @@ package body Ada.Containers.Ordered_Sets is 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); diff --git a/gcc/ada/a-crbtgo.adb b/gcc/ada/a-crbtgo.adb index 4afce91a4f3..83c980dc182 100644 --- a/gcc/ada/a-crbtgo.adb +++ b/gcc/ada/a-crbtgo.adb @@ -7,7 +7,7 @@ -- -- -- 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- -- @@ -598,6 +598,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is 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); diff --git a/gcc/ada/a-crdlli.adb b/gcc/ada/a-crdlli.adb index 1e998007bb7..b5b22bdf82d 100644 --- a/gcc/ada/a-crdlli.adb +++ b/gcc/ada/a-crdlli.adb @@ -7,7 +7,7 @@ -- -- -- 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- -- @@ -664,7 +664,7 @@ package body Ada.Containers.Restricted_Doubly_Linked_Lists is Count : Count_Type := 1) is Position : Cursor; - + pragma Unreferenced (Position); begin Insert (Container, Before, New_Item, Position, Count); end Insert; @@ -1300,7 +1300,9 @@ package body Ada.Containers.Restricted_Doubly_Linked_Lists is declare I_Next : constant Cursor := Next (I); + J_Copy : Cursor := J; + pragma Warnings (Off, J_Copy); begin if I_Next = J then @@ -1309,7 +1311,9 @@ package body Ada.Containers.Restricted_Doubly_Linked_Lists is else declare J_Next : constant Cursor := Next (J); + I_Copy : Cursor := I; + pragma Warnings (Off, I_Copy); begin if J_Next = I then diff --git a/gcc/ada/a-ngrear.adb b/gcc/ada/a-ngrear.adb index 2ff5d01c0aa..098d5a9a2c5 100644 --- a/gcc/ada/a-ngrear.adb +++ b/gcc/ada/a-ngrear.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -455,11 +455,13 @@ package body Ada.Numerics.Generic_Real_Arrays is 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"; @@ -491,7 +493,9 @@ package body Ada.Numerics.Generic_Real_Arrays is 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 @@ -554,12 +558,16 @@ package body Ada.Numerics.Generic_Real_Arrays is 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"; @@ -592,6 +600,7 @@ package body Ada.Numerics.Generic_Real_Arrays is declare Work : Real_Vector (1 .. Integer'Min (Integer (L_Work (1)), 4 * N)); + pragma Warnings (Off, Work); begin -- Reduce matrix to tridiagonal form @@ -677,6 +686,8 @@ package body Ada.Numerics.Generic_Real_Arrays is declare Work : Real_Vector (1 .. Integer (L_Work (1))); + pragma Warnings (Off, Work); + begin -- Compute inverse from LU decomposition diff --git a/gcc/ada/a-nuflra.adb b/gcc/ada/a-nuflra.adb index ae23f459381..397398b3e24 100644 --- a/gcc/ada/a-nuflra.adb +++ b/gcc/ada/a-nuflra.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -117,7 +117,7 @@ package body Ada.Numerics.Float_Random is 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; diff --git a/gcc/ada/a-rbtgso.adb b/gcc/ada/a-rbtgso.adb index fc0c706304a..ad4f76f5df6 100644 --- a/gcc/ada/a-rbtgso.adb +++ b/gcc/ada/a-rbtgso.adb @@ -7,7 +7,7 @@ -- -- -- 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- -- @@ -51,6 +51,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is pragma Assert (Tree.Lock = 0); Root : Node_Access := Tree.Root; + pragma Warnings (Off, Root); begin Tree.Root := null; @@ -145,6 +146,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is R_Node : Node_Access := Right.First; Dst_Node : Node_Access; + pragma Warnings (Off, Dst_Node); begin if Left'Address = Right'Address then @@ -268,6 +270,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is R_Node : Node_Access := Right.First; Dst_Node : Node_Access; + pragma Warnings (Off, Dst_Node); begin if Left'Address = Right'Address then @@ -396,6 +399,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is Src : Node_Access := Source.First; New_Tgt_Node : Node_Access; + pragma Warnings (Off, New_Tgt_Node); begin if Target.Busy > 0 then @@ -460,6 +464,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is R_Node : Node_Access := Right.First; Dst_Node : Node_Access; + pragma Warnings (Off, Dst_Node); begin if Left'Address = Right'Address then diff --git a/gcc/ada/a-tigeau.adb b/gcc/ada/a-tigeau.adb index 919d690bc29..1feed2b4377 100644 --- a/gcc/ada/a-tigeau.adb +++ b/gcc/ada/a-tigeau.adb @@ -319,7 +319,7 @@ package body Ada.Text_IO.Generic_Aux is Ptr : in out Integer) is Junk : Boolean; - + pragma Unreferenced (Junk); begin Load_Extended_Digits (File, Buf, Ptr, Junk); end Load_Extended_Digits; diff --git a/gcc/ada/a-wtgeau.adb b/gcc/ada/a-wtgeau.adb index c020589ee8c..57b9cb72d74 100644 --- a/gcc/ada/a-wtgeau.adb +++ b/gcc/ada/a-wtgeau.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -345,7 +345,7 @@ package body Ada.Wide_Text_IO.Generic_Aux is Ptr : in out Integer) is Junk : Boolean; - + pragma Unreferenced (Junk); begin Load_Extended_Digits (File, Buf, Ptr, Junk); end Load_Extended_Digits; diff --git a/gcc/ada/a-ztgeau.adb b/gcc/ada/a-ztgeau.adb index 21b9608db80..fcf36331767 100644 --- a/gcc/ada/a-ztgeau.adb +++ b/gcc/ada/a-ztgeau.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -345,7 +345,7 @@ package body Ada.Wide_Wide_Text_IO.Generic_Aux is Ptr : in out Integer) is Junk : Boolean; - + pragma Unreferenced (Junk); begin Load_Extended_Digits (File, Buf, Ptr, Junk); end Load_Extended_Digits; diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index bf15ffb3ca3..ba6a5a3c1ce 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -2400,9 +2400,9 @@ package body Bindgen is ----------------------- 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); @@ -2421,7 +2421,6 @@ package body Bindgen is 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; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 33696b0003c..f9f0c1041bf 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -1315,7 +1315,10 @@ package body Checks is LOK : Boolean; Rlo : Uint; Rhi : Uint; - ROK : Boolean; + ROK : Boolean; + + pragma Warnings (Off, Lhi); + -- Don't actually use this value begin if Expander_Active @@ -5201,7 +5204,10 @@ package body Checks is 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; @@ -6658,10 +6664,6 @@ package body Checks is 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); @@ -6672,9 +6674,6 @@ package body Checks is 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. @@ -6691,7 +6690,6 @@ package body Checks is Evolve_Or_Else (Cond, Range_Equal_E_Cond (Exptyp, T_Typ, Indx)); - else Evolve_Or_Else (Cond, Range_E_Cond (Exptyp, T_Typ, Indx)); diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 013fab917a9..ffa4ad08794 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -174,7 +174,6 @@ package body Einfo is -- 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 @@ -217,7 +216,8 @@ package body Einfo is -- 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 @@ -554,7 +554,7 @@ package body Einfo is (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; @@ -2051,8 +2051,8 @@ package body Einfo is 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 @@ -2608,6 +2608,11 @@ package body Einfo 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; @@ -2855,7 +2860,7 @@ package body Einfo is (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; @@ -4378,8 +4383,8 @@ package body Einfo is 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 @@ -5489,11 +5494,29 @@ package body Einfo 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; @@ -8038,9 +8061,6 @@ package body Einfo is when E_Exception => Write_Str ("Register_Exception_Call"); - when E_Variable => - Write_Str ("Last_Assignment"); - when others => Write_Str ("Field20??"); end case; @@ -8283,6 +8303,11 @@ package body Einfo is 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; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 0a6b35ab5d5..8e659f12ab3 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2711,11 +2711,12 @@ package Einfo is -- 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 @@ -3630,9 +3631,6 @@ package Einfo is -- 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. @@ -3647,21 +3645,24 @@ package Einfo is 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 -- -------------------------------- @@ -4046,6 +4047,11 @@ package Einfo is -- 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; @@ -4156,9 +4162,9 @@ package Einfo is 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 .. @@ -4214,14 +4220,14 @@ package Einfo is 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; @@ -4902,12 +4908,14 @@ package Einfo is -- 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) @@ -5282,11 +5290,11 @@ package Einfo is -- 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) @@ -5901,6 +5909,7 @@ package Einfo is 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; @@ -6846,6 +6855,7 @@ package Einfo is 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); diff --git a/gcc/ada/eval_fat.adb b/gcc/ada/eval_fat.adb index 78f2e4d5436..ab5e49fbf71 100644 --- a/gcc/ada/eval_fat.adb +++ b/gcc/ada/eval_fat.adb @@ -114,6 +114,7 @@ package body Eval_Fat is 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; @@ -435,6 +436,7 @@ package body Eval_Fat is 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; @@ -470,6 +472,7 @@ package body Eval_Fat is 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; @@ -726,6 +729,8 @@ package body Eval_Fat is K : UI; P_Even : Boolean; + pragma Warnings (Off, Arg_Frac); + begin if UR_Is_Positive (X) then Sign_X := Ureal_1; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 7296b8ac0f5..451fa0b7d38 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2412,8 +2412,30 @@ package body Exp_Ch6 is 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 @@ -5685,10 +5707,26 @@ package body Exp_Ch6 is -- 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 diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb index 21e1eb13ce6..98268d246e9 100644 --- a/gcc/ada/exp_fixd.adb +++ b/gcc/ada/exp_fixd.adb @@ -416,6 +416,8 @@ package body Exp_Fixd is 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); @@ -803,6 +805,8 @@ package body Exp_Fixd is 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); diff --git a/gcc/ada/exp_smem.adb b/gcc/ada/exp_smem.adb index 8330405613c..b34a1ef80dc 100644 --- a/gcc/ada/exp_smem.adb +++ b/gcc/ada/exp_smem.adb @@ -69,7 +69,7 @@ package body Exp_Smem is 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 -- @@ -245,50 +245,18 @@ package body Exp_Smem is ------------------- 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; --------------------------- diff --git a/gcc/ada/fmap.adb b/gcc/ada/fmap.adb index dc5d10df974..8f286b3b6f7 100644 --- a/gcc/ada/fmap.adb +++ b/gcc/ada/fmap.adb @@ -490,7 +490,7 @@ package body Fmap is if Last_In_Table = 0 then declare Discard : Boolean; - + pragma Warnings (Off, Discard); begin Delete_File (File_Name, Discard); end; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index c55d46892fb..c6ce9dfa451 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1449,10 +1449,12 @@ package body Freeze is 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). @@ -2899,8 +2901,10 @@ package body Freeze is 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 diff --git a/gcc/ada/g-awk.adb b/gcc/ada/g-awk.adb index e530efc1560..60a85b51c5d 100644 --- a/gcc/ada/g-awk.adb +++ b/gcc/ada/g-awk.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -1475,6 +1475,7 @@ package body GNAT.AWK is 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); diff --git a/gcc/ada/g-calend.adb b/gcc/ada/g-calend.adb index f34a0d9d7c9..e2edaff657d 100644 --- a/gcc/ada/g-calend.adb +++ b/gcc/ada/g-calend.adb @@ -45,6 +45,7 @@ package body GNAT.Calendar is 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; @@ -59,6 +60,7 @@ package body GNAT.Calendar is 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); @@ -76,6 +78,7 @@ package body GNAT.Calendar is 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; @@ -135,6 +138,7 @@ package body GNAT.Calendar is 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; @@ -152,6 +156,7 @@ package body GNAT.Calendar is 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; @@ -202,6 +207,7 @@ package body GNAT.Calendar is 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; @@ -220,6 +226,7 @@ package body GNAT.Calendar is 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) + @@ -297,6 +304,8 @@ package body GNAT.Calendar is 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. diff --git a/gcc/ada/g-diopit.adb b/gcc/ada/g-diopit.adb index d57ca385832..e88d2ee6c43 100644 --- a/gcc/ada/g-diopit.adb +++ b/gcc/ada/g-diopit.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -78,10 +78,12 @@ package body GNAT.Directory_Operations.Iteration is -------------------- 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); @@ -319,7 +321,10 @@ package body GNAT.Directory_Operations.Iteration is 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; diff --git a/gcc/ada/g-expect.adb b/gcc/ada/g-expect.adb index fb9d296e513..237f3f498fb 100644 --- a/gcc/ada/g-expect.adb +++ b/gcc/ada/g-expect.adb @@ -248,6 +248,7 @@ package body GNAT.Expect is procedure Close (Descriptor : in out Process_Descriptor) is Status : Integer; + pragma Unreferenced (Status); begin Close (Descriptor, Status); end Close; @@ -299,7 +300,7 @@ package body GNAT.Expect is 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; @@ -385,7 +386,9 @@ package body GNAT.Expect is 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 @@ -407,7 +410,7 @@ package body GNAT.Expect is 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; @@ -419,7 +422,7 @@ package body GNAT.Expect is 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; @@ -815,6 +818,7 @@ package body GNAT.Expect is declare Result : Expect_Match; + pragma Unreferenced (Result); begin -- This loop runs until the call to Expect raises Process_Died @@ -1117,10 +1121,11 @@ package body GNAT.Expect is 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 @@ -1238,6 +1243,7 @@ package body GNAT.Expect is Pipe3 : not null access Pipe_Type) is Status : Boolean; + pragma Unreferenced (Status); begin -- Create the pipes diff --git a/gcc/ada/g-spipat.adb b/gcc/ada/g-spipat.adb index 49d9bf6bac9..09f2efaacf9 100644 --- a/gcc/ada/g-spipat.adb +++ b/gcc/ada/g-spipat.adb @@ -2803,11 +2803,13 @@ package body GNAT.Spitbol.Patterns is (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); @@ -2825,6 +2827,8 @@ package body GNAT.Spitbol.Patterns is Pat : Pattern) return Boolean is Start, Stop : Natural; + pragma Unreferenced (Stop); + subtype String1 is String (1 .. Subject'Length); begin @@ -2898,10 +2902,12 @@ package body GNAT.Spitbol.Patterns is (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); @@ -2918,7 +2924,10 @@ package body GNAT.Spitbol.Patterns is 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); @@ -3093,10 +3102,12 @@ package body GNAT.Spitbol.Patterns is (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); @@ -3113,6 +3124,8 @@ package body GNAT.Spitbol.Patterns is Pat : PString) is Start, Stop : Natural; + pragma Unreferenced (Start, Stop); + subtype String1 is String (1 .. Subject'Length); begin diff --git a/gcc/ada/g-thread.adb b/gcc/ada/g-thread.adb index 94719ce9bd7..9f584fdc1ce 100644 --- a/gcc/ada/g-thread.adb +++ b/gcc/ada/g-thread.adb @@ -68,6 +68,7 @@ package body GNAT.Threads is Parm : Void_Ptr; Code : Code_Proc) is + pragma Unreferenced (Parm); pragma Priority (Prio); pragma Storage_Size (Stsz); end Thread; diff --git a/gcc/ada/gnatchop.adb b/gcc/ada/gnatchop.adb index 03d797e743f..9957dee094f 100644 --- a/gcc/ada/gnatchop.adb +++ b/gcc/ada/gnatchop.adb @@ -428,9 +428,11 @@ procedure Gnatchop is 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); diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index c3cb72677b9..42fcdc94bb9 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -692,6 +692,7 @@ procedure Gnatlink is -- Used for various Interfaces.C_Streams calls Closing_Status : Boolean; + pragma Warnings (Off, Closing_Status); -- For call to Close GNAT_Static : Boolean := False; @@ -1589,7 +1590,7 @@ begin -- 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 @@ -1599,7 +1600,7 @@ begin 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 diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index c12f7944ad2..b0a96af5c26 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -44,7 +44,7 @@ with Stand; use Stand; with Table; use Table; with Widechar; use Widechar; -with GNAT.Heap_Sort_A; +with GNAT.Heap_Sort_G; package body Lib.Xref is @@ -200,11 +200,11 @@ 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; @@ -212,18 +212,25 @@ package body Lib.Xref is 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 -- @@ -235,28 +242,41 @@ package body Lib.Xref is -- 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? @@ -267,15 +287,16 @@ package body Lib.Xref is -- 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; @@ -290,6 +311,7 @@ package body Lib.Xref is 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 @@ -393,7 +415,18 @@ package body Lib.Xref is 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. @@ -433,13 +466,49 @@ package body Lib.Xref is 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; @@ -954,11 +1023,14 @@ package body Lib.Xref is 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, @@ -1140,6 +1212,8 @@ package body Lib.Xref is procedure Move (From : Natural; To : Natural); -- Move procedure for Sort call + package Sorting is new GNAT.Heap_Sort_G (Move, Lt); + -------- -- Lt -- -------- @@ -1230,10 +1304,7 @@ package body Lib.Xref is -- Sort the references - GNAT.Heap_Sort_A.Sort - (Integer (Nrefs), - Move'Unrestricted_Access, - Lt'Unrestricted_Access); + Sorting.Sort (Integer (Nrefs)); -- Eliminate duplicate entries @@ -1272,9 +1343,12 @@ package body Lib.Xref is 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 diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads index c40f483df05..1a96e81e6a4 100644 --- a/gcc/ada/lib-xref.ads +++ b/gcc/ada/lib-xref.ads @@ -115,11 +115,18 @@ package Lib.Xref is -- 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: @@ -561,11 +568,11 @@ package Lib.Xref is -- 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: -- @@ -605,22 +612,22 @@ package Lib.Xref is -- 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 diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index c2c10ad1958..a5c784d0b3a 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -3947,6 +3947,7 @@ package body Make is 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 @@ -3968,6 +3969,8 @@ package body Make is 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 .. @@ -4203,6 +4206,7 @@ package body Make is -- 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 @@ -7077,9 +7081,11 @@ package body Make is 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 diff --git a/gcc/ada/makegpr.adb b/gcc/ada/makegpr.adb index 4548916aee3..3011c420bb8 100644 --- a/gcc/ada/makegpr.adb +++ b/gcc/ada/makegpr.adb @@ -1058,7 +1058,9 @@ package body Makegpr is Time_Stamp : Time_Stamp_Type; Saved_Last_Argument : Natural; First_Object : Natural; - Discard : Boolean; + + Discard : Boolean; + pragma Warnings (Off, Discard); begin Check_Archive_Builder; @@ -2239,7 +2241,9 @@ package body Makegpr is declare Dep_File : Ada.Text_IO.File_Type; Result : Expect_Match; - Status : Integer; + + Status : Integer; + pragma Warnings (Off, Status); begin -- Create the dependency file diff --git a/gcc/ada/mdll.adb b/gcc/ada/mdll.adb index f2d5aa97578..e6eb5e936a3 100644 --- a/gcc/ada/mdll.adb +++ b/gcc/ada/mdll.adb @@ -111,6 +111,7 @@ package body MDLL is -- Objects plus the export table (.exp) file Success : Boolean; + pragma Warnings (Off, Success); begin if not Quiet then @@ -192,6 +193,7 @@ package body MDLL is procedure Ada_Build_Reloc_DLL is Success : Boolean; + pragma Warnings (Off, Success); begin if not Quiet then @@ -296,6 +298,7 @@ package body MDLL is procedure Build_Non_Reloc_DLL is Success : Boolean; + pragma Warnings (Off, Success); begin if not Quiet then @@ -348,6 +351,7 @@ package body MDLL is procedure Ada_Build_Non_Reloc_DLL is Success : Boolean; + pragma Warnings (Off, Success); begin if not Quiet then diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index 4314a80a1d6..2805b8c97a1 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -1699,7 +1699,8 @@ package body MLib.Prj is -- 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 @@ -1774,6 +1775,7 @@ package body MLib.Prj is Last : Natural; Disregard : Boolean; + pragma Warnings (Off, Disregard); DLL_Name : aliased constant String := Lib_Filename.all & "." & DLL_Ext; @@ -1963,6 +1965,7 @@ package body MLib.Prj is Last : Natural; Disregard : Boolean; + pragma Warnings (Off, Disregard); begin Open (Dir, "."); @@ -2181,7 +2184,8 @@ package body MLib.Prj is ---------- procedure Copy (File_Name : File_Name_Type) is - Success : Boolean := False; + Success : Boolean; + pragma Warnings (Off, Success); begin Unit_Loop : diff --git a/gcc/ada/mlib.adb b/gcc/ada/mlib.adb index 573043325e2..b0301d2817c 100644 --- a/gcc/ada/mlib.adb +++ b/gcc/ada/mlib.adb @@ -303,11 +303,11 @@ package body MLib is 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 diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index d766e97abbe..00a9cef9076 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -36,6 +36,7 @@ -- 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; @@ -252,8 +253,8 @@ package Opt is -- 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 @@ -601,6 +602,13 @@ package Opt is -- 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 @@ -1186,8 +1194,13 @@ package Opt is 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 diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index ca42b44a918..eb9d23c207e 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -295,6 +295,7 @@ package body Osint is Ch : Character; Status : Boolean; + pragma Warnings (Off, Status); -- For the call to Close begin @@ -2042,6 +2043,7 @@ package body Osint is -- Allocated text buffer Status : Boolean; + pragma Warnings (Off, Status); -- For the calls to Close begin @@ -2174,6 +2176,7 @@ package body Osint is Actual_Len : Integer; Status : Boolean; + pragma Warnings (Off, Status); -- For the call to Close begin @@ -2811,6 +2814,7 @@ package body Osint is procedure Write_With_Check (A : Address; N : Integer) is Ignore : Boolean; + pragma Warnings (Off, Ignore); begin if N = Write (Output_FD, A, N) then diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 265c691ce02..b28c93ea5a7 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -4412,7 +4412,7 @@ package body Ch3 is 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; diff --git a/gcc/ada/prj-makr.adb b/gcc/ada/prj-makr.adb index c07fb267acb..aef87437b88 100644 --- a/gcc/ada/prj-makr.adb +++ b/gcc/ada/prj-makr.adb @@ -937,6 +937,7 @@ package body Prj.Makr is declare Discard : Boolean; + pragma Warnings (Off, Discard); begin Delete_File (Source_List_Path (1 .. Source_List_Last), @@ -1350,6 +1351,7 @@ package body Prj.Makr is declare Discard : Boolean; + pragma Warnings (Off, Discard); begin -- Delete the file if it already exists diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 5b0ebbb8ebd..0bd6028102c 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -364,6 +364,7 @@ package body Prj is 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 diff --git a/gcc/ada/s-fatgen.adb b/gcc/ada/s-fatgen.adb index f591a699250..20f3ead2828 100644 --- a/gcc/ada/s-fatgen.adb +++ b/gcc/ada/s-fatgen.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -129,6 +129,7 @@ package body System.Fat_Gen is 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); @@ -251,6 +252,7 @@ package body System.Fat_Gen is 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; @@ -279,6 +281,7 @@ package body System.Fat_Gen is 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; @@ -451,7 +454,6 @@ package body System.Fat_Gen is B : T; Arg : T; P : T; - Arg_Frac : T; P_Frac : T; Sign_X : T; IEEE_Rem : T; @@ -460,6 +462,9 @@ package body System.Fat_Gen is K : UI; P_Even : Boolean; + Arg_Frac : T; + pragma Unreferenced (Arg_Frac); + begin if Y = 0.0 then raise Constraint_Error; diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index 40a02fb010f..e2c0e3df29c 100644 --- a/gcc/ada/s-fileio.adb +++ b/gcc/ada/s-fileio.adb @@ -523,6 +523,7 @@ package body System.File_IO is return Boolean is V1, V2 : Natural; + pragma Unreferenced (V2); begin Form_Parameter (Form, Keyword, V1, V2); diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb index d09d9235a73..af4c394b47b 100755 --- a/gcc/ada/s-os_lib.adb +++ b/gcc/ada/s-os_lib.adb @@ -1091,12 +1091,15 @@ package body System.OS_Lib is ------------ 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); @@ -1108,12 +1111,15 @@ package body System.OS_Lib is ------------- 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); @@ -1125,12 +1131,15 @@ package body System.OS_Lib is --------------- 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); @@ -1142,12 +1151,15 @@ package body System.OS_Lib is -------------- 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); @@ -1159,12 +1171,15 @@ package body System.OS_Lib is --------------- 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); @@ -1226,11 +1241,14 @@ package body System.OS_Lib is 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); @@ -1464,9 +1482,9 @@ package body System.OS_Lib is (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; @@ -2287,8 +2305,9 @@ package body System.OS_Lib is (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; diff --git a/gcc/ada/s-regpat.adb b/gcc/ada/s-regpat.adb index 2441271f0e5..4204f0cfa06 100755 --- a/gcc/ada/s-regpat.adb +++ b/gcc/ada/s-regpat.adb @@ -2059,8 +2059,12 @@ package body System.Regpat is 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 @@ -2090,6 +2094,7 @@ package body System.Regpat is is Size : Program_Size; Dummy : Pattern_Matcher (0); + pragma Unreferenced (Dummy); begin Compile (Dummy, Expression, Size, Flags); @@ -2108,6 +2113,7 @@ package body System.Regpat is Flags : Regexp_Flags := No_Flags) is Size : Program_Size; + pragma Unreferenced (Size); begin Compile (Matcher, Expression, Size, Flags); end Compile; @@ -3442,7 +3448,7 @@ package body System.Regpat is 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); @@ -3464,8 +3470,8 @@ package body System.Regpat is 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); @@ -3488,8 +3494,8 @@ package body System.Regpat is 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); diff --git a/gcc/ada/s-taasde.adb b/gcc/ada/s-taasde.adb index f9bcabeeef1..b3e67eeb679 100644 --- a/gcc/ada/s-taasde.adb +++ b/gcc/ada/s-taasde.adb @@ -304,7 +304,7 @@ package body System.Tasking.Async_Delays is 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 -- @@ -316,6 +316,8 @@ package body System.Tasking.Async_Delays is return Duration'Last; end Get_Next_Wakeup_Time; + -- Local Declarations + Next_Wakeup_Time : Duration := Get_Next_Wakeup_Time; Timedout : Boolean; Yielded : Boolean; @@ -323,6 +325,8 @@ package body System.Tasking.Async_Delays is Dequeued : Delay_Block_Access; Dequeued_Task : Task_Id; + pragma Unreferenced (Timedout, Yielded); + begin Timer_Server_ID := STPO.Self; @@ -376,7 +380,6 @@ package body System.Tasking.Async_Delays is 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 diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index b8ebc814387..d0ba725272d 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -547,7 +547,9 @@ package body System.Task_Primitives.Operations is Check_Time : Duration := Monotonic_Clock; Rel_Time : Duration; Abs_Time : Duration; - Result : Integer; + + Result : Integer; + pragma Unreferenced (Result); Local_Timedout : Boolean; @@ -607,10 +609,10 @@ package body System.Task_Primitives.Operations is 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 diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index e0c35b52b99..f9b30ce69c6 100644 --- a/gcc/ada/s-taprop-posix.adb +++ b/gcc/ada/s-taprop-posix.adb @@ -204,9 +204,11 @@ package body System.Task_Primitives.Operations is 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. diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb index 26dab87029c..330519db8ea 100644 --- a/gcc/ada/s-taprop-solaris.adb +++ b/gcc/ada/s-taprop-solaris.adb @@ -270,6 +270,7 @@ package body System.Task_Primitives.Operations is 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 diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb index 0647b21c981..0440ff3d359 100644 --- a/gcc/ada/s-taprop-vms.adb +++ b/gcc/ada/s-taprop-vms.adb @@ -150,7 +150,8 @@ package body System.Task_Primitives.Operations is -- 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; diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index 51e7f0cac18..9af031a499a 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -176,9 +176,11 @@ package body System.Task_Primitives.Operations is 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. diff --git a/gcc/ada/s-tasdeb.ads b/gcc/ada/s-tasdeb.ads index 72f3954a9d5..9aebe943d4d 100644 --- a/gcc/ada/s-tasdeb.ads +++ b/gcc/ada/s-tasdeb.ads @@ -98,7 +98,7 @@ package System.Tasking.Debug is 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 diff --git a/gcc/ada/s-tasren.adb b/gcc/ada/s-tasren.adb index 2af7365554b..40111c8fd3a 100644 --- a/gcc/ada/s-tasren.adb +++ b/gcc/ada/s-tasren.adb @@ -392,6 +392,7 @@ package body System.Tasking.Rendezvous is Uninterpreted_Data : System.Address) is Rendezvous_Successful : Boolean; + pragma Unreferenced (Rendezvous_Successful); begin -- If pragma Detect_Blocking is active then Program_Error must be @@ -1706,7 +1707,9 @@ package body System.Tasking.Rendezvous is 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 diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index a50b3795871..ceea9352b3e 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -749,7 +749,9 @@ package body System.Tasking.Stages is 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 diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb index 25208ad10c0..f034f9e63a5 100644 --- a/gcc/ada/s-tpobop.adb +++ b/gcc/ada/s-tpobop.adb @@ -114,11 +114,10 @@ package body System.Tasking.Protected_Objects.Operations is (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; @@ -132,15 +131,16 @@ package body System.Tasking.Protected_Objects.Operations is -- 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... @@ -148,12 +148,13 @@ package body System.Tasking.Protected_Objects.Operations is -- ...B... -- end select; - -- expanded code: + -- Expanded code: -- declare -- X : protected_entry_index := 1; -- B80b : communication_block; -- communication_blockIP (B80b); + -- begin -- begin -- A79b : label @@ -165,6 +166,7 @@ package body System.Tasking.Protected_Objects.Operations is -- end if; -- return; -- end _clean; + -- begin -- protected_entry_call (rTV!(r)._object'unchecked_access, X, -- null_address, asynchronous_call, B80b, objectF => 0); @@ -174,11 +176,13 @@ package body System.Tasking.Protected_Objects.Operations is -- at end -- _clean; -- end A79b; + -- exception -- when _abort_signal => -- abort_undefer.all; -- null; -- end; + -- if not cancelled (B80b) then -- x := ...A... -- end if; @@ -188,12 +192,12 @@ package body System.Tasking.Protected_Objects.Operations is -- 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. @@ -201,24 +205,21 @@ package body System.Tasking.Protected_Objects.Operations is -- 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. @@ -277,15 +278,17 @@ package body System.Tasking.Protected_Objects.Operations is 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. @@ -299,6 +302,7 @@ package body System.Tasking.Protected_Objects.Operations is -- Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or -- PO_Service_Entries on return. + end if; if Runtime_Traces then @@ -331,7 +335,7 @@ package body System.Tasking.Protected_Objects.Operations is 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; @@ -439,7 +443,7 @@ package body System.Tasking.Protected_Objects.Operations is 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; @@ -454,10 +458,12 @@ package body System.Tasking.Protected_Objects.Operations is 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 @@ -497,8 +503,7 @@ package body System.Tasking.Protected_Objects.Operations is 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)); @@ -508,7 +513,7 @@ package body System.Tasking.Protected_Objects.Operations is -- 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... @@ -520,9 +525,11 @@ package body System.Tasking.Protected_Objects.Operations is -- 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 @@ -636,7 +643,7 @@ package body System.Tasking.Protected_Objects.Operations is 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; @@ -657,16 +664,17 @@ package body System.Tasking.Protected_Objects.Operations is 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 @@ -686,6 +694,7 @@ package body System.Tasking.Protected_Objects.Operations is 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); @@ -750,8 +759,7 @@ package body System.Tasking.Protected_Objects.Operations is 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); @@ -761,17 +769,17 @@ package body System.Tasking.Protected_Objects.Operations is 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; @@ -804,6 +812,7 @@ package body System.Tasking.Protected_Objects.Operations is if Single_Lock then STPO.Unlock_RTS; end if; + else Queuing.Enqueue (New_Object.Entry_Queues (E), Entry_Call); @@ -831,7 +840,7 @@ package body System.Tasking.Protected_Objects.Operations is -- 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 @@ -893,7 +902,7 @@ package body System.Tasking.Protected_Objects.Operations is -- Requeue_Task_To_Protected_Entry -- ------------------------------------- - -- Compiler interface only. + -- Compiler interface only (do not call from within the RTS) -- accept e1 do -- ...A... @@ -902,6 +911,7 @@ package body System.Tasking.Protected_Objects.Operations is -- A79b : address; -- L78b : label + -- begin -- accept_call (1, A79b); -- ...A... @@ -910,6 +920,7 @@ package body System.Tasking.Protected_Objects.Operations is -- goto L78b; -- <<L78b>> -- complete_rendezvous; + -- exception -- when all others => -- exceptional_complete_rendezvous (get_gnat_exception); @@ -951,7 +962,7 @@ package body System.Tasking.Protected_Objects.Operations is -- 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; @@ -964,7 +975,9 @@ package body System.Tasking.Protected_Objects.Operations is 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 @@ -1028,7 +1041,7 @@ package body System.Tasking.Protected_Objects.Operations is 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); diff --git a/gcc/ada/s-tposen.adb b/gcc/ada/s-tposen.adb index 38554fa53e3..aeee03684b4 100644 --- a/gcc/ada/s-tposen.adb +++ b/gcc/ada/s-tposen.adb @@ -211,7 +211,9 @@ package body System.Tasking.Protected_Objects.Single_Entry is is Self_Id : constant Task_Id := Entry_Call.Self; Timedout : Boolean; + Yielded : Boolean; + pragma Unreferenced (Yielded); use type Ada.Exceptions.Exception_Id; @@ -663,7 +665,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is -- 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; diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index f6ce93d5443..66cfc88a993 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -534,6 +534,8 @@ package body Sem_Ch11 is Analyze_And_Resolve (Expression (N), Standard_String); end if; end if; + + Kill_Current_Values (Last_Assignment_Only => True); end Analyze_Raise_Statement; ----------------------------- diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 25e5889815d..553f20040cb 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -707,8 +707,11 @@ package body Sem_Ch5 is -- 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 @@ -884,6 +887,10 @@ package body Sem_Ch5 is 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 @@ -981,6 +988,7 @@ package body Sem_Ch5 is -- 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 @@ -1171,6 +1179,7 @@ package body Sem_Ch5 is begin Check_Unreachable_Code (N); + Kill_Current_Values (Last_Assignment_Only => True); Analyze (Label); Label_Ent := Entity (Label); @@ -1771,6 +1780,8 @@ package body Sem_Ch5 is Hhi : Uint; HOK : Boolean; + pragma Warnings (Off, Hlo); + begin Determine_Range (L, LOK, Llo, Lhi); Determine_Range (H, HOK, Hlo, Hhi); diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 40dceb2a2c2..e7076b34e50 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -808,7 +808,7 @@ package body Sem_Ch7 is 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); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index fff20546516..8a5ae003e5f 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -3014,6 +3014,15 @@ package body Sem_Ch8 is -- 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 @@ -3094,6 +3103,23 @@ package body Sem_Ch8 is 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 -- ------------------------- @@ -3837,7 +3863,9 @@ package body Sem_Ch8 is -- 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 @@ -3856,10 +3884,11 @@ package body Sem_Ch8 is 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 @@ -3870,9 +3899,15 @@ package body Sem_Ch8 is -- 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; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 71a3da2fa0d..65ee2870de5 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -5519,6 +5519,8 @@ package body Sem_Prag is 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; @@ -6151,6 +6153,8 @@ package body Sem_Prag is C : Convention_Id; Def_Id : Entity_Id; + pragma Warnings (Off, C); + begin Check_Ada_83_Warning; Check_Arg_Order @@ -6540,8 +6544,11 @@ package body Sem_Prag is -- [, [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 diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 718fb242e08..258064aa20d 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -116,6 +116,10 @@ package body Sem_Res is -- 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. @@ -989,6 +993,18 @@ package body Sem_Res is 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 -- ---------------------- @@ -1024,10 +1040,6 @@ package body Sem_Res is 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 @@ -1037,18 +1049,6 @@ package body Sem_Res is -- 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 -- --------------------------- @@ -2568,6 +2568,7 @@ package body Sem_Res is 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, @@ -3042,10 +3043,44 @@ package body Sem_Res is 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)); @@ -4774,6 +4809,37 @@ package body Sem_Res is 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. @@ -4804,6 +4870,8 @@ package body Sem_Res is 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; diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 3b9f57de48d..4612ad36517 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -494,10 +494,13 @@ package body Sem_Type is 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; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a9d4aec18c6..a6c35d3e9ef 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2192,6 +2192,9 @@ package body Sem_Util is 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))); @@ -2629,6 +2632,69 @@ package body Sem_Util is 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 -- ------------------------------------- @@ -5827,7 +5893,9 @@ package body Sem_Util is 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 @@ -6923,16 +6991,19 @@ package body Sem_Util is -- 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; @@ -6941,7 +7012,7 @@ package body Sem_Util is 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); @@ -6956,7 +7027,7 @@ package body Sem_Util is 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; @@ -6966,7 +7037,9 @@ package body Sem_Util is 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. @@ -7766,8 +7839,8 @@ package body Sem_Util is 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; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index c0ce298befa..1e023252b56 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -283,6 +283,17 @@ package Sem_Util is -- 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; @@ -743,7 +754,7 @@ package Sem_Util is -- 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 @@ -756,11 +767,24 @@ package Sem_Util is -- 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 diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 3faf9cb09d6..65ea957c744 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -1119,8 +1119,9 @@ package body Sem_Warn is 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 @@ -2529,6 +2530,12 @@ package body Sem_Warn is 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; @@ -2597,6 +2604,7 @@ package body Sem_Warn is 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; @@ -3256,6 +3264,7 @@ package body Sem_Warn is 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 @@ -3269,7 +3278,7 @@ package body Sem_Warn 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) @@ -3425,7 +3434,7 @@ package body Sem_Warn is -- 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) @@ -3451,10 +3460,21 @@ package body Sem_Warn is 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 @@ -3462,6 +3482,8 @@ package body Sem_Warn is Last_Assignment (Ent), Ent); end if; + -- Clear last assignment indication and we are done + Set_Last_Assignment (Ent, Empty); return; diff --git a/gcc/ada/sem_warn.ads b/gcc/ada/sem_warn.ads index fa0bf53e70d..23618d105c2 100644 --- a/gcc/ada/sem_warn.ads +++ b/gcc/ada/sem_warn.ads @@ -179,10 +179,11 @@ package Sem_Warn is 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); diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 8528156dd9e..61a1400369e 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -3672,10 +3672,10 @@ package Sinfo is -- 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) diff --git a/gcc/ada/sinput-d.adb b/gcc/ada/sinput-d.adb index ba9a3dfc921..a860058c900 100644 --- a/gcc/ada/sinput-d.adb +++ b/gcc/ada/sinput-d.adb @@ -39,6 +39,8 @@ package body Sinput.D is 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; diff --git a/gcc/ada/stylesw.adb b/gcc/ada/stylesw.adb index 13df44dacd3..a6cd38c591b 100644 --- a/gcc/ada/stylesw.adb +++ b/gcc/ada/stylesw.adb @@ -180,6 +180,7 @@ package body Stylesw is 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); diff --git a/gcc/ada/symbols-vms.adb b/gcc/ada/symbols-vms.adb index f3b5aea3d68..39c9beb3202 100644 --- a/gcc/ada/symbols-vms.adb +++ b/gcc/ada/symbols-vms.adb @@ -103,7 +103,6 @@ package body Symbols is begin if Result (Result'First) = ' ' then return Result (Result'First + 1 .. Result'Last); - else return Result; end if; diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 2bfc91e2a86..61318c8bcb8 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -93,7 +93,7 @@ package Types is 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 diff --git a/gcc/ada/ug_words b/gcc/ada/ug_words index bd4f779fb9e..2582b6360cc 100644 --- a/gcc/ada/ug_words +++ b/gcc/ada/ug_words @@ -140,6 +140,8 @@ gcc -c ^ GNAT COMPILE -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 diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb index 362d1d03915..4ee886ebc9e 100644 --- a/gcc/ada/uintp.adb +++ b/gcc/ada/uintp.adb @@ -1259,6 +1259,7 @@ package body Uintp is function UI_Div (Left, Right : Uint) return Uint is Quotient : Uint; Remainder : Uint; + pragma Warnings (Off, Remainder); begin UI_Div_Rem (Left, Right, @@ -1536,6 +1537,7 @@ package body Uintp is 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), @@ -2571,7 +2573,9 @@ package body Uintp is end if; declare - Quotient, Remainder : Uint; + Remainder : Uint; + Quotient : Uint; + pragma Warnings (Off, Quotient); begin UI_Div_Rem (Left, Right, Quotient, Remainder, diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index f7c0f82e20f..ae5ee42268b 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -362,7 +362,7 @@ begin 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)"); @@ -400,6 +400,10 @@ begin 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 " & diff --git a/gcc/ada/validsw.adb b/gcc/ada/validsw.adb index ab6fb937e90..1c7d5cfc63a 100644 --- a/gcc/ada/validsw.adb +++ b/gcc/ada/validsw.adb @@ -104,7 +104,8 @@ package body Validsw is 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; diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index a78a3dbf603..5b8d59bd5a7 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -2586,6 +2586,10 @@ package VMS_Data is "!-gnatws,!-gnatwe " & "ALL " & "-gnatwa " & + "OPTIONAL " & + "-gnatwa " & + "NOOPTIONAL " & + "-gnatwA " & "NOALL " & "-gnatwA " & "ALL_GCC " & @@ -2602,20 +2606,20 @@ package VMS_Data is "-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 " & @@ -2624,36 +2628,48 @@ package VMS_Data is "-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 " & @@ -2662,14 +2678,6 @@ package VMS_Data is "-gnatwT " & "UNINITIALIZED " & "-Wuninitialized " & - "UNREFERENCED_FORMALS " & - "-gnatwf " & - "NOUNREFERENCED_FORMALS " & - "-gnatwF " & - "UNRECOGNIZED_PRAGMAS " & - "-gnatwg " & - "NOUNRECOGNIZED_PRAGMAS " & - "-gnatwG " & "UNUSED " & "-gnatwu " & "NOUNUSED " & @@ -2870,20 +2878,15 @@ package VMS_Data is -- 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 |