sem_prag.adb, [...]: Code cleanup...

2010-06-22  Javier Miranda  <miranda@adacore.com>

	* sem_prag.adb, sem_util.adb, sem_util.ads, sem_attr.adb, exp_ch6.adb,
	exp_disp.adb, sem_eval.adb, exp_dist.adb lib-xref.adb: Code cleanup,
	this patch replaces duplication of code that traverses the chain of
	aliased primitives by a call to routine Ultimate_Alias that
	provides this functionality.

From-SVN: r161184

gcc/ada/ChangeLog

+2010-06-22  Javier Miranda  <miranda@adacore.com>
+
+	* sem_prag.adb, sem_util.adb, sem_util.ads, sem_attr.adb, exp_ch6.adb,
+	exp_disp.adb, sem_eval.adb, exp_dist.adb lib-xref.adb: Code cleanup,
+	this patch replaces duplication of code that traverses the chain of
+	aliased primitives by a call to routine Ultimate_Alias that
+	provides this functionality.
+
 2010-06-22  Arnaud Charlet  <charlet@adacore.com>
 
 	* fmap.adb, opt.ads, osint.adb, osint.ads, output.ads, scng.adb,

gcc/ada/exp_ch6.adb

@@ -2668,9 +2668,7 @@ package body Exp_Ch6 is
          if Present (Inherited_From_Formal (Subp)) then
             Parent_Subp := Inherited_From_Formal (Subp);
          else
-            while Present (Alias (Parent_Subp)) loop
-               Parent_Subp := Alias (Parent_Subp);
-            end loop;
+            Parent_Subp := Ultimate_Alias (Parent_Subp);
          end if;
 
          --  The below setting of Entity is suspect, see F109-018 discussion???

gcc/ada/exp_disp.adb

@@ -1843,23 +1843,10 @@ package body Exp_Disp is
 
    function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean
    is
-      E : Entity_Id;
-
    begin
-      if not Is_Predefined_Dispatching_Operation (Prim)
+      return not Is_Predefined_Dispatching_Operation (Prim)
         and then Present (Alias (Prim))
-      then
-         E := Prim;
-         while Present (Alias (E)) loop
-            E := Alias (E);
-         end loop;
-
-         if Is_Predefined_Dispatching_Operation (E) then
-            return True;
-         end if;
-      end if;
-
-      return False;
+        and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim));
    end Is_Predefined_Dispatching_Alias;
 
    ---------------------------------------
@@ -3703,11 +3690,8 @@ package body Exp_Disp is
                           Alias (Prim);
 
                      else
-                        while Present (Alias (Prim)) loop
-                           Prim := Alias (Prim);
-                        end loop;
-
-                        Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
+                        Expand_Interface_Thunk
+                          (Ultimate_Alias (Prim), Thunk_Id, Thunk_Code);
 
                         if Present (Thunk_Id) then
                            Append_To (Result, Thunk_Code);
@@ -3874,12 +3858,7 @@ package body Exp_Disp is
                                (Interface_Alias (Prim)) = Iface
                   then
                      Prim_Alias := Interface_Alias (Prim);
-
-                     E := Prim;
-                     while Present (Alias (E)) loop
-                        E := Alias (E);
-                     end loop;
-
+                     E   := Ultimate_Alias (Prim);
                      Pos := UI_To_Int (DT_Position (Prim_Alias));
 
                      if Present (Prim_Table (Pos)) then
@@ -4933,9 +4912,7 @@ package body Exp_Disp is
                   Prim := Node (Prim_Elmt);
 
                   if Chars (Prim) = Name_uSize then
-                     while Present (Alias (Prim)) loop
-                        Prim := Alias (Prim);
-                     end loop;
+                     Prim := Ultimate_Alias (Prim);
 
                      if Is_Abstract_Subprogram (Prim) then
                         Append_To (TSD_Aggr_List,
@@ -5396,11 +5373,7 @@ package body Exp_Disp is
                        and then not Present (Prim_Table
                                               (UI_To_Int (DT_Position (Prim))))
                      then
-                        E := Prim;
-                        while Present (Alias (E)) loop
-                           E := Alias (E);
-                        end loop;
-
+                        E := Ultimate_Alias (Prim);
                         pragma Assert (not Is_Abstract_Subprogram (E));
                         Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
                      end if;
@@ -6121,10 +6094,7 @@ package body Exp_Disp is
 
                --  Retrieve the root of the alias chain
 
-               Prim_Als := Prim;
-               while Present (Alias (Prim_Als)) loop
-                  Prim_Als := Alias (Prim_Als);
-               end loop;
+               Prim_Als := Ultimate_Alias (Prim);
 
                --  In the case of an entry wrapper, set the entry index
 
@@ -6656,10 +6626,7 @@ package body Exp_Disp is
    begin
       --  Retrieve the original primitive operation
 
-      Prim_Op := Prim;
-      while Present (Alias (Prim_Op)) loop
-         Prim_Op := Alias (Prim_Op);
-      end loop;
+      Prim_Op := Ultimate_Alias (Prim);
 
       if Ekind (Typ) = E_Record_Type
         and then Present (Corresponding_Concurrent_Type (Typ))
@@ -7179,12 +7146,8 @@ package body Exp_Disp is
                Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
 
             elsif Is_Predefined_Dispatching_Alias (Prim) then
-               E := Alias (Prim);
-               while Present (Alias (E)) loop
-                  E := Alias (E);
-               end loop;
-
-               Set_DT_Position (Prim, Default_Prim_Op_Position (E));
+               Set_DT_Position (Prim,
+                 Default_Prim_Op_Position (Ultimate_Alias (Prim)));
 
             --  Overriding primitives of ancestor abstract interfaces
 

gcc/ada/exp_dist.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, 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- --
@@ -1346,13 +1346,7 @@ package body Exp_Dist is
                --  primitive may have been inherited, go back the alias chain
                --  until the real primitive has been found.
 
-               Current_Primitive_Alias := Current_Primitive;
-               while Present (Alias (Current_Primitive_Alias)) loop
-                  pragma Assert
-                    (Current_Primitive_Alias
-                      /= Alias (Current_Primitive_Alias));
-                  Current_Primitive_Alias := Alias (Current_Primitive_Alias);
-               end loop;
+               Current_Primitive_Alias := Ultimate_Alias (Current_Primitive);
 
                --  Copy the spec from the original declaration for the purpose
                --  of declaring an overriding subprogram: we need to replace

gcc/ada/lib-xref.adb

@@ -214,7 +214,6 @@ package body Lib.Xref is
       Base_T    : Entity_Id;
       Prim      : Elmt_Id;
       Prim_List : Elist_Id;
-      Ent       : Entity_Id;
 
    begin
       --  Handle subtypes of synchronized types
@@ -262,12 +261,8 @@ package body Lib.Xref is
          --  reference purposes (it is the original for which we want the xref
          --  and for which the comes_from_source test must be performed).
 
-         Ent := Node (Prim);
-         while Present (Alias (Ent)) loop
-            Ent := Alias (Ent);
-         end loop;
-
-         Generate_Reference (Typ, Ent, 'p', Set_Ref => False);
+         Generate_Reference
+           (Typ, Ultimate_Alias (Node (Prim)), 'p', Set_Ref => False);
          Next_Elmt (Prim);
       end loop;
    end Generate_Prim_Op_References;
@@ -1704,10 +1699,7 @@ package body Lib.Xref is
                      --  through several levels of derivation, so find the
                      --  ultimate (source) ancestor.
 
-                     Op := Alias (Old_E);
-                     while Present (Alias (Op)) loop
-                        Op := Alias (Op);
-                     end loop;
+                     Op := Ultimate_Alias (Old_E);
 
                   --  Normal case of no alias present
 

gcc/ada/sem_attr.adb

@@ -3545,13 +3545,9 @@ package body Sem_Attr is
          ----------------------
 
          procedure Must_Be_Imported (Proc_Ent : Entity_Id) is
-            Pent : Entity_Id := Proc_Ent;
+            Pent : constant Entity_Id := Ultimate_Alias (Proc_Ent);
 
          begin
-            while Present (Alias (Pent)) loop
-               Pent := Alias (Pent);
-            end loop;
-
             --  Ignore check if procedure not frozen yet (we will get
             --  another chance when the default parameter is reanalyzed)
 

gcc/ada/sem_eval.adb

@@ -1674,10 +1674,7 @@ package body Sem_Eval is
         and then Present (Alias (Entity (Name (N))))
         and then Is_Enumeration_Type (Base_Type (Typ))
       then
-         Lit := Alias (Entity (Name (N)));
-         while Present (Alias (Lit)) loop
-            Lit := Alias (Lit);
-         end loop;
+         Lit := Ultimate_Alias (Entity (Name (N)));
 
          if Ekind (Lit) = E_Enumeration_Literal then
             if Base_Type (Etype (Lit)) /= Base_Type (Typ) then

gcc/ada/sem_prag.adb

@@ -3956,9 +3956,7 @@ package body Sem_Prag is
             --  entity (if declared in the same unit) is inlined.
 
             if Is_Subprogram (Subp) then
-               while Present (Alias (Inner_Subp)) loop
-                  Inner_Subp := Alias (Inner_Subp);
-               end loop;
+               Inner_Subp := Ultimate_Alias (Inner_Subp);
 
                if In_Same_Source_Unit (Subp, Inner_Subp) then
                   Set_Inline_Flags (Inner_Subp);

gcc/ada/sem_util.adb

@@ -11128,13 +11128,13 @@ package body Sem_Util is
    --------------------
    -- Ultimate_Alias --
    --------------------
-   --  To do: add occurrences calling this new subprogram
 
    function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
       E : Entity_Id := Prim;
 
    begin
       while Present (Alias (E)) loop
+         pragma Assert (Alias (E) /= E);
          E := Alias (E);
       end loop;
 

gcc/ada/sem_util.ads

@@ -216,6 +216,7 @@ package Sem_Util is
    --  for stubbed subprograms.
 
    function Current_Entity (N : Node_Id) return Entity_Id;
+   pragma Inline (Current_Entity);
    --  Find the currently visible definition for a given identifier, that is to
    --  say the first entry in the visibility chain for the Chars of N.
 
@@ -464,6 +465,7 @@ package Sem_Util is
    --  Decl_Node into the name buffer.
 
    function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id;
+   pragma Inline (Get_Name_Entity_Id);
    --  An entity value is associated with each name in the name table. The
    --  Get_Name_Entity_Id function fetches the Entity_Id of this entity,
    --  which is the innermost visible entity with the given name. See the
@@ -696,9 +698,10 @@ package Sem_Util is
    --  it is of protected, synchronized or task kind.
 
    function Is_False (U : Uint) return Boolean;
-   --  The argument is a Uint value which is the Boolean'Pos value of a
-   --  Boolean operand (i.e. is either 0 for False, or 1 for True). This
-   --  function simply tests if it is False (i.e. zero)
+   pragma Inline (Is_False);
+   --  The argument is a Uint value which is the Boolean'Pos value of a Boolean
+   --  operand (i.e. is either 0 for False, or 1 for True). This function tests
+   --  if it is False (i.e. zero).
 
    function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean;
    --  Returns True iff the number U is a model number of the fixed-
@@ -734,11 +737,11 @@ package Sem_Util is
    --  variable and constant objects return True (compare Is_Variable).
 
    function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean;
-   --  Used to test if AV is an acceptable formal for an OUT or IN OUT
-   --  formal. Note that the Is_Variable function is not quite the right
-   --  test because this is a case in which conversions whose expression
-   --  is a variable (in the Is_Variable sense) with a non-tagged type
-   --  target are considered view conversions and hence variables.
+   --  Used to test if AV is an acceptable formal for an OUT or IN OUT formal.
+   --  Note that the Is_Variable function is not quite the right test because
+   --  this is a case in which conversions whose expression is a variable (in
+   --  the Is_Variable sense) with a non-tagged type target are considered view
+   --  conversions and hence variables.
 
    function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean;
    --  Typ is a type entity. This function returns true if this type is partly
@@ -782,6 +785,7 @@ package Sem_Util is
    --  normally such nodes represent a direct name.
 
    function Is_Statement (N : Node_Id) return Boolean;
+   pragma Inline (Is_Statement);
    --  Check if the node N is a statement node. Note that this includes
    --  the case of procedure call statements (unlike the direct use of
    --  the N_Statement_Other_Than_Procedure_Call subtype from Sinfo).
@@ -791,14 +795,15 @@ package Sem_Util is
    --  Returns True if E is a synchronized tagged type (AARM 3.9.4 (6/2))
 
    function Is_Transfer (N : Node_Id) return Boolean;
-   --  Returns True if the node N is a statement which is known to cause
-   --  an unconditional transfer of control at runtime, i.e. the following
+   --  Returns True if the node N is a statement which is known to cause an
+   --  unconditional transfer of control at runtime, i.e. the following
    --  statement definitely will not be executed.
 
    function Is_True (U : Uint) return Boolean;
-   --  The argument is a Uint value which is the Boolean'Pos value of a
-   --  Boolean operand (i.e. is either 0 for False, or 1 for True). This
-   --  function simply tests if it is True (i.e. non-zero)
+   pragma Inline (Is_True);
+   --  The argument is a Uint value which is the Boolean'Pos value of a Boolean
+   --  operand (i.e. is either 0 for False, or 1 for True). This function tests
+   --  if it is True (i.e. non-zero).
 
    function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean;
    pragma Inline (Is_Universal_Numeric_Type);
@@ -1004,7 +1009,8 @@ package Sem_Util is
 
    procedure Next_Actual (Actual_Id : in out Node_Id);
    pragma Inline (Next_Actual);
-   --  Next_Actual (N) is equivalent to N := Next_Actual (N)
+   --  Next_Actual (N) is equivalent to N := Next_Actual (N). Note that we
+   --  inline this procedural form, but not the functional form that follows.
 
    function Next_Actual (Actual_Id : Node_Id) return Node_Id;
    --  Find next actual parameter in declaration order. As described for
@@ -1172,6 +1178,7 @@ package Sem_Util is
    --  foreign convention, then we set Can_Use_Internal_Rep to False on E.
 
    procedure Set_Current_Entity (E : Entity_Id);
+   pragma Inline (Set_Current_Entity);
    --  Establish the entity E as the currently visible definition of its
    --  associated name (i.e. the Node_Id associated with its name)
 
@@ -1189,6 +1196,7 @@ package Sem_Util is
    --  can check identifier spelling style.
 
    procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id);
+   pragma Inline (Set_Name_Entity_Id);
    --  Sets the Entity_Id value associated with the given name, which is the
    --  Id of the innermost visible entity with the given name. See the body
    --  of package Sem_Ch8 for further details on the handling of visibility.
@@ -1219,6 +1227,7 @@ package Sem_Util is
    --  Set the flag Is_Transient of the current scope
 
    procedure Set_Size_Info (T1, T2 : Entity_Id);
+   pragma Inline (Set_Size_Info);
    --  Copies the Esize field and Has_Biased_Representation flag from sub(type)
    --  entity T2 to (sub)type entity T1. Also copies the Is_Unsigned_Type flag
    --  in the fixed-point and discrete cases, and also copies the alignment
@@ -1252,8 +1261,9 @@ package Sem_Util is
    --  Return the accessibility level of Typ
 
    function Ultimate_Alias (Prim : Entity_Id) return Entity_Id;
-   --  Return the last entity in the chain of aliased entities of Prim.
-   --  If Prim has no alias return Prim.
+   pragma Inline (Ultimate_Alias);
+   --  Return the last entity in the chain of aliased entities of Prim. If Prim
+   --  has no alias return Prim.
 
    function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id;
    --  Unit_Id is the simple name of a program unit, this function returns the
@@ -1266,28 +1276,18 @@ package Sem_Util is
    --  Yields Universal_Integer or Universal_Real if this is a candidate
 
    function Unqualify (Expr : Node_Id) return Node_Id;
-   --  Removes any qualifications from Expr. For example, for T1'(T2'(X)),
-   --  this returns X. If Expr is not a qualified expression, returns Expr.
+   pragma Inline (Unqualify);
+   --  Removes any qualifications from Expr. For example, for T1'(T2'(X)), this
+   --  returns X. If Expr is not a qualified expression, returns Expr.
 
    function Within_Init_Proc return Boolean;
    --  Determines if Current_Scope is within an init proc
 
    procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id);
-   --  Output error message for incorrectly typed expression. Expr is the
-   --  node for the incorrectly typed construct (Etype (Expr) is the type
-   --  found), and Expected_Type is the entity for the expected type. Note
-   --  that Expr does not have to be a subexpression, anything with an
-   --  Etype field may be used.
-
-private
-   pragma Inline (Current_Entity);
-   pragma Inline (Get_Name_Entity_Id);
-   pragma Inline (Is_False);
-   pragma Inline (Is_Statement);
-   pragma Inline (Is_True);
-   pragma Inline (Set_Current_Entity);
-   pragma Inline (Set_Name_Entity_Id);
-   pragma Inline (Set_Size_Info);
-   pragma Inline (Unqualify);
+   --  Output error message for incorrectly typed expression. Expr is the node
+   --  for the incorrectly typed construct (Etype (Expr) is the type found),
+   --  and Expected_Type is the entity for the expected type. Note that Expr
+   --  does not have to be a subexpression, anything with an Etype field may
+   --  be used.
 
 end Sem_Util;