git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[multiple changes] 

2012-03-30  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch7.adb (Process_Declarations): Replace
	the call to Is_Null_Access_BIP_Func_Call with
	Is_Secondary_Stack_BIP_Func_Call. Update the related comment.
	* exp_util.adb (Is_Null_Access_BIP_Func_Call): Removed.
	(Is_Secondary_Stack_BIP_Func_Call): New routine.
	(Requires_Cleanup_Actions): Replace
	the call to Is_Null_Access_BIP_Func_Call with
	Is_Secondary_Stack_BIP_Func_Call. Update the related comment.
	* exp_util.ads (Is_Null_Access_BIP_Func_Call): Removed.
	(Is_Secondary_Stack_BIP_Func_Call): New routine.

2012-03-30  Yannick Moy  <moy@adacore.com>

	* lib-xref-alfa.adb, lib-xref.adb: Code clean ups.

From-SVN: r186001
This commit is contained in:
Arnaud Charlet 2012-03-30 11:21:43 +02:00
parent 5cf01d62a8
commit cdc96e3ea6
6 changed files with 538 additions and 568 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
gcc/ada/ChangeLog
View File

@ -1,3 +1,20 @@
2012-03-30 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch7.adb (Process_Declarations): Replace
the call to Is_Null_Access_BIP_Func_Call with
Is_Secondary_Stack_BIP_Func_Call. Update the related comment.
* exp_util.adb (Is_Null_Access_BIP_Func_Call): Removed.
(Is_Secondary_Stack_BIP_Func_Call): New routine.
(Requires_Cleanup_Actions): Replace
the call to Is_Null_Access_BIP_Func_Call with
Is_Secondary_Stack_BIP_Func_Call. Update the related comment.
* exp_util.ads (Is_Null_Access_BIP_Func_Call): Removed.
(Is_Secondary_Stack_BIP_Func_Call): New routine.
2012-03-30 Yannick Moy <moy@adacore.com>
* lib-xref-alfa.adb, lib-xref.adb: Code clean ups.
2012-03-30 Gary Dismukes <dismukes@adacore.com> 2012-03-30 Gary Dismukes <dismukes@adacore.com>
* exp_ch5.adb (Expand_Iterator_Loop_Over_Array): For the case of a * exp_ch5.adb (Expand_Iterator_Loop_Over_Array): For the case of a

5
gcc/ada/exp_ch7.adb
View File

@ -1824,15 +1824,14 @@ package body Exp_Ch7 is
-- Obj : Access_Typ := Non_BIP_Function_Call'reference; -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
-- Obj : Access_Typ := -- Obj : Access_Typ :=
-- BIP_Function_Call -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
-- (..., BIPaccess => null, ...)'reference;
elsif Is_Access_Type (Obj_Typ) elsif Is_Access_Type (Obj_Typ)
and then Needs_Finalization and then Needs_Finalization
(Available_View (Designated_Type (Obj_Typ))) (Available_View (Designated_Type (Obj_Typ)))
and then Present (Expr) and then Present (Expr)
and then and then
(Is_Null_Access_BIP_Func_Call (Expr) (Is_Secondary_Stack_BIP_Func_Call (Expr)
or else or else
(Is_Non_BIP_Func_Call (Expr) (Is_Non_BIP_Func_Call (Expr)
and then not Is_Related_To_Func_Return (Obj_Id))) and then not Is_Related_To_Func_Return (Obj_Id)))

142
gcc/ada/exp_util.adb
View File

@ -4475,74 +4475,6 @@ package body Exp_Util is
and then Is_Library_Level_Entity (Typ); and then Is_Library_Level_Entity (Typ);
end Is_Library_Level_Tagged_Type; end Is_Library_Level_Tagged_Type;
----------------------------------
-- Is_Null_Access_BIP_Func_Call --
----------------------------------
function Is_Null_Access_BIP_Func_Call (Expr : Node_Id) return Boolean is
Call : Node_Id := Expr;
begin
-- Build-in-place calls usually appear in 'reference format
if Nkind (Call) = N_Reference then
Call := Prefix (Call);
end if;
if Nkind_In (Call, N_Qualified_Expression,
N_Unchecked_Type_Conversion)
then
Call := Expression (Call);
end if;
if Is_Build_In_Place_Function_Call (Call) then
declare
Access_Nam : Name_Id := No_Name;
Actual : Node_Id;
Param : Node_Id;
Formal : Node_Id;
begin
-- Examine all parameter associations of the function call
Param := First (Parameter_Associations (Call));
while Present (Param) loop
if Nkind (Param) = N_Parameter_Association
and then Nkind (Selector_Name (Param)) = N_Identifier
then
Formal := Selector_Name (Param);
Actual := Explicit_Actual_Parameter (Param);
-- Construct the name of formal BIPaccess. It is much easier
-- to extract the name of the function using an arbitrary
-- formal's scope rather than the Name field of Call.
if Access_Nam = No_Name
and then Present (Entity (Formal))
then
Access_Nam :=
New_External_Name
(Chars (Scope (Entity (Formal))),
BIP_Formal_Suffix (BIP_Object_Access));
end if;
-- A match for BIPaccess => null has been found
if Chars (Formal) = Access_Nam
and then Nkind (Actual) = N_Null
then
return True;
end if;
end if;
Next (Param);
end loop;
end;
end if;
return False;
end Is_Null_Access_BIP_Func_Call;
-------------------------- --------------------------
-- Is_Non_BIP_Func_Call -- -- Is_Non_BIP_Func_Call --
-------------------------- --------------------------
@ -4949,6 +4881,75 @@ package body Exp_Util is
end if; end if;
end Is_Renamed_Object; end Is_Renamed_Object;
--------------------------------------
-- Is_Secondary_Stack_BIP_Func_Call --
--------------------------------------
function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
Call : Node_Id := Expr;
begin
-- Build-in-place calls usually appear in 'reference format
if Nkind (Call) = N_Reference then
Call := Prefix (Call);
end if;
if Nkind_In (Call, N_Qualified_Expression,
N_Unchecked_Type_Conversion)
then
Call := Expression (Call);
end if;
if Is_Build_In_Place_Function_Call (Call) then
declare
Access_Nam : Name_Id := No_Name;
Actual : Node_Id;
Param : Node_Id;
Formal : Node_Id;
begin
-- Examine all parameter associations of the function call
Param := First (Parameter_Associations (Call));
while Present (Param) loop
if Nkind (Param) = N_Parameter_Association
and then Nkind (Selector_Name (Param)) = N_Identifier
then
Formal := Selector_Name (Param);
Actual := Explicit_Actual_Parameter (Param);
-- Construct the name of formal BIPalloc. It is much easier
-- to extract the name of the function using an arbitrary
-- formal's scope rather than the Name field of Call.
if Access_Nam = No_Name
and then Present (Entity (Formal))
then
Access_Nam :=
New_External_Name
(Chars (Scope (Entity (Formal))),
BIP_Formal_Suffix (BIP_Alloc_Form));
end if;
-- A match for BIPalloc => 2 has been found
if Chars (Formal) = Access_Nam
and then Nkind (Actual) = N_Integer_Literal
and then Intval (Actual) = Uint_2
then
return True;
end if;
end if;
Next (Param);
end loop;
end;
end if;
return False;
end Is_Secondary_Stack_BIP_Func_Call;
------------------------------------- -------------------------------------
-- Is_Tag_To_Class_Wide_Conversion -- -- Is_Tag_To_Class_Wide_Conversion --
------------------------------------- -------------------------------------
@ -7123,15 +7124,14 @@ package body Exp_Util is
-- Obj : Access_Typ := Non_BIP_Function_Call'reference; -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
-- --
-- Obj : Access_Typ := -- Obj : Access_Typ :=
-- BIP_Function_Call -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
-- (..., BIPaccess => null, ...)'reference;
elsif Is_Access_Type (Obj_Typ) elsif Is_Access_Type (Obj_Typ)
and then Needs_Finalization and then Needs_Finalization
(Available_View (Designated_Type (Obj_Typ))) (Available_View (Designated_Type (Obj_Typ)))
and then Present (Expr) and then Present (Expr)
and then and then
(Is_Null_Access_BIP_Func_Call (Expr) (Is_Secondary_Stack_BIP_Func_Call (Expr)
or else or else
(Is_Non_BIP_Func_Call (Expr) (Is_Non_BIP_Func_Call (Expr)
and then not Is_Related_To_Func_Return (Obj_Id))) and then not Is_Related_To_Func_Return (Obj_Id)))

30
gcc/ada/exp_util.ads
View File

@ -548,13 +548,20 @@ package Exp_Util is
-- Return True if Typ is a library level tagged type. Currently we use -- Return True if Typ is a library level tagged type. Currently we use
-- this information to build statically allocated dispatch tables. -- this information to build statically allocated dispatch tables.
function Is_Null_Access_BIP_Func_Call (Expr : Node_Id) return Boolean;
-- Determine whether node Expr denotes a build-in-place function call with
-- a value of "null" for extra formal BIPaccess.
function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean; function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean;
-- Determine whether node Expr denotes a non build-in-place function call -- Determine whether node Expr denotes a non build-in-place function call
function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean;
-- Node N is an object reference. This function returns True if it is
-- possible that the object may not be aligned according to the normal
-- default alignment requirement for its type (e.g. if it appears in a
-- packed record, or as part of a component that has a component clause.)
function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean;
-- Determine whether the node P is a slice of an array where the slice
-- result may cause alignment problems because it has an alignment that
-- is not compatible with the type. Return True if so.
function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean; function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean;
-- Determine whether the node P is a reference to a bit packed array, i.e. -- Determine whether the node P is a reference to a bit packed array, i.e.
-- whether the designated object is a component of a bit packed array, or a -- whether the designated object is a component of a bit packed array, or a
@ -571,17 +578,6 @@ package Exp_Util is
-- Determine whether object Id is related to an expanded return statement. -- Determine whether object Id is related to an expanded return statement.
-- The case concerned is "return Id.all;". -- The case concerned is "return Id.all;".
function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean;
-- Determine whether the node P is a slice of an array where the slice
-- result may cause alignment problems because it has an alignment that
-- is not compatible with the type. Return True if so.
function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean;
-- Node N is an object reference. This function returns True if it is
-- possible that the object may not be aligned according to the normal
-- default alignment requirement for its type (e.g. if it appears in a
-- packed record, or as part of a component that has a component clause.)
function Is_Renamed_Object (N : Node_Id) return Boolean; function Is_Renamed_Object (N : Node_Id) return Boolean;
-- Returns True if the node N is a renamed object. An expression is -- Returns True if the node N is a renamed object. An expression is
-- considered to be a renamed object if either it is the Name of an object -- considered to be a renamed object if either it is the Name of an object
@ -593,6 +589,10 @@ package Exp_Util is
-- We consider that a (1 .. 2) is a renamed object since it is the prefix -- We consider that a (1 .. 2) is a renamed object since it is the prefix
-- of the name in the renaming declaration. -- of the name in the renaming declaration.
function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean;
-- Determine whether Expr denotes a build-in-place function which returns
-- its result on the secondary stack.
function Is_Tag_To_Class_Wide_Conversion function Is_Tag_To_Class_Wide_Conversion
(Obj_Id : Entity_Id) return Boolean; (Obj_Id : Entity_Id) return Boolean;
-- Determine whether object Obj_Id is the result of a tag-to-class-wide -- Determine whether object Obj_Id is the result of a tag-to-class-wide

828
gcc/ada/lib-xref-alfa.adb
View File

File diff suppressed because it is too large Load Diff

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

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1998-2011, Free Software Foundation, Inc. -- -- Copyright (C) 1998-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -161,6 +161,9 @@ package body Lib.Xref is
-- Local Subprograms -- -- Local Subprograms --
------------------------ ------------------------
procedure Add_Entry (Key : Xref_Key; Ent_Scope_File : Unit_Number_Type);
-- Add an entry to the tables of Xref_Entries, avoiding duplicates
procedure Generate_Prim_Op_References (Typ : Entity_Id); procedure Generate_Prim_Op_References (Typ : Entity_Id);
-- For a tagged type, generate implicit references to its primitive -- For a tagged type, generate implicit references to its primitive
-- operations, for source navigation. This is done right before emitting -- operations, for source navigation. This is done right before emitting
@ -170,9 +173,6 @@ package body Lib.Xref is
function Lt (T1, T2 : Xref_Entry) return Boolean; function Lt (T1, T2 : Xref_Entry) return Boolean;
-- Order cross-references -- Order cross-references
procedure Add_Entry (Key : Xref_Key; Ent_Scope_File : Unit_Number_Type);
-- Add an entry to the tables of Xref_Entries, avoiding duplicates
--------------- ---------------
-- Add_Entry -- -- Add_Entry --
--------------- ---------------
@ -373,23 +373,17 @@ package body Lib.Xref is
Set_Ref : Boolean := True; Set_Ref : Boolean := True;
Force : Boolean := False) Force : Boolean := False)
is is
Nod : Node_Id; Actual_Typ : Character := Typ;
Ref : Source_Ptr; Call : Node_Id;
Def : Source_Ptr; Def : Source_Ptr;
Ent : Entity_Id; Ent : Entity_Id;
Actual_Typ : Character := Typ;
Ref_Scope : Entity_Id;
Ent_Scope : Entity_Id; Ent_Scope : Entity_Id;
Ent_Scope_File : Unit_Number_Type; Ent_Scope_File : Unit_Number_Type;
Call : Node_Id;
Formal : Entity_Id; Formal : Entity_Id;
-- Used for call to Find_Actual
Kind : Entity_Kind; Kind : Entity_Kind;
-- If Formal is non-Empty, then its Ekind, otherwise E_Void Nod : Node_Id;
Ref : Source_Ptr;
Ref_Scope : Entity_Id;
function Get_Through_Renamings (E : Entity_Id) return Entity_Id; function Get_Through_Renamings (E : Entity_Id) return Entity_Id;
-- Get the enclosing entity through renamings, which may come from -- Get the enclosing entity through renamings, which may come from
@ -884,11 +878,13 @@ package body Lib.Xref is
and then Sloc (E) > No_Location and then Sloc (E) > No_Location
and then Sloc (N) > No_Location and then Sloc (N) > No_Location
-- We ignore references from within an instance, except for default -- Ignore references from within an instance. The only exceptions to
-- subprograms, for which we generate an implicit reference. -- this are default subprograms, for which we generate an implicit
-- reference.
and then and then
(Instantiation_Location (Sloc (N)) = No_Location or else Typ = 'i') (Instantiation_Location (Sloc (N)) = No_Location
or else Typ = 'i')
-- Ignore dummy references -- Ignore dummy references
@ -1003,14 +999,14 @@ package body Lib.Xref is
Def := Original_Location (Sloc (Ent)); Def := Original_Location (Sloc (Ent));
if Actual_Typ = 'p' if Actual_Typ = 'p'
and then Is_Subprogram (N) and then Is_Subprogram (Nod)
and then Present (Overridden_Operation (N)) and then Present (Overridden_Operation (Nod))
then then
Actual_Typ := 'P'; Actual_Typ := 'P';
end if; end if;
if Alfa_Mode then if Alfa_Mode then
Ref_Scope := Alfa.Enclosing_Subprogram_Or_Package (N); Ref_Scope := Alfa.Enclosing_Subprogram_Or_Package (Nod);
Ent_Scope := Alfa.Enclosing_Subprogram_Or_Package (Ent); Ent_Scope := Alfa.Enclosing_Subprogram_Or_Package (Ent);
-- Since we are reaching through renamings in Alfa mode, we may -- Since we are reaching through renamings in Alfa mode, we may
@ -2434,6 +2430,8 @@ package body Lib.Xref is
end Output_Refs; end Output_Refs;
end Output_References; end Output_References;
-- Start of elaboration for Lib.Xref
begin begin
-- Reset is necessary because Elmt_Ptr does not default to Null_Ptr, -- Reset is necessary because Elmt_Ptr does not default to Null_Ptr,
-- because it's not an access type. -- because it's not an access type.