aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
authorArnaud Charlet <charlet@gcc.gnu.org>2013-02-06 11:10:32 +0100
committerArnaud Charlet <charlet@gcc.gnu.org>2013-02-06 11:10:32 +0100
commit4c7e09908b732b93b74b49ad3eafda0198c1d1df (patch)
tree2339ff1bd35b72bb0decc57cd5f24dd2bbe5a808 /gcc
parent088c2c8d37175054fd0af5b58734a1fbf6ecebd1 (diff)
downloadgcc-4c7e09908b732b93b74b49ad3eafda0198c1d1df.zip
gcc-4c7e09908b732b93b74b49ad3eafda0198c1d1df.tar.gz
gcc-4c7e09908b732b93b74b49ad3eafda0198c1d1df.tar.bz2
[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
Diffstat (limited to 'gcc')
-rw-r--r--gcc/ada/ChangeLog22
-rw-r--r--gcc/ada/exp_ch4.adb374
-rw-r--r--gcc/ada/exp_ch6.adb54
-rw-r--r--gcc/ada/exp_util.adb37
-rw-r--r--gcc/ada/exp_util.ads5
-rw-r--r--gcc/ada/sem_ch12.adb14
6 files changed, 352 insertions, 154 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 309f7e7..6cc022a 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -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>
* s-dim.ads, clean.adb: Minor reformatting.
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 70e2fcd..56b1d63 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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
+ In_Case_Or_If_Expression : constant Boolean :=
+ Within_Case_Or_If_Expression (N);
- procedure Process_Transient_Object (Decl : Node_Id);
- -- Given the declaration of a controlled transient declared inside the
- -- 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.
+ function Process_Action (Act : Node_Id) return Traverse_Result;
+ -- Inspect and process a single action of an expression_with_actions
- ------------------------------
- -- Process_Transient_Object --
- ------------------------------
+ --------------------
+ -- Process_Action --
+ --------------------
+
+ 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.
+
+ ------------------------------
+ -- Process_Transient_Object --
+ ------------------------------
+
+ procedure Process_Transient_Object (Obj_Decl : Node_Id) is
+ function Find_Enclosing_Context return Node_Id;
+ -- Find the context where the expression_with_actions appears
+
+ ----------------------------
+ -- 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 ...;
- procedure Process_Transient_Object (Decl : Node_Id) is
+ 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
- function Find_Insertion_Node return Node_Id;
- -- Complex conditions in if statements may be converted into nested
- -- 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.
+ return Top;
+ end if;
+ end Find_Enclosing_Context;
+
+ -- Local variables
- -------------------------
- -- Find_Insertion_Node --
- -------------------------
+ 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;
- function Find_Insertion_Node return Node_Id is
- Par : Node_Id;
+ -- Start of processing for Process_Transient_Object
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;
- while Nkind_In (Parent (Par), N_And_Then, N_Op_Not, N_Or_Else) loop
- Par := Parent (Par);
- end loop;
+ if Is_Access_Type (Obj_Typ) then
+ Desig_Typ := Directly_Designated_Type (Obj_Typ);
+ else
+ Desig_Typ := Obj_Typ;
+ end if;
- return Par;
- end Find_Insertion_Node;
+ -- Generate:
+ -- Ann : access [all] <Desig_Typ>;
- -- Local variables
+ Ptr_Id := Make_Temporary (Loc, 'A');
- Ins_Node : constant Node_Id := Find_Insertion_Node;
- Loc : constant Source_Ptr := Sloc (Decl);
- Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
- Obj_Typ : constant Entity_Id := Etype (Obj_Id);
- Desig_Typ : Entity_Id;
- Expr : Node_Id;
- Ptr_Decl : Node_Id;
- Ptr_Id : Entity_Id;
- Temp_Decl : Node_Id;
- Temp_Id : Node_Id;
+ Insert_Action (Context,
+ 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))));
- -- Start of processing for Process_Transient_Object
+ -- Step 2: Create a temporary which acts as a hook to the
+ -- transient object. Generate:
- begin
- -- Step 1: Create the access type which provides a reference to the
- -- transient object.
+ -- Temp : Ptr_Id := null;
- if Is_Access_Type (Obj_Typ) then
- Desig_Typ := Directly_Designated_Type (Obj_Typ);
- else
- Desig_Typ := Obj_Typ;
- end if;
+ Temp_Id := Make_Temporary (Loc, 'T');
- -- Generate:
- -- Ann : access [all] <Desig_Typ>;
+ Insert_Action (Context,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp_Id,
+ Object_Definition => New_Reference_To (Ptr_Id, Loc)));
- Ptr_Id := Make_Temporary (Loc, 'A');
+ -- 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.
- 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)));
+ Set_Status_Flag_Or_Transient_Decl (Temp_Id, Obj_Decl);
- Insert_Action (Ins_Node, Ptr_Decl);
- Analyze (Ptr_Decl);
+ -- Step 3: Hook the transient object to the temporary
- -- Step 2: Create a temporary which acts as a hook to the transient
- -- object. Generate:
+ 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;
- -- Temp : Ptr_Id := null;
+ -- Generate:
+ -- Temp := Ptr_Id (Obj_Id);
+ -- <or>
+ -- Temp := Obj_Id'Unrestricted_Access;
- Temp_Id := Make_Temporary (Loc, 'T');
+ Insert_After_And_Analyze (Obj_Decl,
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (Temp_Id, Loc),
+ Expression => Expr));
- Temp_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp_Id,
- Object_Definition => New_Reference_To (Ptr_Id, Loc));
+ -- Step 4: Finalize the function result after the context has been
+ -- evaluated/elaborated. Generate:
- Insert_Action (Ins_Node, Temp_Decl);
- Analyze (Temp_Decl);
+ -- if Temp /= null then
+ -- [Deep_]Finalize (Temp.all);
+ -- Temp := null;
+ -- end if;
- -- 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.
+ 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)),
- Set_Status_Flag_Or_Transient_Decl (Temp_Id, Decl);
+ Then_Statements => New_List (
+ Make_Final_Call
+ (Obj_Ref =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Reference_To (Temp_Id, Loc)),
+ Typ => Desig_Typ),
- -- Step 3: Hook the transient object to the temporary
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (Temp_Id, Loc),
+ Expression => Make_Null (Loc)))));
+ end Process_Transient_Object;
- 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);
+ -- Start of processing for Process_Action
+
+ begin
+ if Nkind (Act) = N_Object_Declaration
+ and then Is_Finalizable_Transient (Act, N)
+ then
+ Process_Transient_Object (Act);
+
+ -- Avoid processing temporary function results multiple times when
+ -- dealing with nested expression_with_actions.
+
+ 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;
- -- Generate:
- -- Temp := Ptr_Id (Obj_Id);
- -- <or>
- -- Temp := Obj_Id'Unrestricted_Access;
+ return OK;
+ end Process_Action;
- Insert_After_And_Analyze (Decl,
- Make_Assignment_Statement (Loc,
- Name => New_Reference_To (Temp_Id, Loc),
- Expression => Expr));
- end Process_Transient_Object;
+ procedure Process_Single_Action is new Traverse_Proc (Process_Action);
-- Local variables
- Decl : Node_Id;
+ Act : Node_Id;
-- Start of processing for Expand_N_Expression_With_Actions
begin
- Decl := First (Actions (N));
- while Present (Decl) loop
- if Nkind (Decl) = N_Object_Declaration
- and then Is_Finalizable_Transient (Decl, N)
- then
- Process_Transient_Object (Decl);
- end if;
+ Act := First (Actions (N));
+ while Present (Act) loop
+ Process_Single_Action (Act);
- Next (Decl);
+ Next (Act);
end loop;
end Expand_N_Expression_With_Actions;
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index cd83d45bd..a2caf15 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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
- 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
-- Optimization, if the returned value (which is on the sec-stack) is
-- 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);
- -- The function call is part of an if expression dependent expression.
- -- The temporary result must live as long as the if expression itself,
- -- otherwise it will be finalized too early. Mark the transient as
- -- processed to avoid untimely finalization.
-
- -- Why no special handling for case expressions here ???
+ -- When the temporary function result appears inside a case or an if
+ -- expression, its lifetime must be extended to match that of the
+ -- context. If not, the function result would be finalized prematurely
+ -- and the evaluation of the expression could yield the wrong result.
- if Present (Context)
- and then Nkind (Context) = N_If_Expression
+ if Within_Case_Or_If_Expression (N)
and then Nkind (N) = N_Explicit_Dereference
then
Set_Is_Processed_Transient (Entity (Prefix (N)));
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 4e04ae8..3528fc9 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -7944,6 +7944,43 @@ package body Exp_Util is
end if;
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 --
----------------------------
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 339fd43..e0b0e09 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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
-- 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);
-- 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
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 85a863f..267d50c 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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
-- 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
- -- 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
(Component_Type (A_Gen_T), Component_Type (Act_T))
or else Subtypes_Match
- (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T),
- Component_Type (Act_T))
+ (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_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
null;
else