Skip to content

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

[multiple changes] 

2012-04-02  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch7.adb (Process_Declarations): Detect a case where
	a source object was initialized by another source object,
	but the expression was rewritten as a class-wide conversion
	of Ada.Tags.Displace.
	* exp_util.adb (Initialized_By_Ctrl_Function): Removed.
	(Is_Controlled_Function_Call): New routine.
	(Is_Displacement_Of_Ctrl_Function_Result): Removed.
	(Is_Displacement_Of_Object_Or_Function_Result): New routine.
	(Is_Source_Object): New routine.
	(Requires_Cleanup_Actions): Detect a case where a source object was
	initialized by another source object, but the expression was rewritten
	as a class-wide conversion of Ada.Tags.Displace.
	* exp_util.ads (Is_Displacement_Of_Ctrl_Function_Result): Removed.
	(Is_Displacement_Of_Object_Or_Function_Result): New routine.

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

	* sem_res.adb (Resolve_Call): A call to an expression function
	does not freeze if it appears in a different scope from the
	expression function itself. Such calls appear in the generated
	bodies of other expression functions, or in pre/postconditions
	of subsequent subprograms.

From-SVN: r186071
parent e228f7ee
Showing with 113 additions and 44 deletions
gcc/ada/ChangeLog
2012-04-02 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch7.adb (Process_Declarations): Detect a case where
a source object was initialized by another source object,
but the expression was rewritten as a class-wide conversion
of Ada.Tags.Displace.
* exp_util.adb (Initialized_By_Ctrl_Function): Removed.
(Is_Controlled_Function_Call): New routine.
(Is_Displacement_Of_Ctrl_Function_Result): Removed.
(Is_Displacement_Of_Object_Or_Function_Result): New routine.
(Is_Source_Object): New routine.
(Requires_Cleanup_Actions): Detect a case where a source object was
initialized by another source object, but the expression was rewritten
as a class-wide conversion of Ada.Tags.Displace.
* exp_util.ads (Is_Displacement_Of_Ctrl_Function_Result): Removed.
(Is_Displacement_Of_Object_Or_Function_Result): New routine.
2012-04-02 Ed Schonberg <schonberg@adacore.com>
* sem_res.adb (Resolve_Call): A call to an expression function
does not freeze if it appears in a different scope from the
expression function itself. Such calls appear in the generated
bodies of other expression functions, or in pre/postconditions
of subsequent subprograms.
2012-04-02 Yannick Moy <moy@adacore.com>
* lib-xref-alfa.adb: Code clean up.
......
gcc/ada/exp_ch7.adb
......@@ -1917,16 +1917,17 @@ package body Exp_Ch7 is
Processing_Actions (Has_No_Init => True);
-- Detect a case where a source object has been initialized by
-- a controlled function call which was later rewritten as a
-- class-wide conversion of Ada.Tags.Displace.
-- a controlled function call or another object which was later
-- rewritten as a class-wide conversion of Ada.Tags.Displace.
-- Obj : Class_Wide_Type := Function_Call (...);
-- Obj1 : CW_Type := Src_Obj;
-- Obj2 : CW_Type := Function_Call (...);
-- Temp : ... := Function_Call (...)'reference;
-- Obj : Class_Wide_Type renames
-- (... Ada.Tags.Displace (Temp));
-- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
-- Tmp : ... := Function_Call (...)'reference;
-- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
elsif Is_Displacement_Of_Ctrl_Function_Result (Obj_Id) then
elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
Processing_Actions (Has_No_Init => True);
end if;
......
gcc/ada/exp_util.adb
......@@ -3940,27 +3940,30 @@ package body Exp_Util is
return True;
end Is_All_Null_Statements;
---------------------------------------------
-- Is_Displacement_Of_Ctrl_Function_Result --
---------------------------------------------
--------------------------------------------------
-- Is_Displacement_Of_Object_Or_Function_Result --
--------------------------------------------------
function Is_Displacement_Of_Ctrl_Function_Result
function Is_Displacement_Of_Object_Or_Function_Result
(Obj_Id : Entity_Id) return Boolean
is
function Initialized_By_Ctrl_Function (N : Node_Id) return Boolean;
-- Determine whether object declaration N is initialized by a controlled
-- function call.
function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
-- Determine whether a particular node denotes a controlled function
-- call.
function Is_Displace_Call (N : Node_Id) return Boolean;
-- Determine whether a particular node is a call to Ada.Tags.Displace.
-- The call might be nested within other actions such as conversions.
----------------------------------
-- Initialized_By_Ctrl_Function --
----------------------------------
function Is_Source_Object (N : Node_Id) return Boolean;
-- Determine whether a particular node denotes a source object
---------------------------------
-- Is_Controlled_Function_Call --
---------------------------------
function Initialized_By_Ctrl_Function (N : Node_Id) return Boolean is
Expr : Node_Id := Original_Node (Expression (N));
function Is_Controlled_Function_Call (N : Node_Id) return Boolean is
Expr : Node_Id := Original_Node (N);
begin
if Nkind (Expr) = N_Function_Call then
......@@ -3977,7 +3980,7 @@ package body Exp_Util is
Nkind_In (Expr, N_Expanded_Name, N_Identifier)
and then Ekind (Entity (Expr)) = E_Function
and then Needs_Finalization (Etype (Entity (Expr)));
end Initialized_By_Ctrl_Function;
end Is_Controlled_Function_Call;
----------------------
-- Is_Displace_Call --
......@@ -4004,39 +4007,66 @@ package body Exp_Util is
end loop;
return
Nkind (Call) = N_Function_Call
Present (Call)
and then Nkind (Call) = N_Function_Call
and then Is_RTE (Entity (Name (Call)), RE_Displace);
end Is_Displace_Call;
----------------------
-- Is_Source_Object --
----------------------
function Is_Source_Object (N : Node_Id) return Boolean is
begin
return
Present (N)
and then Nkind (N) in N_Has_Entity
and then Is_Object (Entity (N))
and then Comes_From_Source (N);
end Is_Source_Object;
-- Local variables
Decl : constant Node_Id := Parent (Obj_Id);
Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
Orig_Decl : constant Node_Id := Original_Node (Decl);
-- Start of processing for Is_Displacement_Of_Ctrl_Function_Result
-- Start of processing for Is_Displacement_Of_Object_Or_Function_Result
begin
-- Detect the following case:
-- Case 1:
-- Obj : Class_Wide_Type := Function_Call (...);
-- Obj : CW_Type := Function_Call (...);
-- which is rewritten into:
-- rewritten into:
-- Temp : ... := Function_Call (...)'reference;
-- Obj : Class_Wide_Type renames (... Ada.Tags.Displace (Temp));
-- Tmp : ... := Function_Call (...)'reference;
-- Obj : CW_Type renames (... Ada.Tags.Displace (Tmp));
-- when the return type of the function and the class-wide type require
-- where the return type of the function and the class-wide type require
-- dispatch table pointer displacement.
-- Case 2:
-- Obj : CW_Type := Src_Obj;
-- rewritten into:
-- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
-- where the type of the source object and the class-wide type require
-- dispatch table pointer displacement.
return
Nkind (Decl) = N_Object_Renaming_Declaration
and then Nkind (Orig_Decl) = N_Object_Declaration
and then Comes_From_Source (Orig_Decl)
and then Initialized_By_Ctrl_Function (Orig_Decl)
and then Is_Class_Wide_Type (Obj_Typ)
and then Is_Displace_Call (Renamed_Object (Obj_Id));
end Is_Displacement_Of_Ctrl_Function_Result;
and then Is_Displace_Call (Renamed_Object (Obj_Id))
and then
(Is_Controlled_Function_Call (Expression (Orig_Decl))
or else Is_Source_Object (Expression (Orig_Decl)));
end Is_Displacement_Of_Object_Or_Function_Result;
------------------------------
-- Is_Finalizable_Transient --
......@@ -7189,17 +7219,18 @@ package body Exp_Util is
then
return True;
-- Detect a case where a source object has been initialized by a
-- controlled function call which was later rewritten as a class-
-- wide conversion of Ada.Tags.Displace.
-- Detect a case where a source object has been initialized by
-- a controlled function call or another object which was later
-- rewritten as a class-wide conversion of Ada.Tags.Displace.
-- Obj : Class_Wide_Type := Function_Call (...);
-- Obj1 : CW_Type := Src_Obj;
-- Obj2 : CW_Type := Function_Call (...);
-- Temp : ... := Function_Call (...)'reference;
-- Obj : Class_Wide_Type renames
-- (... Ada.Tags.Displace (Temp));
-- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
-- Tmp : ... := Function_Call (...)'reference;
-- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
elsif Is_Displacement_Of_Ctrl_Function_Result (Obj_Id) then
elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
return True;
end if;
......
gcc/ada/exp_util.ads
......@@ -521,11 +521,12 @@ package Exp_Util is
-- False otherwise. True for an empty list. It is an error to call this
-- routine with No_List as the argument.
function Is_Displacement_Of_Ctrl_Function_Result
function Is_Displacement_Of_Object_Or_Function_Result
(Obj_Id : Entity_Id) return Boolean;
-- Determine whether Obj_Id is a source object that has been initialized by
-- a controlled function call later rewritten as a class-wide conversion of
-- Ada.Tags.Displace.
-- Determine whether Obj_Id is a source entity that has been initialized by
-- either a controlled function call or the assignment of another source
-- object. In both cases the initialization expression is rewritten as a
-- class-wide conversion of Ada.Tags.Displace.
function Is_Finalizable_Transient
(Decl : Node_Id;
......
gcc/ada/sem_res.adb
......@@ -5316,7 +5316,18 @@ package body Sem_Res is
-- needs extending because we can generate procedure calls that need
-- freezing.
if Is_Entity_Name (Subp) and then not In_Spec_Expression then
-- In Ada 2012, expression functions may be called within pre/post
-- conditions of subsequent functions or expression functions. Such
-- calls do not freeze when they appear within generated bodies, which
-- would place the freeze node in the wrong scope. An expression
-- function is frozen in the usual fashion, by the appearance of a real
-- body, or at the end of a declarative part.
if Is_Entity_Name (Subp) and then not In_Spec_Expression
and then
(not Is_Expression_Function (Entity (Subp))
or else Scope (Entity (Subp)) = Current_Scope)
then
Freeze_Expression (Subp);
end if;
......
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