Skip to content

R
riscv-gcc-1
Commit cdc96e3e by Arnaud Charlet
Options

[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
parent 5cf01d62
Showing with 131 additions and 117 deletions
gcc/ada/ChangeLog
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>
* exp_ch5.adb (Expand_Iterator_Loop_Over_Array): For the case of a
......
gcc/ada/exp_ch7.adb
......@@ -1824,15 +1824,14 @@ package body Exp_Ch7 is
-- Obj : Access_Typ := Non_BIP_Function_Call'reference;
-- Obj : Access_Typ :=
-- BIP_Function_Call
-- (..., BIPaccess => null, ...)'reference;
-- BIP_Function_Call (BIPalloc => 2, ...)'reference;
elsif Is_Access_Type (Obj_Typ)
and then Needs_Finalization
(Available_View (Designated_Type (Obj_Typ)))
and then Present (Expr)
and then
(Is_Null_Access_BIP_Func_Call (Expr)
(Is_Secondary_Stack_BIP_Func_Call (Expr)
or else
(Is_Non_BIP_Func_Call (Expr)
and then not Is_Related_To_Func_Return (Obj_Id)))
......
gcc/ada/exp_util.adb
......@@ -4475,74 +4475,6 @@ package body Exp_Util is
and then Is_Library_Level_Entity (Typ);
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 --
--------------------------
......@@ -4949,6 +4881,75 @@ package body Exp_Util is
end if;
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 --
-------------------------------------
......@@ -7123,18 +7124,17 @@ package body Exp_Util is
-- Obj : Access_Typ := Non_BIP_Function_Call'reference;
--
-- Obj : Access_Typ :=
-- BIP_Function_Call
-- (..., BIPaccess => null, ...)'reference;
-- BIP_Function_Call (BIPalloc => 2, ...)'reference;
elsif Is_Access_Type (Obj_Typ)
and then Needs_Finalization
(Available_View (Designated_Type (Obj_Typ)))
and then Present (Expr)
and then
(Is_Null_Access_BIP_Func_Call (Expr)
or else
(Is_Non_BIP_Func_Call (Expr)
and then not Is_Related_To_Func_Return (Obj_Id)))
(Is_Secondary_Stack_BIP_Func_Call (Expr)
or else
(Is_Non_BIP_Func_Call (Expr)
and then not Is_Related_To_Func_Return (Obj_Id)))
then
return True;
......
gcc/ada/exp_util.ads
......@@ -548,13 +548,20 @@ package Exp_Util is
-- Return True if Typ is a library level tagged type. Currently we use
-- 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;
-- 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;
-- 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
......@@ -571,17 +578,6 @@ package Exp_Util is
-- Determine whether object Id is related to an expanded return statement.
-- 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;
-- 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
......@@ -593,6 +589,10 @@ package Exp_Util is
-- We consider that a (1 .. 2) is a renamed object since it is the prefix
-- 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
(Obj_Id : Entity_Id) return Boolean;
-- Determine whether object Obj_Id is the result of a tag-to-class-wide
......
gcc/ada/lib-xref.adb
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -161,6 +161,9 @@ package body Lib.Xref is
-- 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);
-- For a tagged type, generate implicit references to its primitive
-- 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;
-- 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 --
---------------
......@@ -373,23 +373,17 @@ package body Lib.Xref is
Set_Ref : Boolean := True;
Force : Boolean := False)
is
Nod : Node_Id;
Ref : Source_Ptr;
Def : Source_Ptr;
Ent : Entity_Id;
Actual_Typ : Character := Typ;
Ref_Scope : Entity_Id;
Actual_Typ : Character := Typ;
Call : Node_Id;
Def : Source_Ptr;
Ent : Entity_Id;
Ent_Scope : Entity_Id;
Ent_Scope_File : Unit_Number_Type;
Call : Node_Id;
Formal : Entity_Id;
-- Used for call to Find_Actual
Kind : Entity_Kind;
-- If Formal is non-Empty, then its Ekind, otherwise E_Void
Formal : Entity_Id;
Kind : Entity_Kind;
Nod : Node_Id;
Ref : Source_Ptr;
Ref_Scope : Entity_Id;
function Get_Through_Renamings (E : Entity_Id) return Entity_Id;
-- 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 (N) > No_Location
-- We ignore references from within an instance, except for default
-- subprograms, for which we generate an implicit reference.
-- Ignore references from within an instance. The only exceptions to
-- this are default subprograms, for which we generate an implicit
-- reference.
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
......@@ -1003,14 +999,14 @@ package body Lib.Xref is
Def := Original_Location (Sloc (Ent));
if Actual_Typ = 'p'
and then Is_Subprogram (N)
and then Present (Overridden_Operation (N))
and then Is_Subprogram (Nod)
and then Present (Overridden_Operation (Nod))
then
Actual_Typ := 'P';
end if;
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);
-- 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_References;
-- Start of elaboration for Lib.Xref
begin
-- Reset is necessary because Elmt_Ptr does not default to Null_Ptr,
-- because it's not an access type.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment