[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

gcc/ada/ChangeLog

+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,

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));

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);

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>>

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;
 
@@ -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

gcc/ada/sem_ch4.adb

@@ -6326,7 +6326,6 @@ package body Sem_Ch4 is
       else
          return Typ;
       end if;
-
    end Process_Implicit_Dereference_Prefix;
 
    --------------------------------

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,17 +5328,17 @@ 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
+                        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
@@ -5348,14 +5347,15 @@ package body Sem_Ch8 is
                                  Error_Msg_NE
                                    ("% not declared in&", N, P_Name);
                                  Error_Msg_NE
-                                ("\use fully qualified name starting with"
-                                  & " Standard to make& visible", N, H);
+                                   ("\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;
+                        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;

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,10 +2295,16 @@ 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);
+
+               --  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));
 
@@ -2307,6 +2315,7 @@ package body Sem_Disp is
                      Set_Has_Delayed_Freeze (Prim);
                   end if;
                end if;
+            end if;
 
             Next_Elmt (Elmt);
          end loop;

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