[multiple changes]

2012-02-22  Vincent Pucci  <pucci@adacore.com>

	* rtsfind.adb (Get_Unit_Name): Ada_Numerics_Child and
	System_Dim_Child cases added.
	* rtsfind.ads: Ada_Numerics,
	Ada_Numerics_Generic_Elementary_Functions, System_Dim,
	System_Dim_Float_IO and System_Dim_Integer_IO added to the list
	of RTU_Id.  Ada_Numerics_Child and System_Dim_Child added as
	new RTU_Id subtypes.
	* sem_dim.adb (Is_Dim_IO_Package_Entity): Use of
	Rtsfind to verify the package entity is located either
	in System.Dim.Integer_IO or in System.Dim.Float_IO.
	(Is_Dim_IO_Package_Instantiation): Minor
	changes.  (Is_Elementary_Function_Call): Removed.
	(Is_Elementary_Function_Entity): New routine.
	(Is_Procedure_Put_Call): Is_Dim_IO_Package_Entity call added.
	* snames.ads-tmpl: Name_Dim and Name_Generic_Elementary_Functions
	removed.

2012-02-22  Vincent Pucci  <pucci@adacore.com>

	* sem_prag.adb: Minor reformatting.

2012-02-22  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Find_Type_Name): When analyzing a private type
	declaration that is the completion of a tagged incomplete type, do
	not associate the class-wide type already created with the private
	type to prevent order-of-elaboration issues in the back-end.
	* exp_disp.adb (Find_Specific_Type): Find specific type of
	a class-wide type, and handle the case of an incomplete type
	coming	either from a limited_with clause or from an incomplete
	type declaration. Used when expanding a dispatchin call and
	generating tag checks (minor refactoring).

From-SVN: r184473

gcc/ada/ChangeLog

@@ -1,3 +1,38 @@
+2012-02-22  Vincent Pucci  <pucci@adacore.com>
+
+	* rtsfind.adb (Get_Unit_Name): Ada_Numerics_Child and
+	System_Dim_Child cases added.
+	* rtsfind.ads: Ada_Numerics,
+	Ada_Numerics_Generic_Elementary_Functions, System_Dim,
+	System_Dim_Float_IO and System_Dim_Integer_IO added to the list
+	of RTU_Id.  Ada_Numerics_Child and System_Dim_Child added as
+	new RTU_Id subtypes.
+	* sem_dim.adb (Is_Dim_IO_Package_Entity): Use of
+	Rtsfind to verify the package entity is located either
+	in System.Dim.Integer_IO or in System.Dim.Float_IO.
+	(Is_Dim_IO_Package_Instantiation): Minor
+	changes.  (Is_Elementary_Function_Call): Removed.
+	(Is_Elementary_Function_Entity): New routine.
+	(Is_Procedure_Put_Call): Is_Dim_IO_Package_Entity call added.
+	* snames.ads-tmpl: Name_Dim and Name_Generic_Elementary_Functions
+	removed.
+
+2012-02-22  Vincent Pucci  <pucci@adacore.com>
+
+	* sem_prag.adb: Minor reformatting.
+
+2012-02-22  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch3.adb (Find_Type_Name): When analyzing a private type
+	declaration that is the completion of a tagged incomplete type, do
+	not associate the class-wide type already created with the private
+	type to prevent order-of-elaboration issues in the back-end.
+	* exp_disp.adb (Find_Specific_Type): Find specific type of
+	a class-wide type, and handle the case of an incomplete type
+	coming	either from a limited_with clause or from an incomplete
+	type declaration. Used when expanding a dispatchin call and
+	generating tag checks (minor refactoring).
+
 2012-02-22  Robert Dewar  <dewar@adacore.com>
 
 	* exp_ch5.adb: Add comment.

gcc/ada/exp_disp.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2011, 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- --
@@ -75,6 +75,11 @@ package body Exp_Disp is
    --  Ada 2005 (AI-251): Returns the fixed position in the dispatch table
    --  of the default primitive operations.
 
+   function Find_Specific_Type (CW : Entity_Id) return Entity_Id;
+   --  Find specific type of a class-wide type, and handle the case of an
+   --  incomplete type coming  either from a limited_with clause or from an
+   --  incomplete type declaration.
+
    function Has_DT (Typ : Entity_Id) return Boolean;
    pragma Inline (Has_DT);
    --  Returns true if we generate a dispatch table for tagged type Typ
@@ -178,11 +183,7 @@ package body Exp_Disp is
          CW_Typ := Class_Wide_Type (Ctrl_Typ);
       end if;
 
-      Typ := Root_Type (CW_Typ);
+      Typ := Find_Specific_Type (CW_Typ);
-
-      if Ekind (Typ) = E_Incomplete_Type then
-         Typ := Non_Limited_View (Typ);
-      end if;
 
       if not Is_Limited_Type (Typ) then
          Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
@@ -746,11 +747,7 @@ package body Exp_Disp is
          CW_Typ := Class_Wide_Type (Ctrl_Typ);
       end if;
 
-      Typ := Root_Type (CW_Typ);
+      Typ := Find_Specific_Type (CW_Typ);
-
-      if Ekind (Typ) = E_Incomplete_Type then
-         Typ := Non_Limited_View (Typ);
-      end if;
 
       if not Is_Limited_Type (Typ) then
          Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
@@ -1884,6 +1881,25 @@ package body Exp_Disp is
       end if;
    end Expand_Interface_Thunk;
 
+   ------------------------
+   -- Find_Specific_Type --
+   ------------------------
+
+   function Find_Specific_Type (CW : Entity_Id) return Entity_Id is
+      Typ : Entity_Id := Root_Type (CW);
+
+   begin
+      if Ekind (Typ) = E_Incomplete_Type then
+         if From_With_Type (Typ) then
+            Typ := Non_Limited_View (Typ);
+         else
+            Typ := Full_View (Typ);
+         end if;
+      end if;
+
+      return Typ;
+   end Find_Specific_Type;
+
    --------------------------
    -- Has_CPP_Constructors --
    --------------------------

gcc/ada/rtsfind.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2011, 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- --
@@ -313,6 +313,9 @@ package body Rtsfind is
          elsif U_Id in Ada_Interrupts_Child then
             Name_Buffer (15) := '.';
 
+         elsif U_Id in Ada_Numerics_Child then
+            Name_Buffer (13) := '.';
+
          elsif U_Id in Ada_Real_Time_Child then
             Name_Buffer (14) := '.';
 
@@ -338,6 +341,10 @@ package body Rtsfind is
       elsif U_Id in System_Child then
          Name_Buffer (7) := '.';
 
+         if U_Id in System_Dim_Child then
+            Name_Buffer (11) := '.';
+         end if;
+
          if U_Id in System_Multiprocessors_Child then
             Name_Buffer (23) := '.';
          end if;

gcc/ada/rtsfind.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2011, 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- --
@@ -125,6 +125,7 @@ package Rtsfind is
       Ada_Exceptions,
       Ada_Finalization,
       Ada_Interrupts,
+      Ada_Numerics,
       Ada_Real_Time,
       Ada_Streams,
       Ada_Strings,
@@ -144,6 +145,10 @@ package Rtsfind is
 
       Ada_Interrupts_Names,
 
+      --  Children of Ada.Numerics
+
+      Ada_Numerics_Generic_Elementary_Functions,
+
       --  Children of Ada.Real_Time
 
       Ada_Real_Time_Delays,
@@ -223,6 +228,7 @@ package Rtsfind is
       System_Concat_7,
       System_Concat_8,
       System_Concat_9,
+      System_Dim,
       System_DSA_Services,
       System_DSA_Types,
       System_Exception_Table,
@@ -372,6 +378,11 @@ package Rtsfind is
       System_WWd_Enum,
       System_WWd_Wchar,
 
+      --  Children of System.Dim
+
+      System_Dim_Float_IO,
+      System_Dim_Integer_IO,
+
       --  Children of System.Multiprocessors
 
       System_Multiprocessors_Dispatching_Domains,
@@ -413,6 +424,11 @@ package Rtsfind is
      Ada_Interrupts_Names .. Ada_Interrupts_Names;
    --  Range of values for children of Ada.Interrupts
 
+   subtype Ada_Numerics_Child is Ada_Child
+     range Ada_Numerics_Generic_Elementary_Functions ..
+           Ada_Numerics_Generic_Elementary_Functions;
+   --  Range of values for children of Ada.Numerics
+
    subtype Ada_Real_Time_Child is Ada_Child
      range Ada_Real_Time_Delays .. Ada_Real_Time_Timing_Events;
    --  Range of values for children of Ada.Real_Time
@@ -445,6 +461,10 @@ package Rtsfind is
      range System_Address_Image .. System_Tasking_Stages;
    --  Range of values for children or grandchildren of System
 
+   subtype System_Dim_Child is RTU_Id
+     range System_Dim_Float_IO .. System_Dim_Integer_IO;
+   --  Range of values for children of System.Dim
+
    subtype System_Multiprocessors_Child is RTU_Id
      range System_Multiprocessors_Dispatching_Domains ..
        System_Multiprocessors_Dispatching_Domains;

gcc/ada/sem_ch3.adb

@@ -14968,7 +14968,15 @@ package body Sem_Ch3 is
             then
                Set_Ekind (Id, Ekind (Prev));         --  will be reset later
                Set_Class_Wide_Type (Id, Class_Wide_Type (Prev));
-               Set_Etype (Class_Wide_Type (Id), Id);
+
+               --  If the incomplete type is completed by a private declaration
+               --  the class-wide type remains associated with the incomplete
+               --  type, to prevent order-of-elaboration issues in gigi, else
+               --  we associate the class-wide type with the known full view.
+
+               if Nkind (N) /= N_Private_Type_Declaration then
+                  Set_Etype (Class_Wide_Type (Id), Id);
+               end if;
             end if;
 
          --  Case of full declaration of private type

gcc/ada/sem_dim.adb

@@ -36,7 +36,6 @@ with Rtsfind;  use Rtsfind;
 with Sem;      use Sem;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
-with Sem_Util; use Sem_Util;
 with Sinfo;    use Sinfo;
 with Snames;   use Snames;
 with Stand;    use Stand;
@@ -1359,94 +1358,105 @@ package body Sem_Dim is
    -- Analyze_Dimension_Function_Call --
    -------------------------------------
 
+   --  Propagate the dimensions from the returned type to the call node. Note
+   --  that there is a special treatment for elementary function calls. Indeed
+   --  for Sqrt call, the resulting dimensions equal to half the dimensions of
+   --  the actual, and for other elementary calls, this routine check that
+   --  every actuals are dimensionless.
+
    procedure Analyze_Dimension_Function_Call (N : Node_Id) is
-      Name_Call      : constant Node_Id := Name (N);
       Actuals        : constant List_Id := Parameter_Associations (N);
+      Name_Call      : constant Node_Id := Name (N);
       Actual         : Node_Id;
       Dims_Of_Actual : Dimension_Type;
       Dims_Of_Call   : Dimension_Type;
+      Ent            : Entity_Id;
 
-      function Is_Elementary_Function_Call return Boolean;
+      function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean;
-      --  Return True if the call is a call of an elementary function (see
+      --  Given E the original subprogram entity, return True if the call is a
+      --  an elementary function call (see
       --  Ada.Numerics.Generic_Elementary_Functions).
 
-      ---------------------------------
+      -----------------------------------
-      -- Is_Elementary_Function_Call --
+      -- Is_Elementary_Function_Entity --
-      ---------------------------------
+      -----------------------------------
 
-      function Is_Elementary_Function_Call return Boolean is
+      function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean is
-         Ent : Entity_Id;
+         Loc : constant Source_Ptr := Sloc (E);
 
       begin
-         if Is_Entity_Name (Name_Call) then
+         --  Check the function entity is located in
-            Ent := Entity (Name_Call);
+         --  Ada.Numerics.Generic_Elementary_Functions.
 
-            --  Check the procedure is defined in an instantiation of a generic
+         return
-            --  package.
+           Loc > No_Location
-
+             and then
-            if Is_Generic_Instance (Scope (Ent)) then
+               Is_RTU
-               Ent := Cunit_Entity (Get_Source_Unit (Ent));
+                (Cunit_Entity (Get_Source_Unit (Loc)),
-
+                 Ada_Numerics_Generic_Elementary_Functions);
-               --  Check the name of the generic package is
+      end Is_Elementary_Function_Entity;
-               --  Generic_Elementary_Functions
-
-               return
-                 Is_Library_Level_Entity (Ent)
-                   and then Chars (Ent) = Name_Generic_Elementary_Functions;
-            end if;
-         end if;
-
-         return False;
-      end Is_Elementary_Function_Call;
 
    --  Start of processing for Analyze_Dimension_Function_Call
 
    begin
-      --  Elementary function case
+      --  Look for elementary function call
 
-      if Is_Elementary_Function_Call then
+      if Is_Entity_Name (Name_Call) then
+         Ent := Entity (Name_Call);
+
+         --  Get the original subprogram entity following the renaming chain
+
+         if Present (Alias (Ent)) then
+            Ent := Alias (Ent);
+         end if;
+
+         --  Elementary function case
+
+         if Is_Elementary_Function_Entity (Ent) then
 
          --  Sqrt function call case
 
-         if Chars (Name_Call) = Name_Sqrt then
+            if Chars (Ent) = Name_Sqrt then
-            Dims_Of_Call := Dimensions_Of (First (Actuals));
+               Dims_Of_Call := Dimensions_Of (First (Actuals));
 
-            if Exists (Dims_Of_Call) then
+               if Exists (Dims_Of_Call) then
-               for Position in Dims_Of_Call'Range loop
+                  for Position in Dims_Of_Call'Range loop
-                  Dims_Of_Call (Position) :=
+                     Dims_Of_Call (Position) :=
-                    Dims_Of_Call (Position) * Rational'(Numerator =>   1,
+                       Dims_Of_Call (Position) * Rational'(Numerator =>   1,
                                                         Denominator => 2);
-               end loop;
+                  end loop;
 
-               Set_Dimensions (N, Dims_Of_Call);
+                  Set_Dimensions (N, Dims_Of_Call);
-            end if;
-
-         --  All other functions in Ada.Numerics.Generic_Elementary_Functions
-         --  case. Note that all parameters here should be dimensionless.
-
-         else
-            Actual := First (Actuals);
-            while Present (Actual) loop
-               Dims_Of_Actual := Dimensions_Of (Actual);
-
-               if Exists (Dims_Of_Actual) then
-                  Error_Msg_NE ("parameter should be dimensionless for " &
-                                "elementary function&",
-                                Actual,
-                                Name_Call);
-                  Error_Msg_N ("\parameter " & Dimensions_Msg_Of (Actual),
-                               Actual);
                end if;
 
-               Next (Actual);
+            --  All other elementary functions case. Note that every actual
-            end loop;
+            --  here should be dimensionless.
+
+            else
+               Actual := First (Actuals);
+               while Present (Actual) loop
+                  Dims_Of_Actual := Dimensions_Of (Actual);
+
+                  if Exists (Dims_Of_Actual) then
+                     Error_Msg_NE ("parameter should be dimensionless for " &
+                                   "elementary function&",
+                                   Actual,
+                                   Name_Call);
+                     Error_Msg_N ("\parameter " & Dimensions_Msg_Of (Actual),
+                                  Actual);
+                  end if;
+
+                  Next (Actual);
+               end loop;
+            end if;
+
+            return;
          end if;
-
-      --  Other case
-
-      else
-         Analyze_Dimension_Has_Etype (N);
       end if;
+
+      --  Other cases
+
+      Analyze_Dimension_Has_Etype (N);
    end Analyze_Dimension_Function_Call;
 
    ---------------------------------
@@ -2226,28 +2236,31 @@ package body Sem_Dim is
 
       function Is_Procedure_Put_Call return Boolean is
          Ent : Entity_Id;
+         Loc : Source_Ptr;
 
       begin
-         --  There are three different Put routine in each generic package
+         --  There are three different Put routines in each generic dim IO
-         --  Check that the current procedure call is one of them
+         --  package. Verify the current procedure call is one of them.
 
          if Is_Entity_Name (Name_Call) then
             Ent := Entity (Name_Call);
 
-            --  Check that the name of the procedure is Put
+            --  Get the original subprogram entity following the renaming chain
-            --  Check the procedure is defined in an instantiation of a
-            --  generic package.
 
-            if Chars (Name_Call) = Name_Put
+            if Present (Alias (Ent)) then
-              and then Is_Generic_Instance (Scope (Ent))
+               Ent := Alias (Ent);
-            then
-               Ent := Cunit_Entity (Get_Source_Unit (Ent));
-
-               --  Verify that the generic package is either
-               --  System.Dim.Float_IO or System.Dim.Integer_IO.
-
-               return Is_Dim_IO_Package_Entity (Ent);
             end if;
+
+            Loc := Sloc (Ent);
+
+            --  Check the name of the entity subprogram is Put and verify this
+            --  entity is located in either System.Dim.Float_IO or
+            --  System.Dim.Integer_IO.
+
+            return Chars (Ent) = Name_Put
+              and then Loc > No_Location
+              and then Is_Dim_IO_Package_Entity
+                         (Cunit_Entity (Get_Source_Unit (Loc)));
          end if;
 
          return False;
@@ -2499,22 +2512,14 @@ package body Sem_Dim is
    -- Is_Dim_IO_Package_Entity --
    ------------------------------
 
-   --  Why all this comparison of names, why not use Is_RTE and Is_RTU ???
-
    function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean is
    begin
-      --  Check the package entity is standard and its scope is either
+      --  Check the package entity corresponds to System.Dim.Float_IO or
-      --  System.Dim.Float_IO or System.Dim.Integer_IO.
+      --  System.Dim.Integer_IO.
 
-      if Is_Library_Level_Entity (E)
+      return
-        and then (Chars (E) = Name_Float_IO
+        Is_RTU (E, System_Dim_Float_IO)
-                    or else Chars (E) = Name_Integer_IO)
+          or Is_RTU (E, System_Dim_Integer_IO);
-      then
-         return Chars (Scope (E)) = Name_Dim
-           and Chars (Scope (Scope (E))) = Name_System;
-      end if;
-
-      return False;
    end Is_Dim_IO_Package_Entity;
 
    -------------------------------------
@@ -2523,19 +2528,14 @@ package body Sem_Dim is
 
    function Is_Dim_IO_Package_Instantiation (N : Node_Id) return Boolean is
       Gen_Id : constant Node_Id := Name (N);
-      Ent    : Entity_Id;
 
    begin
-      if Is_Entity_Name (Gen_Id) then
+      --  Check that the instantiated package is either System.Dim.Float_IO
-         Ent := Entity (Gen_Id);
+      --  or System.Dim.Integer_IO.
 
-         --  Verify that the instantiated package is either System.Dim.Float_IO
+      return
-         --  or System.Dim.Integer_IO.
+        Is_Entity_Name (Gen_Id)
-
+          and then Is_Dim_IO_Package_Entity (Entity (Gen_Id));
-         return Is_Dim_IO_Package_Entity (Ent);
-      end if;
-
-      return False;
    end Is_Dim_IO_Package_Instantiation;
 
    ----------------

gcc/ada/sem_prag.adb

@@ -14970,14 +14970,15 @@ package body Sem_Prag is
       --  Follow subprogram renaming chain
 
       Result := Def_Id;
-      while Is_Subprogram (Result)
+
+      if Is_Subprogram (Result)
         and then
           Nkind (Parent (Declaration_Node (Result))) =
                                          N_Subprogram_Renaming_Declaration
         and then Present (Alias (Result))
-      loop
+      then
          Result := Alias (Result);
-      end loop;
+      end if;
 
       return Result;
    end Get_Base_Subprogram;

gcc/ada/snames.ads-tmpl

@@ -225,8 +225,6 @@ package Snames is
    --  Names used by the analyzer and expander for aspect Dimension and
    --  Dimension_System to deal with Sqrt and IO routines.
 
-   Name_Dim                          : constant Name_Id := N + $; -- Ada 12
-   Name_Generic_Elementary_Functions : constant Name_Id := N + $; -- Ada 12
    Name_Item                         : constant Name_Id := N + $; -- Ada 12
    Name_Sqrt                         : constant Name_Id := N + $; -- Ada 12
    Name_Symbols                      : constant Name_Id := N + $; -- Ada 12