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

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,7 +5086,8 @@ package body Freeze is
                      and then Present (Packed_Array_Type (Etype (Comp)))
                   then
                      Error_Msg_NE
-                       ("packed array component& will be initialized to zero?",
+                       ("\packed array component& " &
+                        "will be initialized to zero?",
                         Nam, Comp);
                      exit;
                   else
@@ -5102,7 +5098,7 @@ package body Freeze is
          end if;
 
          Error_Msg_N
-           ("use pragma Import for & to " &
+           ("\use pragma Import for & to " &
             "suppress initialization ('R'M B.1(24))?",
             Nam);
       end if;

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

@@ -141,7 +141,9 @@ package body Xref_Lib is
       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)),