2009-11-30 Vincent Celier <celier@adacore.com>

	* prj-tree.ads: Minor comment updates
	* prj-tree.adb: Minor reformatting

2009-11-30  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Derive_Subprogram): Indicate that an inherited
	predefined control operation is hidden if the parent type is not
	visibly controlled.
	* sem_ch6.adb (Check_Overriding_Indicator): Do not report error if
	overridden operation is not visible, as may be the case with predefined
	control operations.
	* sem_disp.adb (Check_Dispatching_Operation): Do not emit warning on
	non-overriding control operation when type is not visibly controlled,
	if the subprogram has an explicit overriding indicator.
	* sem_util.ads, sem_util.adb (Is_Visibly_Controlled): Moved here from
	sem_disp.adb.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@154791 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 1f6be28..ee3c5e2 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,22 @@
+2009-11-30  Vincent Celier  <celier@adacore.com>
+
+       * prj-tree.ads: Minor comment updates
+       * prj-tree.adb: Minor reformatting
+
+2009-11-30  Ed Schonberg  <schonberg@adacore.com>
+
+       * sem_ch3.adb (Derive_Subprogram): Indicate that an inherited
+       predefined control operation is hidden if the parent type is not
+       visibly controlled.
+       * sem_ch6.adb (Check_Overriding_Indicator): Do not report error if
+       overridden operation is not visible, as may be the case with predefined
+       control operations.
+       * sem_disp.adb (Check_Dispatching_Operation): Do not emit warning on
+       non-overriding control operation when type is not visibly controlled,
+       if the subprogram has an explicit overriding indicator.
+       * sem_util.ads, sem_util.adb (Is_Visibly_Controlled): Moved here from
+       sem_disp.adb.
+
 2009-11-30  Emmanuel Briot  <briot@adacore.com>
 
        * prj-tree.adb (Create_Attribute): Fix handling of VMS and Windows

diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb
index b35d889..0129f1d 100644 (file)
--- a/gcc/ada/prj-tree.adb
+++ b/gcc/ada/prj-tree.adb
@@ -3027,7 +3027,7 @@ package body Prj.Tree is
       return Pack;
    end Create_Package;
 
-   -------------------
+   ----------------------
    -- Create_Attribute --
    ----------------------
 

diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads
index f794c4a..d3b86e6 100644 (file)
--- a/gcc/ada/prj-tree.ads
+++ b/gcc/ada/prj-tree.ads
@@ -408,7 +408,8 @@ package Prj.Tree is
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
    pragma Inline (First_Declarative_Item_Of);
-   --  Only valid for N_With_Clause nodes
+   --  Only valid for N_Project_Declaration, N_Case_Item and
+   --  N_Package_Declaration.
 
    function Extended_Project_Of
      (Node    : Project_Node_Id;
@@ -492,7 +493,7 @@ package Prj.Tree is
       In_Tree : Project_Node_Tree_Ref) return Name_Id;
    pragma Inline (Associative_Array_Index_Of);
    --  Only valid for N_Attribute_Declaration and N_Attribute_Reference.
-   --  Returns No_String for non associative array attributes.
+   --  Returns No_Name for non associative array attributes.
 
    function Next_Variable
      (Node    : Project_Node_Id;
@@ -573,8 +574,8 @@ package Prj.Tree is
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
    pragma Inline (First_Choice_Of);
-   --  Return the first choice in a N_Case_Item, or Empty_Node if
-   --  this is when others.
+   --  Only valid for N_Case_Item nodes. Return the first choice in a
+   --  N_Case_Item, or Empty_Node if this is when others.
 
    function Next_Case_Item
      (Node    : Project_Node_Id;
@@ -665,8 +666,11 @@ package Prj.Tree is
    --  The following procedures are part of the abstract interface of the
    --  Project File tree.
 
-   --  Each Set_* procedure is valid only for the same Project_Node_Kind
-   --  nodes as the corresponding query function above.
+   --  Foe each Set_* procedure the condition of validity is specified. If an
+   --  access function is called with invalid arguments, then exception
+   --  Assertion_Error is raised if assertions are enabled, otherwise the
+   --  behaviour is not defined and may result in a crash.
+
    --  These are very low-level, and manipulate the tree itself directly. You
    --  should look at the Create_* procedure instead if you want to use higher
    --  level constructs
@@ -676,146 +680,183 @@ package Prj.Tree is
       In_Tree : Project_Node_Tree_Ref;
       To      : Name_Id);
    pragma Inline (Set_Name_Of);
+   --  Valid for all non empty nodes.
 
    procedure Set_Kind_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Kind);
    pragma Inline (Set_Kind_Of);
+   --  Valid for all non empty nodes
 
    procedure Set_Location_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Source_Ptr);
    pragma Inline (Set_Location_Of);
+   --  Valid for all non empty nodes
 
    procedure Set_First_Comment_After
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_First_Comment_After);
+   --  Valid only for N_Comment_Zones nodes
 
    procedure Set_First_Comment_After_End
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_First_Comment_After_End);
+   --  Valid only for N_Comment_Zones nodes
 
    procedure Set_First_Comment_Before
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_First_Comment_Before);
+   --  Valid only for N_Comment_Zones nodes
 
    procedure Set_First_Comment_Before_End
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_First_Comment_Before_End);
+   --  Valid only for N_Comment_Zones nodes
 
    procedure Set_Next_Comment
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Next_Comment);
+   --  Valid only for N_Comment nodes
 
    procedure Set_Parent_Project_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
+   --  Valid only for N_Project nodes
 
    procedure Set_Project_File_Includes_Unkept_Comments
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Boolean);
+   --  Valid only for N_Project nodes
 
    procedure Set_Directory_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Path_Name_Type);
    pragma Inline (Set_Directory_Of);
+   --  Valid only for N_Project nodes
 
    procedure Set_Expression_Kind_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Variable_Kind);
    pragma Inline (Set_Expression_Kind_Of);
+   --  Only valid for N_Literal_String, N_Attribute_Declaration,
+   --  N_Variable_Declaration, N_Typed_Variable_Declaration, N_Expression,
+   --  N_Term, N_Variable_Reference or N_Attribute_Reference nodes.
 
    procedure Set_Is_Extending_All
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref);
    pragma Inline (Set_Is_Extending_All);
+   --  Only valid for N_Project and N_With_Clause
 
    procedure Set_Is_Not_Last_In_List
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref);
    pragma Inline (Set_Is_Not_Last_In_List);
+   --  Only valid for N_With_Clause
 
    procedure Set_First_Variable_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Variable_Node_Id);
    pragma Inline (Set_First_Variable_Of);
+   --  Only valid for N_Project or N_Package_Declaration nodes
 
    procedure Set_First_Package_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Package_Declaration_Id);
    pragma Inline (Set_First_Package_Of);
+   --  Only valid for N_Project nodes
 
    procedure Set_Package_Id_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Package_Node_Id);
    pragma Inline (Set_Package_Id_Of);
+   --  Only valid for N_Package_Declaration nodes
 
    procedure Set_Path_Name_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Path_Name_Type);
    pragma Inline (Set_Path_Name_Of);
+   --  Only valid for N_Project and N_With_Clause nodes
 
    procedure Set_String_Value_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Name_Id);
    pragma Inline (Set_String_Value_Of);
+   --  Only valid for N_With_Clause, N_Literal_String nodes or N_Comment.
+
+   procedure Set_Source_Index_Of
+     (Node    : Project_Node_Id;
+      In_Tree : Project_Node_Tree_Ref;
+      To      : Int);
+   pragma Inline (Set_Source_Index_Of);
+   --  Only valid for N_Literal_String and N_Attribute_Declaration nodes. For
+   --  N_Literal_String, set the source index of the litteral string. For
+   --  N_Attribute_Declaration, set the source index of the index of the
+   --  associative array element.
 
    procedure Set_First_With_Clause_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_First_With_Clause_Of);
+   --  Only valid for N_Project nodes
 
    procedure Set_Project_Declaration_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Project_Declaration_Of);
+   --  Only valid for N_Project nodes
 
    procedure Set_Project_Qualifier_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Qualifier);
    pragma Inline (Set_Project_Qualifier_Of);
+   --  Only valid for N_Project nodes
 
    procedure Set_Extending_Project_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Extending_Project_Of);
+   --  Only valid for N_Project_Declaration nodes
 
    procedure Set_First_String_Type_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_First_String_Type_Of);
+   --  Only valid for N_Project nodes
 
    procedure Set_Extended_Project_Path_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Path_Name_Type);
    pragma Inline (Set_Extended_Project_Path_Of);
+   --  Only valid for N_With_Clause nodes
 
    procedure Set_Project_Node_Of
      (Node         : Project_Node_Id;
@@ -823,185 +864,214 @@ package Prj.Tree is
       To           : Project_Node_Id;
       Limited_With : Boolean := False);
    pragma Inline (Set_Project_Node_Of);
+   --  Only valid for N_With_Clause, N_Variable_Reference and
+   --  N_Attribute_Reference nodes.
 
    procedure Set_Next_With_Clause_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Next_With_Clause_Of);
+   --  Only valid for N_With_Clause nodes
 
    procedure Set_First_Declarative_Item_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_First_Declarative_Item_Of);
+   --  Only valid for N_Project_Declaration, N_Case_Item and
+   --  N_Package_Declaration.
 
    procedure Set_Extended_Project_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Extended_Project_Of);
+   --  Only valid for N_Project_Declaration nodes
 
    procedure Set_Current_Item_Node
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Current_Item_Node);
+   --  Only valid for N_Declarative_Item nodes
 
    procedure Set_Next_Declarative_Item
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Next_Declarative_Item);
+   --  Only valid for N_Declarative_Item node
 
    procedure Set_Project_Of_Renamed_Package_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Project_Of_Renamed_Package_Of);
+   --  Only valid for N_Package_Declaration nodes.
 
    procedure Set_Next_Package_In_Project
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Next_Package_In_Project);
+   --  Only valid for N_Package_Declaration nodes
 
    procedure Set_First_Literal_String
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_First_Literal_String);
+   --  Only valid for N_String_Type_Declaration nodes
 
    procedure Set_Next_String_Type
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Next_String_Type);
+   --  Only valid for N_String_Type_Declaration nodes
 
    procedure Set_Next_Literal_String
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Next_Literal_String);
+   --  Only valid for N_Literal_String nodes
 
    procedure Set_Expression_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Expression_Of);
+   --  Only valid for N_Attribute_Declaration, N_Typed_Variable_Declaration
+   --  or N_Variable_Declaration nodes
 
    procedure Set_Associative_Project_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Associative_Project_Of);
+   --  Only valid for N_Attribute_Declaration nodes
 
    procedure Set_Associative_Package_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Associative_Package_Of);
+   --  Only valid for N_Attribute_Declaration nodes
 
    procedure Set_Associative_Array_Index_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Name_Id);
    pragma Inline (Set_Associative_Array_Index_Of);
+   --  Only valid for N_Attribute_Declaration and N_Attribute_Reference.
 
    procedure Set_Next_Variable
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Next_Variable);
+   --  Only valid for N_Typed_Variable_Declaration or N_Variable_Declaration
+   --  nodes.
 
    procedure Set_First_Term
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_First_Term);
+   --  Only valid for N_Expression nodes
 
    procedure Set_Next_Expression_In_List
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Next_Expression_In_List);
+   --  Only valid for N_Expression nodes
 
    procedure Set_Current_Term
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Current_Term);
+   --  Only valid for N_Term nodes
 
    procedure Set_Next_Term
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Next_Term);
+   --  Only valid for N_Term nodes
 
    procedure Set_First_Expression_In_List
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_First_Expression_In_List);
+   --  Only valid for N_Literal_String_List nodes
 
    procedure Set_Package_Node_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Package_Node_Of);
-
-   procedure Set_Source_Index_Of
-     (Node    : Project_Node_Id;
-      In_Tree : Project_Node_Tree_Ref;
-      To      : Int);
-   pragma Inline (Set_Source_Index_Of);
+   --  Only valid for N_Variable_Reference or N_Attribute_Reference nodes.
 
    procedure Set_String_Type_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_String_Type_Of);
+   --  Only valid for N_Variable_Reference or N_Typed_Variable_Declaration
+   --  nodes.
 
    procedure Set_External_Reference_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_External_Reference_Of);
+   --  Only valid for N_External_Value nodes
 
    procedure Set_External_Default_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_External_Default_Of);
+   --  Only valid for N_External_Value nodes
 
    procedure Set_Case_Variable_Reference_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Case_Variable_Reference_Of);
+   --  Only valid for N_Case_Construction nodes
 
    procedure Set_First_Case_Item_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_First_Case_Item_Of);
+   --  Only valid for N_Case_Construction nodes
 
    procedure Set_First_Choice_Of
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_First_Choice_Of);
+   --  Only valid for N_Case_Item nodes.
 
    procedure Set_Next_Case_Item
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Project_Node_Id);
    pragma Inline (Set_Next_Case_Item);
+   --  Only valid for N_Case_Item nodes.
 
    procedure Set_Case_Insensitive
      (Node    : Project_Node_Id;
       In_Tree : Project_Node_Tree_Ref;
       To      : Boolean);
+   --  Only valid for N_Attribute_Declaration and N_Attribute_Reference nodes
 
    -------------------------------
    -- Restricted Access Section --

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 7dd9629..a95c7fa 100644 (file)
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -12418,6 +12418,24 @@ package body Sem_Ch3 is
          Set_Convention (New_Subp, Convention (Parent_Subp));
       end if;
 
+      --  Predefined controlled operations retain their name even if the parent
+      --  is hidden (see above), but they are not primitive operations if the
+      --  ancestor is not visible, for example if the parent is a private
+      --  extension completed with a controlled extension. Note that a full
+      --  type that is controlled can break privacy: the flag Is_Controlled is
+      --  set on both views of the type.
+
+      if Is_Controlled (Parent_Type)
+        and then
+          (Chars (Parent_Subp) = Name_Initialize
+            or else Chars (Parent_Subp) = Name_Adjust
+            or else Chars (Parent_Subp) = Name_Finalize)
+        and then Is_Hidden (Parent_Subp)
+        and then not Is_Visibly_Controlled (Parent_Type)
+      then
+         Set_Is_Hidden (New_Subp);
+      end if;
+
       Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp));
       Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp));
 

diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 94ed69e..c57bb56 100644 (file)
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -4454,7 +4454,9 @@ package body Sem_Ch6 is
          end;
       end if;
 
-      if Present (Overridden_Subp) then
+      if Present (Overridden_Subp)
+        and then not Is_Hidden (Overridden_Subp)
+      then
          if Must_Not_Override (Spec) then
             Error_Msg_Sloc := Sloc (Overridden_Subp);
 

diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index 705f428..2ee5a80 100644 (file)
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -48,7 +48,6 @@ with Sem_Eval; use Sem_Eval;
 with Sem_Type; use Sem_Type;
 with Sem_Util; use Sem_Util;
 with Snames;   use Snames;
-with Stand;    use Stand;
 with Sinfo;    use Sinfo;
 with Tbuild;   use Tbuild;
 with Uintp;    use Uintp;
@@ -673,27 +672,6 @@ package body Sem_Disp is
       Has_Dispatching_Parent : Boolean := False;
       Body_Is_Last_Primitive : Boolean := False;
 
-      function Is_Visibly_Controlled (T : Entity_Id) return Boolean;
-      --  Check whether T is derived from a visibly controlled type.
-      --  This is true if the root type is declared in Ada.Finalization.
-      --  If T is derived instead from a private type whose full view
-      --  is controlled, an explicit Initialize/Adjust/Finalize subprogram
-      --  does not override the inherited one.
-
-      ---------------------------
-      -- Is_Visibly_Controlled --
-      ---------------------------
-
-      function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
-         Root : constant Entity_Id := Root_Type (T);
-      begin
-         return Chars (Scope (Root)) = Name_Finalization
-           and then Chars (Scope (Scope (Root))) = Name_Ada
-           and then Scope (Scope (Scope (Root))) = Standard_Standard;
-      end Is_Visibly_Controlled;
-
-   --  Start of processing for Check_Dispatching_Operation
-
    begin
       if Ekind (Subp) /= E_Procedure and then Ekind (Subp) /= E_Function then
          return;
@@ -1030,8 +1008,20 @@ package body Sem_Disp is
            and then not Is_Visibly_Controlled (Tagged_Type)
          then
             Set_Is_Overriding_Operation (Subp, False);
-            Error_Msg_NE
-              ("operation does not override inherited&?", Subp, Subp);
+            --  If the subprogram specification carries an overriding
+            --  indicator, no need for the warning: it is either redundant,
+            --  or else an error will be reported.
+
+            if Nkind (Parent (Subp)) = N_Procedure_Specification
+              and then
+                (Must_Override (Parent (Subp))
+                  or else Must_Not_Override (Parent (Subp)))
+            then
+               null;
+            else
+               Error_Msg_NE
+                 ("operation does not override inherited&?", Subp, Subp);
+            end if;
          else
             Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
             Set_Is_Overriding_Operation (Subp);

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index cbcbc16..48c7dff 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -7238,6 +7238,18 @@ package body Sem_Util is
       end if;
    end Is_Variable;
 
+   ---------------------------
+   -- Is_Visibly_Controlled --
+   ---------------------------
+
+   function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
+      Root : constant Entity_Id := Root_Type (T);
+   begin
+      return Chars (Scope (Root)) = Name_Finalization
+        and then Chars (Scope (Scope (Root))) = Name_Ada
+        and then Scope (Scope (Scope (Root))) = Standard_Standard;
+   end Is_Visibly_Controlled;
+
    ------------------------
    -- Is_Volatile_Object --
    ------------------------

diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 623a72b..016ff91 100644 (file)
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -812,6 +812,13 @@ package Sem_Util is
    --  the point at which Assignment_OK is checked, and True is returned
    --  for any tree thus marked.
 
+   function Is_Visibly_Controlled (T : Entity_Id) return Boolean;
+   --  Check whether T is derived from a visibly controlled type.
+   --  This is true if the root type is declared in Ada.Finalization.
+   --  If T is derived instead from a private type whose full view
+   --  is controlled, an explicit Initialize/Adjust/Finalize subprogram
+   --  does not override the inherited one.
+
    function Is_Volatile_Object (N : Node_Id) return Boolean;
    --  Determines if the given node denotes an volatile object in the sense
    --  of the legality checks described in RM C.6(12). Note that the test