Skip to content

R
riscv-gcc-1
Commit 3f1ede06 by Robert Dewar Committed by Arnaud Charlet
Options

freeze.adb: Add handling of Last_Assignment field 

2006-10-31  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* freeze.adb: Add handling of Last_Assignment field
	(Warn_Overlay): Supply missing continuation marks in error msgs
	(Freeze_Entity): Add check for Preelaborable_Initialization

	* g-comlin.adb: Add Warnings (Off) to prevent new warning

	* g-expect.adb: Add Warnings (Off) to prevent new warning

	* lib-xref.adb: Add handling of Last_Assignment field
	(Generate_Reference): Centralize handling of pragma Obsolescent here
	(Generate_Reference): Accept an implicit reference generated for a
	default in an instance.
	(Generate_Reference): Accept a reference for a node that is not in the
	main unit, if it is the generic body corresponding to an subprogram
	instantiation.

	* xref_lib.adb: Add pragma Warnings (Off) to avoid new warnings

        * sem_warn.ads, sem_warn.adb (Set_Warning_Switch): Add processing for
	-gnatwq/Q.
	(Warn_On_Useless_Assignment): Suppress warning if enclosing inner
	exception handler.
	(Output_Obsolescent_Entity_Warnings): Rewrite to avoid any messages on
	use clauses, to avoid messages on packages used to qualify, and also
	to avoid messages from obsolescent units.
	(Warn_On_Useless_Assignments): Don't generate messages for imported
	and exported variables.
	(Warn_On_Useless_Assignments): New procedure
	(Output_Obsolescent_Entity_Warnings): New procedure
	(Check_Code_Statement): New procedure

        * einfo.ads, einfo.adb (Has_Static_Discriminants): New flag
	Change name Is_Ada_2005 to Is_Ada_2005_Only
	(Last_Assignment): New field for useless assignment warning

From-SVN: r118271
parent ac3b962e
Showing with 75 additions and 40 deletions
gcc/ada/freeze.adb
......@@ -887,31 +887,12 @@ package body Freeze is
(T : Entity_Id) return Boolean
is
Constraint : Elmt_Id;
Discr : Entity_Id;
begin
if Has_Discriminants (T)
and then Present (Discriminant_Constraint (T))
and then Present (First_Component (T))
then
Discr := First_Discriminant (T);
if Is_Access_Type (Etype (Discr)) then
null;
-- If the bounds of the discriminant are not compile-time known,
-- treat this as non-static, even if the value of the discriminant
-- is compile-time known, because the back-end treats aggregates
-- of such a subtype as having unknown size.
elsif not
(Compile_Time_Known_Value (Type_Low_Bound (Etype (Discr)))
and then
Compile_Time_Known_Value (Type_High_Bound (Etype (Discr))))
then
return False;
end if;
Constraint := First_Elmt (Discriminant_Constraint (T));
while Present (Constraint) loop
if not Compile_Time_Known_Value (Node (Constraint)) then
......@@ -2453,6 +2434,16 @@ package body Freeze is
-- Case of a type or subtype being frozen
else
-- Check preelaborable initialization for full type completing a
-- private type for which pragma Preelaborable_Initialization given.
if Must_Have_Preelab_Init (E)
and then not Has_Preelaborable_Initialization (E)
then
Error_Msg_N
("full view of & does not have preelaborable initialization", E);
end if;
-- The type may be defined in a generic unit. This can occur when
-- freezing a generic function that returns the type (which is
-- defined in a parent unit). It is clearly meaningless to freeze
......@@ -3014,7 +3005,7 @@ package body Freeze is
Freeze_Subprogram (E);
-- AI-326: Check wrong use of tag incomplete type
-- Ada 2005 (AI-326): Check wrong use of tag incomplete type
--
-- type T is tagged;
-- type Acc is access function (X : T) return T; -- ERROR
......@@ -4503,11 +4494,15 @@ package body Freeze is
-- Reset True_Constant flag, since something strange is going on with
-- the scoping here, and our simple value tracing may not be sufficient
-- for this indication to be reliable. We kill the Constant_Value
-- indication for the same reason.
-- and Last_Assignment indications for the same reason.
Set_Is_True_Constant (E, False);
Set_Current_Value (E, Empty);
if Ekind (E) = E_Variable then
Set_Last_Assignment (E, Empty);
end if;
exception
when Cannot_Be_Static =>
......@@ -5091,8 +5086,9 @@ package body Freeze is
and then Present (Packed_Array_Type (Etype (Comp)))
then
Error_Msg_NE
("packed array component& will be initialized to zero?",
Nam, Comp);
("\packed array component& " &
"will be initialized to zero?",
Nam, Comp);
exit;
else
Next_Component (Comp);
......@@ -5102,9 +5098,9 @@ package body Freeze is
end if;
Error_Msg_N
("use pragma Import for & to " &
"suppress initialization ('R'M B.1(24))?",
Nam);
("\use pragma Import for & to " &
"suppress initialization ('R'M B.1(24))?",
Nam);
end if;
end Warn_Overlay;
......
gcc/ada/g-comlin.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2005, Free Software Foundation, Inc. --
-- Copyright (C) 1999-2006, 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- --
......@@ -683,6 +683,9 @@ package body GNAT.Command_Line is
Last : Integer;
Delimiter_Found : Boolean;
Discard : Boolean;
pragma Warnings (Off, Discard);
begin
Current_Argument := 0;
Current_Index := 0;
......@@ -732,7 +735,7 @@ package body GNAT.Command_Line is
end loop;
end loop;
Delimiter_Found := Goto_Next_Argument_In_Section;
Discard := Goto_Next_Argument_In_Section;
end Initialize_Option_Scan;
---------------
......
gcc/ada/g-expect.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2000-2005, AdaCore --
-- Copyright (C) 2000-2006, 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- --
......@@ -1110,8 +1110,8 @@ package body GNAT.Expect is
Result : Expect_Match;
Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
Dummy : Natural;
pragma Unreferenced (Dummy);
Discard : Natural;
pragma Warnings (Off, Discard);
begin
if Empty_Buffer then
......@@ -1135,7 +1135,7 @@ package body GNAT.Expect is
Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input);
Dummy :=
Discard :=
Write (Descriptor.Input_Fd,
Full_Str'Address,
Last - Full_Str'First + 1);
......@@ -1275,7 +1275,6 @@ package body GNAT.Expect is
Pipe3 : in out Pipe_Type)
is
pragma Warnings (Off, Pid);
begin
Close (Pipe1.Input);
Close (Pipe2.Output);
......
gcc/ada/sem_warn.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1999-2005, Free Software Foundation, Inc. --
-- Copyright (C) 1999-2006, 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- --
......@@ -98,6 +98,11 @@ package Sem_Warn is
-- Output Routines --
---------------------
procedure Output_Obsolescent_Entity_Warnings (N : Node_Id; E : Entity_Id);
-- N is a reference to obsolescent entity E, for which appropriate warning
-- messages are to be generated (caller has already checked that warnings
-- are active and appropriate for this entity).
procedure Output_Unreferenced_Messages;
-- Warnings about unreferenced entities are collected till the end of
-- the compilation process (see Check_Unset_Reference for further
......@@ -107,6 +112,9 @@ package Sem_Warn is
-- Other Warning Routines --
----------------------------
procedure Check_Code_Statement (N : Node_Id);
-- Peform warning checks on a code statement node
procedure Warn_On_Known_Condition (C : Node_Id);
-- C is a node for a boolean expression resluting from a relational
-- or membership operation. If the expression has a compile time known
......@@ -132,4 +140,29 @@ package Sem_Warn is
-- If all these conditions are met, the warning is issued noting that
-- the result of the test is always false or always true as appropriate.
procedure Warn_On_Suspicious_Index (Name : Entity_Id; X : Node_Id);
-- This is called after resolving an indexed component or a slice. Name
-- is the entity for the name of the indexed array, and X is the subscript
-- for the indexed component case, or one of the bounds in the slice case.
-- If Name is an unconstrained parameter of a standard string type, and
-- the index is of the form of a literal or Name'Length [- literal], then
-- a warning is generated that the subscripting operation is possibly
-- incorrectly assuming a lower bound of 1.
procedure Warn_On_Useless_Assignment
(Ent : Entity_Id;
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).
procedure Warn_On_Useless_Assignments (E : Entity_Id);
pragma Inline (Warn_On_Useless_Assignments);
-- Called at the end of a block or subprogram. Scans the entities of the
-- block or subprogram to see if there are any variables for which useless
-- assignments were made (assignments whose values were never read).
end Sem_Warn;
gcc/ada/xref_lib.adb
......@@ -136,12 +136,14 @@ package body Xref_Lib is
Entity : String;
Glob : Boolean := False)
is
File_Start : Natural;
Line_Start : Natural;
Col_Start : Natural;
Line_Num : Natural := 0;
Col_Num : Natural := 0;
File_Ref : File_Reference := Empty_File;
File_Start : Natural;
Line_Start : Natural;
Col_Start : Natural;
Line_Num : Natural := 0;
Col_Num : Natural := 0;
File_Ref : File_Reference := Empty_File;
pragma Warnings (Off, File_Ref);
begin
-- Find the end of the first item in Entity (pattern or file?)
......@@ -275,7 +277,9 @@ package body Xref_Lib is
Add_To_Xref_File
(Entity (File_Start .. Line_Start - 1), Visited => True);
Pattern.File_Ref := File_Ref;
Add_Line (Pattern.File_Ref, Line_Num, Col_Num);
File_Ref :=
Add_To_Xref_File
(ALI_File_Name (Entity (File_Start .. Line_Start - 1)),
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment