[multiple changes]

2013-01-03  Robert Dewar  <dewar@adacore.com>

	* sem_ch8.adb, einfo.ads, einfo.adb: Minor code reorganization.

2013-01-03  Javier Miranda  <miranda@adacore.com>

	* exp_ch3.adb (Make_Controlling_Function_Wrappers): Exclude
	internal entities associated with interfaces and add minimum
	decoration to the defining entity of the generated wrapper to
	allow overriding interface primitives.
	* sem_disp.ads (Override_Dispatching_Operation): Addition of a
	new formal (Is_Wrapper).
	* sem_disp.adb (Override_Dispatching_Operation): When overriding
	interface primitives the new formal helps identifying that the
	new operation is not fully decorated.

From-SVN: r194846

9 files changed, 112 insertions, 83 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index ce761e1..56a36b1 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,19 @@
+2013-01-03  Robert Dewar  <dewar@adacore.com>
+
+	* sem_ch8.adb, einfo.ads, einfo.adb: Minor code reorganization.
+
+2013-01-03  Javier Miranda  <miranda@adacore.com>
+
+	* exp_ch3.adb (Make_Controlling_Function_Wrappers): Exclude
+	internal entities associated with interfaces and add minimum
+	decoration to the defining entity of the generated wrapper to
+	allow overriding interface primitives.
+	* sem_disp.ads (Override_Dispatching_Operation): Addition of a
+	new formal (Is_Wrapper).
+	* sem_disp.adb (Override_Dispatching_Operation): When overriding
+	interface primitives the new formal helps identifying that the
+	new operation is not fully decorated.
+
 2013-01-03  Thomas Quinot  <quinot@adacore.com>
 
 	* sem_ch7.adb, sem_ch10.adb, einfo.adb, einfo.ads, sem_ch12.adb,
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 4f57731..b4b5159 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -2175,16 +2175,16 @@ package body Einfo is
       return Flag127 (Id);
    end Is_Valued_Procedure;
 
-   function Is_Visible_Lib_Unit (Id : E) return B is
-   begin
-      return Flag116 (Id);
-   end Is_Visible_Lib_Unit;
-
    function Is_Visible_Formal (Id : E) return B is
    begin
       return Flag206 (Id);
    end Is_Visible_Formal;
 
+   function Is_Visible_Lib_Unit (Id : E) return B is
+   begin
+      return Flag116 (Id);
+   end Is_Visible_Lib_Unit;
+
    function Is_VMS_Exception (Id : E) return B is
    begin
       return Flag133 (Id);
@@ -4735,16 +4735,16 @@ package body Einfo is
       Set_Flag127 (Id, V);
    end Set_Is_Valued_Procedure;
 
-   procedure Set_Is_Visible_Lib_Unit (Id : E; V : B := True) is
-   begin
-      Set_Flag116 (Id, V);
-   end Set_Is_Visible_Lib_Unit;
-
    procedure Set_Is_Visible_Formal (Id : E; V : B := True) is
    begin
       Set_Flag206 (Id, V);
    end Set_Is_Visible_Formal;
 
+   procedure Set_Is_Visible_Lib_Unit (Id : E; V : B := True) is
+   begin
+      Set_Flag116 (Id, V);
+   end Set_Is_Visible_Lib_Unit;
+
    procedure Set_Is_VMS_Exception (Id : E; V : B := True) is
    begin
       pragma Assert (Ekind (Id) = E_Exception);
@@ -7600,8 +7600,8 @@ package body Einfo is
       W ("Is_Unsigned_Type",                Flag144 (Id));
       W ("Is_VMS_Exception",                Flag133 (Id));
       W ("Is_Valued_Procedure",             Flag127 (Id));
-      W ("Is_Visible_Lib_Unit",             Flag116 (Id));
       W ("Is_Visible_Formal",               Flag206 (Id));
+      W ("Is_Visible_Lib_Unit",             Flag116 (Id));
       W ("Is_Volatile",                     Flag16  (Id));
       W ("Itype_Printed",                   Flag202 (Id));
       W ("Kill_Elaboration_Checks",         Flag32  (Id));
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 35400cf..f640771 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -846,8 +846,9 @@ package Einfo is
 --       full details of the use of discriminals.
 
 --    Discriminal_Link (Node10)
---       Defined in discriminals (which have an Ekind of E_In_Parameter,
---       or E_Constant), points back to corresponding discriminant.
+--       Defined in E_In_Parameter or E_Constant entities. For discriminals,
+--       points back to corresponding discriminant. For other entities, must
+--       remain Empty.
 
 --    Discriminant_Checking_Func (Node20)
 --       Defined in components. Points to the defining identifier of the
@@ -2168,7 +2169,7 @@ package Einfo is
 
 --    Is_Discriminal (synthesized)
 --       Applies to all entities, true for renamings of discriminants. Such
---       entities appear as constants or in parameters.
+--       entities appear as constants or IN parameters.
 
 --    Is_Dispatch_Table_Entity (Flag234)
 --       Applies to all entities. Set to indicate to the backend that this
@@ -2856,18 +2857,18 @@ package Einfo is
 --       Defined in procedure entities. Set if an Import_Valued_Procedure
 --       or Export_Valued_Procedure pragma applies to the procedure entity.
 
---    Is_Visible_Lib_Unit (Flag116)
---       Defined in all (root or child) library unit entities. Once compiled,
---       library units remain chained to the entities in the parent scope, and
---       a separate flag must be used to indicate whether the names are visible
---       by selected notation, or not.
-
 --    Is_Visible_Formal (Flag206)
 --       Defined in all entities. Set True for instances of the formals of a
 --       formal package. Indicates that the entity must be made visible in the
 --       body of the instance, to reproduce the visibility of the generic.
 --       This simplifies visibility settings in instance bodies.
 
+--    Is_Visible_Lib_Unit (Flag116)
+--       Defined in all (root or child) library unit entities. Once compiled,
+--       library units remain chained to the entities in the parent scope, and
+--       a separate flag must be used to indicate whether the names are visible
+--       by selected notation, or not.
+
 --    Is_VMS_Exception (Flag133)
 --       Defined in all entities. Set only for exception entities where the
 --       exception was specified in an Import_Exception or Export_Exception
@@ -5091,7 +5092,7 @@ package Einfo is
    --  E_Constant
    --  E_Loop_Parameter
    --    Current_Value                       (Node9)    (always Empty)
-   --    Discriminal_Link                    (Node10)   (discriminals only)
+   --    Discriminal_Link                    (Node10)
    --    Full_View                           (Node11)
    --    Esize                               (Uint12)
    --    Extra_Accessibility                 (Node13)   (constants only)
@@ -6310,8 +6311,8 @@ package Einfo is
    function Is_Unsigned_Type                    (Id : E) return B;
    function Is_VMS_Exception                    (Id : E) return B;
    function Is_Valued_Procedure                 (Id : E) return B;
-   function Is_Visible_Lib_Unit                 (Id : E) return B;
    function Is_Visible_Formal                   (Id : E) return B;
+   function Is_Visible_Lib_Unit                 (Id : E) return B;
    function Is_Volatile                         (Id : E) return B;
    function Itype_Printed                       (Id : E) return B;
    function Kill_Elaboration_Checks             (Id : E) return B;
@@ -6908,8 +6909,8 @@ package Einfo is
    procedure Set_Is_Unsigned_Type                (Id : E; V : B := True);
    procedure Set_Is_VMS_Exception                (Id : E; V : B := True);
    procedure Set_Is_Valued_Procedure             (Id : E; V : B := True);
-   procedure Set_Is_Visible_Lib_Unit             (Id : E; V : B := True);
    procedure Set_Is_Visible_Formal               (Id : E; V : B := True);
+   procedure Set_Is_Visible_Lib_Unit             (Id : E; V : B := True);
    procedure Set_Is_Volatile                     (Id : E; V : B := True);
    procedure Set_Itype_Printed                   (Id : E; V : B := True);
    procedure Set_Kill_Elaboration_Checks         (Id : E; V : B := True);
@@ -7629,8 +7630,8 @@ package Einfo is
    pragma Inline (Is_Unsigned_Type);
    pragma Inline (Is_VMS_Exception);
    pragma Inline (Is_Valued_Procedure);
-   pragma Inline (Is_Visible_Lib_Unit);
    pragma Inline (Is_Visible_Formal);
+   pragma Inline (Is_Visible_Lib_Unit);
    pragma Inline (Itype_Printed);
    pragma Inline (Kill_Elaboration_Checks);
    pragma Inline (Kill_Range_Checks);
@@ -8035,8 +8036,8 @@ package Einfo is
    pragma Inline (Set_Is_Unsigned_Type);
    pragma Inline (Set_Is_VMS_Exception);
    pragma Inline (Set_Is_Valued_Procedure);
-   pragma Inline (Set_Is_Visible_Lib_Unit);
    pragma Inline (Set_Is_Visible_Formal);
+   pragma Inline (Set_Is_Visible_Lib_Unit);
    pragma Inline (Set_Is_Volatile);
    pragma Inline (Set_Itype_Printed);
    pragma Inline (Set_Kill_Elaboration_Checks);
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 83d0c00..15d5de0 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -8274,7 +8274,10 @@ package body Exp_Ch3 is
          --  Input attributes, since each type will have its own version of
          --  Input constructed by the expander. The test for Comes_From_Source
          --  is needed to distinguish inherited operations from renamings
-         --  (which also have Alias set).
+         --  (which also have Alias set). We exclude internal entities with
+         --  Interface_Alias to avoid generating duplicated wrappers since
+         --  the primitive which covers the interface is also available in
+         --  the list of primitive operations.
 
          --  The function may be abstract, or require_Overriding may be set
          --  for it, because tests for null extensions may already have reset
@@ -8284,6 +8287,7 @@ package body Exp_Ch3 is
 
          if Comes_From_Source (Subp)
            or else No (Alias (Subp))
+           or else Present (Interface_Alias (Subp))
            or else Ekind (Subp) /= E_Function
            or else not Has_Controlling_Result (Subp)
            or else Is_Access_Type (Etype (Subp))
@@ -8400,11 +8404,15 @@ package body Exp_Ch3 is
 
             Append_To (Body_List, Func_Body);
 
-            --  Replace the inherited function with the wrapper function
-            --  in the primitive operations list.
+            --  Replace the inherited function with the wrapper function in the
+            --  primitive operations list. We add the minimum decoration needed
+            --  to override interface primitives.
+
+            Set_Ekind (Defining_Unit_Name (Func_Spec), E_Function);
 
             Override_Dispatching_Operation
-              (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec));
+              (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec),
+               Is_Wrapper => True);
          end if;
 
       <<Next_Prim>>
diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
index 0fd690a..6f2dd2e 100644
--- a/gcc/ada/sem_ch10.adb
+++ b/gcc/ada/sem_ch10.adb
@@ -5147,9 +5147,8 @@ package body Sem_Ch10 is
 
       elsif not Is_Immediately_Visible (Uname) then
          Set_Is_Visible_Lib_Unit (Uname);
-         if not Private_Present (With_Clause)
-           or else Private_With_OK
-         then
+
+         if not Private_Present (With_Clause) or else Private_With_OK then
             Set_Is_Immediately_Visible (Uname);
          end if;
 
@@ -5177,7 +5176,7 @@ package body Sem_Ch10 is
         and then Ada_Version >= Ada_2005
       then
          declare
-            Decl1 : constant Node_Id  := Unit_Declaration_Node (P);
+            Decl1 : constant Node_Id := Unit_Declaration_Node (P);
             Decl2 : Node_Id;
             P2    : Entity_Id;
             U2    : Entity_Id;
@@ -5190,9 +5189,7 @@ package body Sem_Ch10 is
                P2 := Scope (U2);
                Decl2  := Unit_Declaration_Node (P2);
 
-               if Is_Child_Unit (U2)
-                 and then Is_Visible_Lib_Unit (U2)
-               then
+               if Is_Child_Unit (U2) and then Is_Visible_Lib_Unit (U2) then
                   if Is_Generic_Instance (P)
                     and then Nkind (Decl1) = N_Package_Declaration
                     and then Generic_Parent (Specification (Decl1)) = P2
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 9442760..bd14f37 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -1765,7 +1765,7 @@ package body Sem_Ch4 is
                    (Is_Immediately_Visible (Scope (DT))
                      or else
                        (Is_Child_Unit (Scope (DT))
-                          and then Is_Visible_Lib_Unit (Scope (DT))))
+                         and then Is_Visible_Lib_Unit (Scope (DT))))
                then
                   Set_Etype (N, Available_View (DT));
 
@@ -6320,13 +6320,12 @@ package body Sem_Ch4 is
           (Is_Immediately_Visible (Scope (Typ))
             or else
               (Is_Child_Unit (Scope (Typ))
-                 and then Is_Visible_Lib_Unit (Scope (Typ))))
+                and then Is_Visible_Lib_Unit (Scope (Typ))))
       then
          return Available_View (Typ);
       else
          return Typ;
       end if;
-
    end Process_Implicit_Dereference_Prefix;
 
    --------------------------------
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 0a046de..a3be9db 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -5144,13 +5144,12 @@ package body Sem_Ch8 is
 
             if Is_New_Candidate then
                if Is_Child_Unit (Id) or else P_Name = Standard_Standard then
-                  exit when Is_Visible_Lib_Unit (Id)
-                    or else Is_Immediately_Visible (Id);
-
+                  exit when Is_Visible_Lib_Unit (Id);
                else
-                  exit when not Is_Hidden (Id)
-                    or else Is_Immediately_Visible (Id);
+                  exit when not Is_Hidden (Id);
                end if;
+
+               exit when Is_Immediately_Visible (Id);
             end if;
 
             Id := Homonym (Id);
@@ -5329,33 +5328,34 @@ package body Sem_Ch8 is
                   --  declares the desired entity. This error can use a
                   --  specialized message.
 
-                  if In_Open_Scopes (P_Name)
-                    and then Present (Homonym (P_Name))
-                    and then Is_Compilation_Unit (Homonym (P_Name))
-                    and then
-                     (Is_Immediately_Visible (Homonym (P_Name))
-                        or else Is_Visible_Lib_Unit (Homonym (P_Name)))
-                  then
+                  if In_Open_Scopes (P_Name) then
                      declare
                         H : constant Entity_Id := Homonym (P_Name);
 
                      begin
-                        Id := First_Entity (H);
-                        while Present (Id) loop
-                           if Chars (Id) = Chars (Selector) then
-                              Error_Msg_Qual_Level := 99;
-                              Error_Msg_Name_1 := Chars (Selector);
-                              Error_Msg_NE
-                                ("% not declared in&", N, P_Name);
-                              Error_Msg_NE
-                                ("\use fully qualified name starting with"
-                                  & " Standard to make& visible", N, H);
-                              Error_Msg_Qual_Level := 0;
-                              goto Done;
-                           end if;
+                        if Present (H)
+                          and then Is_Compilation_Unit (H)
+                          and then
+                            (Is_Immediately_Visible (H)
+                              or else Is_Visible_Lib_Unit (H))
+                        then
+                           Id := First_Entity (H);
+                           while Present (Id) loop
+                              if Chars (Id) = Chars (Selector) then
+                                 Error_Msg_Qual_Level := 99;
+                                 Error_Msg_Name_1 := Chars (Selector);
+                                 Error_Msg_NE
+                                   ("% not declared in&", N, P_Name);
+                                 Error_Msg_NE
+                                   ("\use fully qualified name starting with "
+                                    & "Standard to make& visible", N, H);
+                                 Error_Msg_Qual_Level := 0;
+                                 goto Done;
+                              end if;
 
-                           Next_Entity (Id);
-                        end loop;
+                              Next_Entity (Id);
+                           end loop;
+                        end if;
 
                         --  If not found, standard error message
 
@@ -8049,9 +8049,7 @@ package body Sem_Ch8 is
       --  appear after all visible declarations in the parent entity list.
 
       while Present (Id) loop
-         if Is_Child_Unit (Id)
-           and then Is_Visible_Lib_Unit (Id)
-         then
+         if Is_Child_Unit (Id) and then Is_Visible_Lib_Unit (Id) then
             Set_Is_Potentially_Use_Visible (Id);
          end if;
 
@@ -8544,7 +8542,6 @@ package body Sem_Ch8 is
          Write_Str (" === ");
          Write_Name (Chars (E));
          Write_Eol;
-
          Next_Entity (E);
       end loop;
    end we;
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index 2e4186f..4ce0a15 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -2213,7 +2213,8 @@ package body Sem_Disp is
    procedure Override_Dispatching_Operation
      (Tagged_Type : Entity_Id;
       Prev_Op     : Entity_Id;
-      New_Op      : Entity_Id)
+      New_Op      : Entity_Id;
+      Is_Wrapper  : Boolean := False)
    is
       Elmt : Elmt_Id;
       Prim : Node_Id;
@@ -2278,7 +2279,8 @@ package body Sem_Disp is
          --  operations that it implements (for operations inherited from the
          --  parent itself, this check is made when building the derived type).
 
-         --  Note: This code is only executed in case of late overriding
+         --  Note: This code is executed with internally generated wrappers of
+         --  functions with controlling result and late overridings.
 
          Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
          while Present (Elmt) loop
@@ -2293,18 +2295,25 @@ package body Sem_Disp is
             elsif Is_Subprogram (Prim)
               and then Present (Interface_Alias (Prim))
               and then Alias (Prim) = Prev_Op
-              and then Present (Etype (New_Op))
             then
                Set_Alias (Prim, New_Op);
-               Check_Subtype_Conformant (New_Op, Prim);
-               Set_Is_Abstract_Subprogram (Prim,
-                 Is_Abstract_Subprogram (New_Op));
 
-               --  Ensure that this entity will be expanded to fill the
-               --  corresponding entry in its dispatch table.
+               --  No further decoration needed yet for internally generated
+               --  wrappers of controlling functions since (at this stage)
+               --  they are not yet decorated.
+
+               if not Is_Wrapper then
+                  Check_Subtype_Conformant (New_Op, Prim);
+
+                  Set_Is_Abstract_Subprogram (Prim,
+                    Is_Abstract_Subprogram (New_Op));
 
-               if not Is_Abstract_Subprogram (Prim) then
-                  Set_Has_Delayed_Freeze (Prim);
+                  --  Ensure that this entity will be expanded to fill the
+                  --  corresponding entry in its dispatch table.
+
+                  if not Is_Abstract_Subprogram (Prim) then
+                     Set_Has_Delayed_Freeze (Prim);
+                  end if;
                end if;
             end if;
 
diff --git a/gcc/ada/sem_disp.ads b/gcc/ada/sem_disp.ads
index c27346d..ff1ebc4 100644
--- a/gcc/ada/sem_disp.ads
+++ b/gcc/ada/sem_disp.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2012, 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- --
@@ -121,10 +121,12 @@ package Sem_Disp is
    procedure Override_Dispatching_Operation
      (Tagged_Type : Entity_Id;
       Prev_Op     : Entity_Id;
-      New_Op      : Entity_Id);
+      New_Op      : Entity_Id;
+      Is_Wrapper  : Boolean := False);
    --  Replace an implicit dispatching operation with an explicit one.
    --  Prev_Op is an inherited primitive operation which is overridden
-   --  by the explicit declaration of New_Op.
+   --  by the explicit declaration of New_Op. Is_Wrapper is True when
+   --  New_Op is an internally generated wrapper of a controlling function.
 
    procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id);
    --  If a function call is tag-indeterminate,  its controlling argument is