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

1 files changed, 119 insertions, 74 deletions

diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb
index fc55b4bfb82..3148afeb2e4 100644
--- a/gcc/ada/lib-xref.adb
+++ b/gcc/ada/lib-xref.adb
@@ -37,6 +37,7 @@ with Rident;   use Rident;
 with Sem;      use Sem;
 with Sem_Prag; use Sem_Prag;
 with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
 with Sinfo;    use Sinfo;
 with Sinput;   use Sinput;
 with Snames;   use Snames;
@@ -111,6 +112,7 @@ package body Lib.Xref is
       if Opt.Xref_Active
 
          --  Definition must come from source
+
          --  We make an exception for subprogram child units that have no
          --  spec. For these we generate a subprogram declaration for library
          --  use, and the corresponding entity does not come from source.
@@ -212,17 +214,15 @@ package body Lib.Xref is
       Ent  : Entity_Id;
 
       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:
+      --  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 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.
+      --   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.
 
       ---------------
       -- Is_On_LHS --
@@ -240,9 +240,9 @@ package body Lib.Xref is
             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.
+         --  Reach the assignment statement subtree root. In the case of a
+         --  variable being a direct descendant of an assignment statement,
+         --  the loop is skiped.
 
          while Nkind (Parent (N)) /= N_Assignment_Statement loop
 
@@ -270,16 +270,43 @@ package body Lib.Xref is
    begin
       pragma Assert (Nkind (E) in N_Entity);
 
-      --  Check for obsolescent reference to ASCII
+      --  Check for obsolescent reference to package ASCII. GNAT treats this
+      --  element of annex J specially since in practice, programs make a lot
+      --  of use of this feature, so we don't include it in the set of features
+      --  diagnosed when Warn_On_Obsolescent_Features mode is set. However we
+      --  are required to note it as a violation of the RM defined restriction.
 
       if E = Standard_ASCII then
          Check_Restriction (No_Obsolescent_Features, N);
       end if;
 
+      --  Check for reference to entity marked with Is_Obsolescent
+
+      --  Note that we always allow obsolescent references in the compiler
+      --  itself and the run time, since we assume that we know what we are
+      --  doing in such cases. For example the calls in Ada.Characters.Handling
+      --  to its own obsolescent subprograms are just fine.
+
+      --  In any case we do not generate warnings within the extended source
+      --  unit of the entity in question, since we assume the source unit
+      --  itself knows what is going on (and for sure we do not want silly
+      --  warnings, e.g. on the end line of an obsolescent procedure body).
+
+      if Is_Obsolescent (E)
+        and then not GNAT_Mode
+        and then not In_Extended_Main_Source_Unit (E)
+      then
+         Check_Restriction (No_Obsolescent_Features, N);
+
+         if Warn_On_Obsolescent_Feature then
+            Output_Obsolescent_Entity_Warnings (N, E);
+         end if;
+      end if;
+
       --  Warn if reference to Ada 2005 entity not in Ada 2005 mode. We only
       --  detect real explicit references (modifications and references).
 
-      if Is_Ada_2005 (E)
+      if Is_Ada_2005_Only (E)
         and then Ada_Version < Ada_05
         and then Warn_On_Ada_2005_Compatibility
         and then (Typ = 'm' or else Typ = 'r')
@@ -294,12 +321,23 @@ package body Lib.Xref is
       --  case of 'p' since we want to include inherited primitive operations
       --  from other packages.
 
-      if not In_Extended_Main_Source_Unit (N)
-        and then Typ /= 'e'
-        and then Typ /= 'p'
-        and then Typ /= 'k'
-      then
-         return;
+      --  We also omit this test is this is a body reference for a subprogram
+      --  instantiation. In this case the reference is to the generic body,
+      --  which clearly need not be in the main unit containing the instance.
+      --  For the same reason we accept an implicit reference generated for
+      --  a default in an instance.
+
+      if not In_Extended_Main_Source_Unit (N) then
+         if Typ = 'e'
+           or else Typ = 'p'
+           or else Typ = 'i'
+           or else Typ = 'k'
+           or else (Typ = 'b' and then Is_Generic_Instance (E))
+         then
+            null;
+         else
+            return;
+         end if;
       end if;
 
       --  For reference type p, the entity must be in main source unit
@@ -308,29 +346,27 @@ package body Lib.Xref is
          return;
       end if;
 
-      --  Unless the reference is forced, we ignore references where
-      --  the reference itself does not come from Source.
+      --  Unless the reference is forced, we ignore references where the
+      --  reference itself does not come from Source.
 
       if not Force and then not Comes_From_Source (N) then
          return;
       end if;
 
-      --  Deal with setting entity as referenced, unless suppressed.
-      --  Note that we still do Set_Referenced on entities that do not
-      --  come from source. This situation arises when we have a source
-      --  reference to a derived operation, where the derived operation
-      --  itself does not come from source, but we still want to mark it
-      --  as referenced, since we really are referencing an entity in the
-      --  corresponding package (this avoids incorrect complaints that the
-      --  package contains no referenced entities).
+      --  Deal with setting entity as referenced, unless suppressed. Note that
+      --  we still do Set_Referenced on entities that do not come from source.
+      --  This situation arises when we have a source reference to a derived
+      --  operation, where the derived operation itself does not come from
+      --  source, but we still want to mark it as referenced, since we really
+      --  are referencing an entity in the corresponding package (this avoids
+      --  wrong complaints that the package contains no referenced entities).
 
       if Set_Ref then
 
-         --  For a variable that appears on the left side of an
-         --  assignment statement, we set the Referenced_As_LHS
-         --  flag since this is indeed a left hand side.
-         --  We also set the Referenced_As_LHS flag of a prefix
-         --  of selected or indexed component.
+         --  For a variable that appears on the left side of an assignment
+         --  statement, we set the Referenced_As_LHS flag since this is indeed
+         --  a left hand side. We also set the Referenced_As_LHS flag of a
+         --  prefix of selected or indexed component.
 
          if Ekind (E) = E_Variable
            and then Is_On_LHS (N)
@@ -343,11 +379,10 @@ package body Lib.Xref is
          elsif Is_Non_Significant_Pragma_Reference (N) then
             null;
 
-         --  A reference in an attribute definition clause does not
-         --  count as a reference except for the case of Address.
-         --  The reason that 'Address is an exception is that it
-         --  creates an alias through which the variable may be
-         --  referenced.
+         --  A reference in an attribute definition clause does not count as a
+         --  reference except for the case of Address. The reason that 'Address
+         --  is an exception is that it creates an alias through which the
+         --  variable may be referenced.
 
          elsif Nkind (Parent (N)) = N_Attribute_Definition_Clause
            and then Chars (Parent (N)) /= Name_Address
@@ -380,6 +415,10 @@ package body Lib.Xref is
 
          else
             Set_Referenced (E);
+
+            if Ekind (E) = E_Variable then
+               Set_Last_Assignment (E, Empty);
+            end if;
          end if;
 
          --  Check for pragma Unreferenced given and reference is within
@@ -403,12 +442,12 @@ package body Lib.Xref is
             elsif Is_On_LHS (N) then
                null;
 
-            --  For entry formals, we want to place the warning on the
-            --  corresponding entity in the accept statement. The current
-            --  scope is the body of the accept, so we find the formal
-            --  whose name matches that of the entry formal (there is no
-            --  link between the two entities, and the one in the accept
-            --  statement is only used for conformance checking).
+            --  For entry formals, we want to place the warning message on the
+            --  corresponding entity in the accept statement. The current scope
+            --  is the body of the accept, so we find the formal whose name
+            --  matches that of the entry formal (there is no link between the
+            --  two entities, and the one in the accept statement is only used
+            --  for conformance checking).
 
             elsif Ekind (Scope (E)) = E_Entry then
                declare
@@ -510,15 +549,12 @@ package body Lib.Xref is
            and then Present (Alias (E))
          then
             Ent := Alias (E);
-
-            loop
-               if Comes_From_Source (Ent) then
-                  exit;
-               elsif No (Alias (Ent)) then
+            while not Comes_From_Source (Ent) loop
+               if No (Alias (Ent)) then
                   return;
-               else
-                  Ent := Alias (Ent);
                end if;
+
+               Ent := Alias (Ent);
             end loop;
 
          --  The internally created defining entity for a child subprogram
@@ -623,7 +659,6 @@ package body Lib.Xref is
 
    begin
       Formal := First_Entity (E);
-
       while Present (Formal) loop
          if Comes_From_Source (Formal) then
             Generate_Reference (E, Formal, 'z', False);
@@ -734,9 +769,9 @@ package body Lib.Xref is
                         Right := ')';
                      end if;
 
-                  --  If non-derived array, get component type.
-                  --  Skip component type for case of String
-                  --  or Wide_String, saves worthwhile space.
+                  --  If non-derived array, get component type. Skip component
+                  --  type for case of String or Wide_String, saves worthwhile
+                  --  space.
 
                   elsif Is_Array_Type (Tref)
                     and then Tref /= Standard_String
@@ -828,7 +863,10 @@ package body Lib.Xref is
       procedure Output_Import_Export_Info (Ent : Entity_Id) is
          Language_Name : Name_Id;
          Conv          : constant Convention_Id := Convention (Ent);
+
       begin
+         --  Generate language name from convention
+
          if Conv  = Convention_C then
             Language_Name := Name_C;
 
@@ -839,7 +877,7 @@ package body Lib.Xref is
             Language_Name := Name_Ada;
 
          else
-            --  These are the only languages that GPS knows about
+            --  For the moment we ignore all other cases ???
 
             return;
          end if;
@@ -1104,6 +1142,8 @@ package body Lib.Xref is
          -- Name_Change --
          -----------------
 
+         --  Why a string comparison here??? Why not compare Name_Id values???
+
          function Name_Change (X : Entity_Id) return Boolean is
          begin
             Get_Unqualified_Name_String (Chars (X));
@@ -1358,7 +1398,6 @@ package body Lib.Xref is
                --  Special handling for abstract types and operations
 
                if Is_Abstract (XE.Ent) then
-
                   if Ctyp = 'U' then
                      Ctyp := 'x';            --  abstract procedure
 
@@ -1370,11 +1409,11 @@ package body Lib.Xref is
                   end if;
                end if;
 
-               --  Only output reference if interesting type of entity,
-               --  and suppress self references, except for bodies that
-               --  act as specs. Also suppress definitions of body formals
-               --  (we only treat these as references, and the references
-               --  were separately recorded).
+               --  Only output reference if interesting type of entity, and
+               --  suppress self references, except for bodies that act as
+               --  specs. Also suppress definitions of body formals (we only
+               --  treat these as references, and the references were
+               --  separately recorded).
 
                if Ctyp = ' '
                  or else (XE.Loc = XE.Def
@@ -1559,6 +1598,11 @@ package body Lib.Xref is
                            end if;
                         end loop;
 
+                        --  Write out the identifier by copying the exact
+                        --  source characters used in its declaration. Note
+                        --  that this means wide characters will be in their
+                        --  original encoded form.
+
                         for J in
                           Original_Location (Sloc (XE.Ent)) .. P - 1
                         loop
@@ -1628,23 +1672,24 @@ package body Lib.Xref is
                           (Int (Get_Column_Number (Sloc (Rref))));
                      end if;
 
-                     --  Indicate that the entity is in the unit
-                     --  of the current xref xection.
+                     --  Indicate that the entity is in the unit of the current
+                     --  xref xection.
 
                      Curru := Curxu;
 
-                     --  Write out information about generic parent,
-                     --  if entity is an instance.
+                     --  Write out information about generic parent, if entity
+                     --  is an instance.
 
                      if  Is_Generic_Instance (XE.Ent) then
                         declare
                            Gen_Par : constant Entity_Id :=
-                             Generic_Parent
-                               (Specification
-                                  (Unit_Declaration_Node (XE.Ent)));
-                           Loc : constant Source_Ptr := Sloc (Gen_Par);
-                           Gen_U : constant Unit_Number_Type :=
-                                     Get_Source_Unit (Loc);
+                                       Generic_Parent
+                                         (Specification
+                                            (Unit_Declaration_Node (XE.Ent)));
+                           Loc     : constant Source_Ptr := Sloc (Gen_Par);
+                           Gen_U   : constant Unit_Number_Type :=
+                                       Get_Source_Unit (Loc);
+
                         begin
                            Write_Info_Char ('[');
                            if Curru /= Gen_U then