OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2013-02-06  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch4.adb (Expand_N_Expression_With_Actions): Rewritten. This
	routine should be able to properly detect controlled transient
	objects in its actions and generate the appropriate finalization
	actions.
	* exp_ch6.adb (Enclosing_Context): Removed.
	(Expand_Ctrl_Function_Call): Remove local subprogram and
	constant. Use routine Within_Case_Or_If_Expression to determine
	whether the lifetime of the function result must be extended to
	match that of the context.
	* exp_util.ads, exp_util.adb (Within_Case_Or_If_Expression): New
	routine.

2013-02-06  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb (Validate_Array_Type_Instance): Extend check
	for subtype matching of component type of formal array type,
	to avoid spurious error when component type is a separate actual
	in the instance, and there may be a discrepancy between private
	and full view of component type.

From-SVN: r195790
This commit is contained in:
Arnaud Charlet 2013-02-06 11:10:32 +01:00
parent 088c2c8d37
commit 4c7e09908b
6 changed files with 364 additions and 166 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
gcc/ada/ChangeLog
View File

@ -1,3 +1,25 @@
2013-02-06 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch4.adb (Expand_N_Expression_With_Actions): Rewritten. This
routine should be able to properly detect controlled transient
objects in its actions and generate the appropriate finalization
actions.
* exp_ch6.adb (Enclosing_Context): Removed.
(Expand_Ctrl_Function_Call): Remove local subprogram and
constant. Use routine Within_Case_Or_If_Expression to determine
whether the lifetime of the function result must be extended to
match that of the context.
* exp_util.ads, exp_util.adb (Within_Case_Or_If_Expression): New
routine.
2013-02-06 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb (Validate_Array_Type_Instance): Extend check
for subtype matching of component type of formal array type,
to avoid spurious error when component type is a separate actual
in the instance, and there may be a discrepancy between private
and full view of component type.
2013-02-06 Robert Dewar <dewar@adacore.com> 2013-02-06 Robert Dewar <dewar@adacore.com>
* s-dim.ads, clean.adb: Minor reformatting. * s-dim.ads, clean.adb: Minor reformatting.

398
gcc/ada/exp_ch4.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2013, 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- --
@ -4984,145 +4984,317 @@ package body Exp_Ch4 is
-------------------------------------- --------------------------------------
procedure Expand_N_Expression_With_Actions (N : Node_Id) is procedure Expand_N_Expression_With_Actions (N : Node_Id) is
In_Case_Or_If_Expression : constant Boolean :=
Within_Case_Or_If_Expression (N);
procedure Process_Transient_Object (Decl : Node_Id); function Process_Action (Act : Node_Id) return Traverse_Result;
-- Given the declaration of a controlled transient declared inside the -- Inspect and process a single action of an expression_with_actions
-- Actions list of an Expression_With_Actions, generate all necessary
-- types and hooks in order to properly finalize the transient. This
-- mechanism works in conjunction with Build_Finalizer.
------------------------------ --------------------
-- Process_Transient_Object -- -- Process_Action --
------------------------------ --------------------
procedure Process_Transient_Object (Decl : Node_Id) is function Process_Action (Act : Node_Id) return Traverse_Result is
procedure Process_Transient_Object (Obj_Decl : Node_Id);
-- Obj_Decl denotes the declaration of a transient controlled object.
-- Generate all necessary types and hooks to properly finalize the
-- result when the enclosing context is elaborated/evaluated.
function Find_Insertion_Node return Node_Id; ------------------------------
-- Complex conditions in if statements may be converted into nested -- Process_Transient_Object --
-- EWAs. In this case, any generated code must be inserted before the ------------------------------
-- if statement to ensure proper visibility of the hook objects. This
-- routine returns the top most short circuit operator or the parent
-- of the EWA if no nesting was detected.
------------------------- procedure Process_Transient_Object (Obj_Decl : Node_Id) is
-- Find_Insertion_Node -- function Find_Enclosing_Context return Node_Id;
------------------------- -- Find the context where the expression_with_actions appears
function Find_Insertion_Node return Node_Id is ----------------------------
Par : Node_Id; -- Find_Enclosing_Context --
----------------------------
function Find_Enclosing_Context return Node_Id is
function Is_Body_Or_Unit (N : Node_Id) return Boolean;
-- Determine whether N denotes a body or unit declaration
---------------------
-- Is_Body_Or_Unit --
---------------------
function Is_Body_Or_Unit (N : Node_Id) return Boolean is
begin
return Nkind_In (N, N_Entry_Body,
N_Package_Body,
N_Package_Declaration,
N_Protected_Body,
N_Subprogram_Body,
N_Task_Body);
end Is_Body_Or_Unit;
-- Local variables
Par : Node_Id;
Top : Node_Id;
-- Start of processing for Find_Enclosing_Context
begin
-- The expression_with_action is in a case or if expression and
-- the lifetime of any temporary controlled object is therefore
-- extended. Find a suitable insertion node by locating the top
-- most case or if expressions.
if In_Case_Or_If_Expression then
Par := N;
Top := N;
while Present (Par) loop
if Nkind_In (Original_Node (Par), N_Case_Expression,
N_If_Expression)
then
Top := Par;
-- Prevent the search from going too far
elsif Is_Body_Or_Unit (Par) then
exit;
end if;
Par := Parent (Par);
end loop;
-- The topmost case or if expression is now recovered, but
-- it may still not be the correct place to add all the
-- generated code. Climb to find a parent that is part of a
-- declarative or statement list.
Par := Top;
while Present (Par) loop
if Is_List_Member (Par)
and then
not Nkind_In (Par, N_Component_Association,
N_Discriminant_Association,
N_Parameter_Association,
N_Pragma_Argument_Association)
then
return Par;
-- Prevent the search from going too far
elsif Is_Body_Or_Unit (Par) then
exit;
end if;
Par := Parent (Par);
end loop;
return Par;
-- Shor circuit operators in complex expressions are converted
-- into expression_with_actions.
else
-- Take care of the case where the expression_with_actions
-- is burried deep inside an if statement. The temporary
-- function result must be finalized before the then, elsif
-- or else statements are evaluated.
-- if Something
-- and then Ctrl_Func_Call
-- then
-- <result must be finalized at this point>
-- <statements>
-- end if;
-- To achieve this, find the topmost logical operator. The
-- generated actions are then inserted before/after it.
Par := N;
while Present (Par) loop
-- Keep climbing past various operators
if Nkind (Parent (Par)) in N_Op
or else Nkind_In (Parent (Par), N_And_Then, N_Or_Else)
then
Par := Parent (Par);
else
exit;
end if;
end loop;
Top := Par;
-- The expression_with_action might be located in a pragm
-- in which case locate the pragma itself:
-- pragma Precondition (... and then Ctrl_Func_Call ...);
-- Similar case occurs when the expression_with_actions is
-- related to an object declaration or assignment:
-- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
while Present (Par) loop
if Nkind_In (Par, N_Assignment_Statement,
N_Object_Declaration,
N_Pragma)
then
return Par;
elsif Is_Body_Or_Unit (Par) then
exit;
end if;
Par := Parent (Par);
end loop;
-- Return the topmost short circuit operator
return Top;
end if;
end Find_Enclosing_Context;
-- Local variables
Context : constant Node_Id := Find_Enclosing_Context;
Loc : constant Source_Ptr := Sloc (Obj_Decl);
Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
Obj_Typ : constant Node_Id := Etype (Obj_Id);
Desig_Typ : Entity_Id;
Expr : Node_Id;
Ptr_Id : Entity_Id;
Temp_Id : Entity_Id;
-- Start of processing for Process_Transient_Object
begin begin
-- Climb up the branches of a complex condition -- Step 1: Create the access type which provides a reference to
-- the transient object.
Par := N; if Is_Access_Type (Obj_Typ) then
while Nkind_In (Parent (Par), N_And_Then, N_Op_Not, N_Or_Else) loop Desig_Typ := Directly_Designated_Type (Obj_Typ);
Par := Parent (Par); else
end loop; Desig_Typ := Obj_Typ;
end if;
return Par; -- Generate:
end Find_Insertion_Node; -- Ann : access [all] <Desig_Typ>;
-- Local variables Ptr_Id := Make_Temporary (Loc, 'A');
Ins_Node : constant Node_Id := Find_Insertion_Node; Insert_Action (Context,
Loc : constant Source_Ptr := Sloc (Decl); Make_Full_Type_Declaration (Loc,
Obj_Id : constant Entity_Id := Defining_Identifier (Decl); Defining_Identifier => Ptr_Id,
Obj_Typ : constant Entity_Id := Etype (Obj_Id); Type_Definition =>
Desig_Typ : Entity_Id; Make_Access_To_Object_Definition (Loc,
Expr : Node_Id; All_Present =>
Ptr_Decl : Node_Id; Ekind (Obj_Typ) = E_General_Access_Type,
Ptr_Id : Entity_Id; Subtype_Indication => New_Reference_To (Desig_Typ, Loc))));
Temp_Decl : Node_Id;
Temp_Id : Node_Id;
-- Start of processing for Process_Transient_Object -- Step 2: Create a temporary which acts as a hook to the
-- transient object. Generate:
-- Temp : Ptr_Id := null;
Temp_Id := Make_Temporary (Loc, 'T');
Insert_Action (Context,
Make_Object_Declaration (Loc,
Defining_Identifier => Temp_Id,
Object_Definition => New_Reference_To (Ptr_Id, Loc)));
-- Mark this temporary as created for the purposes of exporting
-- the transient declaration out of the Actions list. This signals
-- the machinery in Build_Finalizer to recognize this special
-- case.
Set_Status_Flag_Or_Transient_Decl (Temp_Id, Obj_Decl);
-- Step 3: Hook the transient object to the temporary
if Is_Access_Type (Obj_Typ) then
Expr := Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc));
else
Expr :=
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Obj_Id, Loc),
Attribute_Name => Name_Unrestricted_Access);
end if;
-- Generate:
-- Temp := Ptr_Id (Obj_Id);
-- <or>
-- Temp := Obj_Id'Unrestricted_Access;
Insert_After_And_Analyze (Obj_Decl,
Make_Assignment_Statement (Loc,
Name => New_Reference_To (Temp_Id, Loc),
Expression => Expr));
-- Step 4: Finalize the function result after the context has been
-- evaluated/elaborated. Generate:
-- if Temp /= null then
-- [Deep_]Finalize (Temp.all);
-- Temp := null;
-- end if;
Insert_Action_After (Context,
Make_If_Statement (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd => New_Reference_To (Temp_Id, Loc),
Right_Opnd => Make_Null (Loc)),
Then_Statements => New_List (
Make_Final_Call
(Obj_Ref =>
Make_Explicit_Dereference (Loc,
Prefix => New_Reference_To (Temp_Id, Loc)),
Typ => Desig_Typ),
Make_Assignment_Statement (Loc,
Name => New_Reference_To (Temp_Id, Loc),
Expression => Make_Null (Loc)))));
end Process_Transient_Object;
-- Start of processing for Process_Action
begin begin
-- Step 1: Create the access type which provides a reference to the if Nkind (Act) = N_Object_Declaration
-- transient object. and then Is_Finalizable_Transient (Act, N)
then
Process_Transient_Object (Act);
if Is_Access_Type (Obj_Typ) then -- Avoid processing temporary function results multiple times when
Desig_Typ := Directly_Designated_Type (Obj_Typ); -- dealing with nested expression_with_actions.
else
Desig_Typ := Obj_Typ; elsif Nkind (Act) = N_Expression_With_Actions then
return Abandon;
-- Do not process temporary function results in loops. This is
-- done by Expand_N_Loop_Statement and Build_Finalizer.
elsif Nkind (Act) = N_Loop_Statement then
return Abandon;
end if; end if;
-- Generate: return OK;
-- Ann : access [all] <Desig_Typ>; end Process_Action;
Ptr_Id := Make_Temporary (Loc, 'A'); procedure Process_Single_Action is new Traverse_Proc (Process_Action);
Ptr_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Ptr_Id,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present =>
Ekind (Obj_Typ) = E_General_Access_Type,
Subtype_Indication => New_Reference_To (Desig_Typ, Loc)));
Insert_Action (Ins_Node, Ptr_Decl);
Analyze (Ptr_Decl);
-- Step 2: Create a temporary which acts as a hook to the transient
-- object. Generate:
-- Temp : Ptr_Id := null;
Temp_Id := Make_Temporary (Loc, 'T');
Temp_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp_Id,
Object_Definition => New_Reference_To (Ptr_Id, Loc));
Insert_Action (Ins_Node, Temp_Decl);
Analyze (Temp_Decl);
-- Mark this temporary as created for the purposes of exporting the
-- transient declaration out of the Actions list. This signals the
-- machinery in Build_Finalizer to recognize this special case.
Set_Status_Flag_Or_Transient_Decl (Temp_Id, Decl);
-- Step 3: Hook the transient object to the temporary
if Is_Access_Type (Obj_Typ) then
Expr := Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc));
else
Expr :=
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Obj_Id, Loc),
Attribute_Name => Name_Unrestricted_Access);
end if;
-- Generate:
-- Temp := Ptr_Id (Obj_Id);
-- <or>
-- Temp := Obj_Id'Unrestricted_Access;
Insert_After_And_Analyze (Decl,
Make_Assignment_Statement (Loc,
Name => New_Reference_To (Temp_Id, Loc),
Expression => Expr));
end Process_Transient_Object;
-- Local variables -- Local variables
Decl : Node_Id; Act : Node_Id;
-- Start of processing for Expand_N_Expression_With_Actions -- Start of processing for Expand_N_Expression_With_Actions
begin begin
Decl := First (Actions (N)); Act := First (Actions (N));
while Present (Decl) loop while Present (Act) loop
if Nkind (Decl) = N_Object_Declaration Process_Single_Action (Act);
and then Is_Finalizable_Transient (Decl, N)
then
Process_Transient_Object (Decl);
end if;
Next (Decl); Next (Act);
end loop; end loop;
end Expand_N_Expression_With_Actions; end Expand_N_Expression_With_Actions;

54
gcc/ada/exp_ch6.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2013, 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- --
@ -4036,45 +4036,6 @@ package body Exp_Ch6 is
------------------------------- -------------------------------
procedure Expand_Ctrl_Function_Call (N : Node_Id) is procedure Expand_Ctrl_Function_Call (N : Node_Id) is
function Enclosing_Context return Node_Id;
-- Find the enclosing context where the function call appears
-----------------------
-- Enclosing_Context --
-----------------------
function Enclosing_Context return Node_Id is
Context : Node_Id;
begin
Context := Parent (N);
while Present (Context) loop
-- The following could use a comment (and why is N_Case_Expression
-- not treated in a similar manner ???
if Nkind (Context) = N_If_Expression then
exit;
-- Stop the search when reaching any statement because we have
-- gone too far up the tree.
elsif Nkind (Context) = N_Procedure_Call_Statement
or else Nkind (Context) in N_Statement_Other_Than_Procedure_Call
then
exit;
end if;
Context := Parent (Context);
end loop;
return Context;
end Enclosing_Context;
-- Local variables
Context : constant Node_Id := Enclosing_Context;
begin begin
-- Optimization, if the returned value (which is on the sec-stack) is -- Optimization, if the returned value (which is on the sec-stack) is
-- returned again, no need to copy/readjust/finalize, we can just pass -- returned again, no need to copy/readjust/finalize, we can just pass
@ -4096,15 +4057,12 @@ package body Exp_Ch6 is
Remove_Side_Effects (N); Remove_Side_Effects (N);
-- The function call is part of an if expression dependent expression. -- When the temporary function result appears inside a case or an if
-- The temporary result must live as long as the if expression itself, -- expression, its lifetime must be extended to match that of the
-- otherwise it will be finalized too early. Mark the transient as -- context. If not, the function result would be finalized prematurely
-- processed to avoid untimely finalization. -- and the evaluation of the expression could yield the wrong result.
-- Why no special handling for case expressions here ??? if Within_Case_Or_If_Expression (N)
if Present (Context)
and then Nkind (Context) = N_If_Expression
and then Nkind (N) = N_Explicit_Dereference and then Nkind (N) = N_Explicit_Dereference
then then
Set_Is_Processed_Transient (Entity (Prefix (N))); Set_Is_Processed_Transient (Entity (Prefix (N)));

37
gcc/ada/exp_util.adb
View File

@ -7944,6 +7944,43 @@ package body Exp_Util is
end if; end if;
end Type_May_Have_Bit_Aligned_Components; end Type_May_Have_Bit_Aligned_Components;
----------------------------------
-- Within_Case_Or_If_Expression --
----------------------------------
function Within_Case_Or_If_Expression (N : Node_Id) return Boolean is
Par : Node_Id;
begin
-- Locate an enclosing case or if expression. Note that these constructs
-- appear as expression_with_actions, hence the test using the original
-- node.
Par := N;
while Present (Par) loop
if Nkind_In (Original_Node (Par), N_Case_Expression,
N_If_Expression)
then
return True;
-- Prevent the search from going too far
elsif Nkind_In (Par, N_Entry_Body,
N_Package_Body,
N_Package_Declaration,
N_Protected_Body,
N_Subprogram_Body,
N_Task_Body)
then
return False;
end if;
Par := Parent (Par);
end loop;
return False;
end Within_Case_Or_If_Expression;
---------------------------- ----------------------------
-- Wrap_Cleanup_Procedure -- -- Wrap_Cleanup_Procedure --
---------------------------- ----------------------------

5
gcc/ada/exp_util.ads
View File

@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2013, 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- --
@ -818,6 +818,9 @@ package Exp_Util is
-- is conservative, in that a result of False is decisive. A result of True -- is conservative, in that a result of False is decisive. A result of True
-- means that such a component may or may not be present. -- means that such a component may or may not be present.
function Within_Case_Or_If_Expression (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N is within a case or an if expression
procedure Wrap_Cleanup_Procedure (N : Node_Id); procedure Wrap_Cleanup_Procedure (N : Node_Id);
-- Given an N_Subprogram_Body node, this procedure adds an Abort_Defer call -- Given an N_Subprogram_Body node, this procedure adds an Abort_Defer call
-- at the start of the statement sequence, and an Abort_Undefer call at the -- at the start of the statement sequence, and an Abort_Undefer call at the

14
gcc/ada/sem_ch12.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2013, 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- --
@ -10699,13 +10699,19 @@ package body Sem_Ch12 is
-- issues when the generic is a child unit and some aspect of the -- issues when the generic is a child unit and some aspect of the
-- generic type is declared in a parent unit of the generic. We do -- generic type is declared in a parent unit of the generic. We do
-- the test to handle this special case only after a direct check -- the test to handle this special case only after a direct check
-- for static matching has failed. -- for static matching has failed. The case where both the component
-- type and the array type are separate formals, and the component
-- type is a private view may also require special checking.
if Subtypes_Match if Subtypes_Match
(Component_Type (A_Gen_T), Component_Type (Act_T)) (Component_Type (A_Gen_T), Component_Type (Act_T))
or else Subtypes_Match or else Subtypes_Match
(Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T), (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T),
Component_Type (Act_T)) Component_Type (Act_T))
or else Subtypes_Match
(Base_Type
(Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T)),
Component_Type (Act_T))
then then
null; null;
else else