mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-14 21:01:22 +08:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Javier Miranda 2010-06-22 13:32:54 +00:00 committed by Arnaud Charlet
parent 9e9df9da7b
commit b81a5940b4
10 changed files with 63 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/ada/ChangeLog
View File

@ -1,3 +1,11 @@
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,

4
gcc/ada/exp_ch6.adb
View File

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

59
gcc/ada/exp_disp.adb
View File

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

10
gcc/ada/exp_dist.adb
View File

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

14
gcc/ada/lib-xref.adb
View File

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

6
gcc/ada/sem_attr.adb
View File

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

5
gcc/ada/sem_eval.adb
View File

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

4
gcc/ada/sem_prag.adb
View File

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

2
gcc/ada/sem_util.adb
View File

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

68
gcc/ada/sem_util.ads
View File

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