+2016-07-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_aggr.adb Remove with and use clauses for Exp_Ch11 and Inline.
+ (Initialize_Array_Component): Protect the initialization
+ statements in an abort defer / undefer block when the associated
+ component is controlled.
+ (Initialize_Record_Component): Protect the initialization statements
+ in an abort defer / undefer block when the associated component is
+ controlled.
+ (Process_Transient_Component_Completion): Use Build_Abort_Undefer_Block
+ to create an abort defer / undefer block.
+ * exp_ch3.adb Remove with and use clauses for Exp_ch11 and Inline.
+ (Default_Initialize_Object): Use Build_Abort_Undefer_Block to
+ create an abort defer / undefer block.
+ * exp_ch5.adb (Expand_N_Assignment_Statement): Mark an abort
+ defer / undefer block as such.
+ * exp_ch9.adb (Find_Enclosing_Context): Do not consider an abort
+ defer / undefer block as a suitable context for an activation
+ chain or a master.
+ * exp_util.adb Add with and use clauses for Exp_Ch11.
+ (Build_Abort_Undefer_Block): New routine.
+ * exp_util.ads (Build_Abort_Undefer_Block): New routine.
+ * sinfo.adb (Is_Abort_Block): New routine.
+ (Set_Is_Abort_Block): New routine.
+ * sinfo.ads New attribute Is_Abort_Block along with occurrences
+ in nodes.
+ (Is_Abort_Block): New routine along with pragma Inline.
+ (Set_Is_Abort_Block): New routine along with pragma Inline.
+
+2016-07-06 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch4.adb (Analyze_One_Call): Add a conditional to handle
+ disambiguation.
+
2016-07-06 Hristian Kirtchev <kirtchev@adacore.com>
* einfo.adb Flag252 is now used as Is_Finalized_Transient. Flag295
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
-with Exp_Ch11; use Exp_Ch11;
with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
with Fname; use Fname;
with Freeze; use Freeze;
-with Inline; use Inline;
with Itypes; use Itypes;
with Lib; use Lib;
with Namet; use Namet;
Init_Expr : Node_Id;
Stmts : List_Id)
is
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active
+ (No_Exception_Propagation);
+
+ Finalization_OK : constant Boolean :=
+ Present (Comp_Typ)
+ and then Needs_Finalization (Comp_Typ);
+
Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
+ Blk_Stmts : List_Id;
Init_Stmt : Node_Id;
begin
+ -- Protect the initialization statements from aborts. Generate:
+
+ -- Abort_Defer;
+
+ if Finalization_OK and Abort_Allowed then
+ if Exceptions_OK then
+ Blk_Stmts := New_List;
+ else
+ Blk_Stmts := Stmts;
+ end if;
+
+ Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
+
+ -- Otherwise aborts are not allowed. All generated code is added
+ -- directly to the input list.
+
+ else
+ Blk_Stmts := Stmts;
+ end if;
+
-- Initialize the array element. Generate:
-- Arr_Comp := Init_Expr;
-- Arr_Comp := Init_Expr;
-- end;
- if Present (Comp_Typ)
- and then Needs_Finalization (Comp_Typ)
- and then Is_Array_Type (Comp_Typ)
- then
+ if Finalization_OK and then Is_Array_Type (Comp_Typ) then
Init_Stmt :=
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Statements => New_List (Init_Stmt)));
end if;
- Append_To (Stmts, Init_Stmt);
+ Append_To (Blk_Stmts, Init_Stmt);
-- Adjust the tag due to a possible view conversion. Generate:
and then Present (Comp_Typ)
and then Is_Tagged_Type (Comp_Typ)
then
- Append_To (Stmts,
+ Append_To (Blk_Stmts,
Make_OK_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
-- [Deep_]Adjust (Arr_Comp);
- if Present (Comp_Typ)
- and then Needs_Finalization (Comp_Typ)
+ if Finalization_OK
and then not Is_Limited_Type (Comp_Typ)
and then not
(Is_Array_Type (Comp_Typ)
and then Is_Controlled (Component_Type (Comp_Typ))
and then Nkind (Expr) = N_Aggregate)
then
- Append_To (Stmts,
+ Append_To (Blk_Stmts,
Make_Adjust_Call
(Obj_Ref => New_Copy_Tree (Arr_Comp),
Typ => Comp_Typ));
end if;
+
+ -- Complete the protection of the initialization statements
+
+ if Finalization_OK and Abort_Allowed then
+
+ -- Wrap the initialization statements in a block to catch a
+ -- potential exception. Generate:
+
+ -- begin
+ -- Abort_Defer;
+ -- Arr_Comp := Init_Expr;
+ -- Arr_Comp._tag := Full_TypP;
+ -- [Deep_]Adjust (Arr_Comp);
+ -- at end
+ -- Abort_Undefer_Direct;
+ -- end;
+
+ if Exceptions_OK then
+ Append_To (Stmts,
+ Build_Abort_Undefer_Block (Loc,
+ Stmts => Blk_Stmts,
+ Context => N));
+
+ -- Otherwise exceptions are not propagated. Generate:
+
+ -- Abort_Defer;
+ -- Arr_Comp := Init_Expr;
+ -- Arr_Comp._tag := Full_TypP;
+ -- [Deep_]Adjust (Arr_Comp);
+ -- Abort_Undefer;
+
+ else
+ Append_To (Blk_Stmts,
+ Build_Runtime_Call (Loc, RE_Abort_Undefer));
+ end if;
+ end if;
end Initialize_Array_Component;
-------------------------------------
Init_Expr : Node_Id;
Stmts : List_Id)
is
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active (No_Exception_Propagation);
+
+ Finalization_OK : constant Boolean := Needs_Finalization (Comp_Typ);
+
Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
+ Blk_Stmts : List_Id;
Init_Stmt : Node_Id;
begin
+ -- Protect the initialization statements from aborts. Generate:
+
+ -- Abort_Defer;
+
+ if Finalization_OK and Abort_Allowed then
+ if Exceptions_OK then
+ Blk_Stmts := New_List;
+ else
+ Blk_Stmts := Stmts;
+ end if;
+
+ Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
+
+ -- Otherwise aborts are not allowed. All generated code is added
+ -- directly to the input list.
+
+ else
+ Blk_Stmts := Stmts;
+ end if;
+
-- Initialize the record component. Generate:
-- Rec_Comp := Init_Expr;
Expression => Init_Expr);
Set_No_Ctrl_Actions (Init_Stmt);
- Append_To (Stmts, Init_Stmt);
+ Append_To (Blk_Stmts, Init_Stmt);
-- Adjust the tag due to a possible view conversion. Generate:
-- Rec_Comp._tag := Full_TypeP;
if Tagged_Type_Expansion and then Is_Tagged_Type (Comp_Typ) then
- Append_To (Stmts,
+ Append_To (Blk_Stmts,
Make_OK_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
-- [Deep_]Adjust (Rec_Comp);
- if Needs_Finalization (Comp_Typ)
- and then not Is_Limited_Type (Comp_Typ)
- then
- Append_To (Stmts,
+ if Finalization_OK and then not Is_Limited_Type (Comp_Typ) then
+ Append_To (Blk_Stmts,
Make_Adjust_Call
(Obj_Ref => New_Copy_Tree (Rec_Comp),
Typ => Comp_Typ));
end if;
+
+ -- Complete the protection of the initialization statements
+
+ if Finalization_OK and Abort_Allowed then
+
+ -- Wrap the initialization statements in a block to catch a
+ -- potential exception. Generate:
+
+ -- begin
+ -- Abort_Defer;
+ -- Rec_Comp := Init_Expr;
+ -- Rec_Comp._tag := Full_TypP;
+ -- [Deep_]Adjust (Rec_Comp);
+ -- at end
+ -- Abort_Undefer_Direct;
+ -- end;
+
+ if Exceptions_OK then
+ Append_To (Stmts,
+ Build_Abort_Undefer_Block (Loc,
+ Stmts => Blk_Stmts,
+ Context => N));
+
+ -- Otherwise exceptions are not propagated. Generate:
+
+ -- Abort_Defer;
+ -- Rec_Comp := Init_Expr;
+ -- Rec_Comp._tag := Full_TypP;
+ -- [Deep_]Adjust (Rec_Comp);
+ -- Abort_Undefer;
+
+ else
+ Append_To (Blk_Stmts,
+ Build_Runtime_Call (Loc, RE_Abort_Undefer));
+ end if;
+ end if;
end Initialize_Record_Component;
-------------------------
-- Hook := null;
-- [Deep_]Finalize (Res.all);
-- at end
- -- Abort_Undefer;
+ -- Abort_Undefer_Direct;
-- end;
elsif Abort_Allowed then
Abort_Only : declare
Blk_Stmts : constant List_Id := New_List;
- AUD : Entity_Id;
- Blk : Node_Id;
- Blk_HSS : Node_Id;
- Blk_Id : Entity_Id;
-
begin
Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
Append_To (Blk_Stmts, Hook_Clear);
Append_To (Blk_Stmts, Fin_Call);
- AUD := RTE (RE_Abort_Undefer_Direct);
-
- Blk_HSS :=
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Blk_Stmts,
- At_End_Proc => New_Occurrence_Of (AUD, Loc));
-
- Blk :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence => Blk_HSS);
-
- Add_Block_Identifier (Blk, Blk_Id);
- Expand_At_End_Handler (Blk_HSS, Blk_Id);
-
- -- Present the Abort_Undefer_Direct function to the back end so
- -- that it can inline the call to the function.
-
- Add_Inlined_Body (AUD, Aggr);
-
- Append_To (Stmts, Blk);
+ Append_To (Stmts,
+ Build_Abort_Undefer_Block (Loc,
+ Stmts => Blk_Stmts,
+ Context => Aggr));
end Abort_Only;
-- Otherwise generate:
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
-with Exp_Ch11; use Exp_Ch11;
with Exp_Dbug; use Exp_Dbug;
with Exp_Disp; use Exp_Disp;
with Exp_Dist; use Exp_Dist;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Ghost; use Ghost;
-with Inline; use Inline;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
- Abrt_Blk : Node_Id;
- Abrt_Blk_Id : Entity_Id;
- Abrt_HSS : Node_Id;
- Aggr_Init : Node_Id;
- AUD : Entity_Id;
- Comp_Init : List_Id := No_List;
- Fin_Call : Node_Id;
- Init_Stmts : List_Id := No_List;
- Obj_Init : Node_Id := Empty;
- Obj_Ref : Node_Id;
+ Aggr_Init : Node_Id;
+ Comp_Init : List_Id := No_List;
+ Fin_Call : Node_Id;
+ Init_Stmts : List_Id := No_List;
+ Obj_Init : Node_Id := Empty;
+ Obj_Ref : Node_Id;
-- Start of processing for Default_Initialize_Object
-- end;
if Exceptions_OK then
- AUD := RTE (RE_Abort_Undefer_Direct);
-
- Abrt_HSS :=
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Init_Stmts,
- At_End_Proc => New_Occurrence_Of (AUD, Loc));
-
- Abrt_Blk :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence => Abrt_HSS);
-
- Add_Block_Identifier (Abrt_Blk, Abrt_Blk_Id);
- Expand_At_End_Handler (Abrt_HSS, Abrt_Blk_Id);
-
- -- Present the Abort_Undefer_Direct function to the backend so
- -- that it can inline the call to the function.
-
- Add_Inlined_Body (AUD, N);
-
- Init_Stmts := New_List (Abrt_Blk);
+ Init_Stmts := New_List (
+ Build_Abort_Undefer_Block (Loc,
+ Stmts => Init_Stmts,
+ Context => N));
-- Otherwise exceptions are not propagated. Generate:
AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct);
begin
+ Set_Is_Abort_Block (N);
+
Set_Scope (Blk, Current_Scope);
Set_Etype (Blk, Standard_Void_Type);
Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N)));
-- package or return statement.
Context := Parent (N);
- while not Nkind_In (Context, N_Block_Statement,
- N_Entry_Body,
- N_Extended_Return_Statement,
- N_Package_Body,
- N_Package_Declaration,
- N_Subprogram_Body,
- N_Task_Body)
- loop
+ while Present (Context) loop
+ if Nkind_In (Context, N_Entry_Body,
+ N_Extended_Return_Statement,
+ N_Package_Body,
+ N_Package_Declaration,
+ N_Subprogram_Body,
+ N_Task_Body)
+ then
+ exit;
+
+ -- Do not consider block created to protect a list of statements with
+ -- an Abort_Defer / Abort_Undefer_Direct pair.
+
+ elsif Nkind (Context) = N_Block_Statement
+ and then not Is_Abort_Block (Context)
+ then
+ exit;
+ end if;
+
Context := Parent (Context);
end loop;
+ pragma Assert (Present (Context));
+
-- Extract the constituents of the context
if Nkind (Context) = N_Extended_Return_Statement then
end if;
else
- Context_Decls := Declarations (Context);
-
if Nkind (Context) = N_Block_Statement then
Context_Id := Entity (Identifier (Context));
else
raise Program_Error;
end if;
+
+ Context_Decls := Declarations (Context);
end if;
- pragma Assert (Present (Context));
pragma Assert (Present (Context_Id));
pragma Assert (Present (Context_Decls));
end Find_Enclosing_Context;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
+with Exp_Ch11; use Exp_Ch11;
with Ghost; use Ghost;
with Inline; use Inline;
with Itypes; use Itypes;
-- For deallocation of class-wide types we obtain the value of
-- alignment from the Type Specific Record of the deallocated object.
-- This is needed because the frontend expansion of class-wide types
- -- into equivalent types confuses the backend.
+ -- into equivalent types confuses the back end.
else
-- Generate:
end;
end Build_Allocate_Deallocate_Proc;
+ -------------------------------
+ -- Build_Abort_Undefer_Block --
+ -------------------------------
+
+ function Build_Abort_Undefer_Block
+ (Loc : Source_Ptr;
+ Stmts : List_Id;
+ Context : Node_Id) return Node_Id
+ is
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active (No_Exception_Propagation);
+
+ AUD : Entity_Id;
+ Blk : Node_Id;
+ Blk_Id : Entity_Id;
+ HSS : Node_Id;
+
+ begin
+ -- The block should be generated only when undeferring abort in the
+ -- context of a potential exception.
+
+ pragma Assert (Abort_Allowed and Exceptions_OK);
+
+ -- Generate:
+ -- begin
+ -- <Stmts>
+ -- at end
+ -- Abort_Undefer_Direct;
+ -- end;
+
+ AUD := RTE (RE_Abort_Undefer_Direct);
+
+ HSS :=
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts,
+ At_End_Proc => New_Occurrence_Of (AUD, Loc));
+
+ Blk :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence => HSS);
+ Set_Is_Abort_Block (Blk);
+
+ Add_Block_Identifier (Blk, Blk_Id);
+ Expand_At_End_Handler (HSS, Blk_Id);
+
+ -- Present the Abort_Undefer_Direct function to the back end to inline
+ -- the call to the routine.
+
+ Add_Inlined_Body (AUD, Context);
+
+ return Blk;
+ end Build_Abort_Undefer_Block;
+
--------------------------
-- Build_Procedure_Form --
--------------------------
-- If the type of the expression is an internally generated type it
-- may not be necessary to create a new subtype. However there are two
-- exceptions: references to the current instances, and aliased array
- -- object declarations for which the backend needs to create a template.
+ -- object declarations for which the back end has to create a template.
elsif Is_Constrained (Exp_Typ)
and then not Is_Class_Wide_Type (Unc_Type)
-- Note on checks that could raise Constraint_Error. Strictly, if we
-- take advantage of 11.6, these checks do not count as side effects.
-- However, we would prefer to consider that they are side effects,
- -- since the backend CSE does not work very well on expressions which
+ -- since the back end CSE does not work very well on expressions which
-- can raise Constraint_Error. On the other hand if we don't consider
-- them to be side effect free, then we get some awkward expansions
-- in -gnato mode, resulting in code insertions at a point where we
-- must be a free statement. If flag Is_Allocate is set, the generated
-- routine is allocate, deallocate otherwise.
+ function Build_Abort_Undefer_Block
+ (Loc : Source_Ptr;
+ Stmts : List_Id;
+ Context : Node_Id) return Node_Id;
+ -- Wrap statements Stmts in a block where the AT END handler contains a
+ -- call to Abort_Undefer_Direct. Context is the node which prompted the
+ -- inlining of the abort undefer routine. Note that this routine does
+ -- not install a call to Abort_Defer.
+
procedure Build_Procedure_Form (N : Node_Id);
-- Create a procedure declaration which emulates the behavior of a function
-- that returns an array type, for C-compatible generation.
Next_Actual (Actual);
Next_Formal (Formal);
+ -- In a complex case where an enclosing generic and a nested
+ -- generic package, both declared with partially parameterized
+ -- formal subprograms with the same names, are instantiated
+ -- with the same type, the types of the actual parameter and
+ -- that of the formal may appear incompatible at first sight.
+
+ -- generic
+ -- type Outer_T is private;
+ -- with function Func (Formal : Outer_T)
+ -- return ... is <>;
+
+ -- package Outer_Gen is
+ -- generic
+ -- type Inner_T is private;
+ -- with function Func (Formal : Inner_T) -- (1)
+ -- return ... is <>;
+
+ -- package Inner_Gen is
+ -- function Inner_Func (Formal : Inner_T) -- (2)
+ -- return ... is (Func (Formal));
+ -- end Inner_Gen;
+ -- end Outer_Generic;
+
+ -- package Outer_Inst is new Outer_Gen (Actual_T);
+ -- package Inner_Inst is new Outer_Inst.Inner_Gen (Actual_T);
+
+ -- In the example above, the type of parameter
+ -- Inner_Func.Formal at (2) is incompatible with the type of
+ -- Func.Formal at (1) in the context of instantiations
+ -- Outer_Inst and Inner_Inst. In reality both types are
+ -- generic actual subtypes renaming base type Actual_T as
+ -- part of the generic prologues for the instantiations.
+
+ -- Recognize this case and add a type conversion to allow
+ -- this kind of generic actual subtype conformance. Note that
+ -- this is done only when the call is non-overloaded because
+ -- the resolution mechanism already has the means to
+ -- disambiguate similar cases.
+
+ elsif not Is_Overloaded (Name (N))
+ and then Is_Type (Etype (Actual))
+ and then Is_Type (Etype (Formal))
+ and then Is_Generic_Actual_Type (Etype (Actual))
+ and then Is_Generic_Actual_Type (Etype (Formal))
+ and then Base_Type (Etype (Actual)) =
+ Base_Type (Etype (Formal))
+ then
+ Rewrite (Actual,
+ Convert_To (Etype (Formal), Relocate_Node (Actual)));
+ Analyze_And_Resolve (Actual, Etype (Formal));
+ Next_Actual (Actual);
+ Next_Formal (Formal);
+
+ -- Handle failed type check
+
else
if Debug_Flag_E then
Write_Str (" type checking fails in call ");
return Uint3 (N);
end Intval;
+ function Is_Abort_Block
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Block_Statement);
+ return Flag4 (N);
+ end Is_Abort_Block;
+
function Is_Accessibility_Actual
(N : Node_Id) return Boolean is
begin
Set_Uint3 (N, Val);
end Set_Intval;
+ procedure Set_Is_Abort_Block
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Block_Statement);
+ Set_Flag4 (N, Val);
+ end Set_Is_Abort_Block;
+
procedure Set_Is_Accessibility_Actual
(N : Node_Id; Val : Boolean := True) is
begin
-- to the node for the spec of the instance, inserted as part of the
-- semantic processing for instantiations in Sem_Ch12.
+ -- Is_Abort_Block (Flag4-Sem)
+ -- Present in N_Block_Statement nodes. True if the block protects a list
+ -- of statements with an Abort_Defer / Abort_Undefer_Direct pair.
+
-- Is_Accessibility_Actual (Flag13-Sem)
-- Present in N_Parameter_Association nodes. True if the parameter is
-- an extra actual that carries the accessibility level of the actual
-- Declarations (List2) (set to No_List if no DECLARE part)
-- Handled_Statement_Sequence (Node4)
-- Cleanup_Actions (List5-Sem)
+ -- Is_Abort_Block (Flag4-Sem)
-- Is_Task_Master (Flag5-Sem)
-- Activation_Chain_Entity (Node3-Sem)
-- Has_Created_Identifier (Flag15)
function Intval
(N : Node_Id) return Uint; -- Uint3
+ function Is_Abort_Block
+ (N : Node_Id) return Boolean; -- Flag4
+
function Is_Accessibility_Actual
(N : Node_Id) return Boolean; -- Flag13
procedure Set_Intval
(N : Node_Id; Val : Uint); -- Uint3
+ procedure Set_Is_Abort_Block
+ (N : Node_Id; Val : Boolean := True); -- Flag4
+
procedure Set_Is_Accessibility_Actual
(N : Node_Id; Val : Boolean := True); -- Flag13
pragma Inline (Instance_Spec);
pragma Inline (Intval);
pragma Inline (Iterator_Specification);
+ pragma Inline (Is_Abort_Block);
pragma Inline (Is_Accessibility_Actual);
pragma Inline (Is_Analyzed_Pragma);
pragma Inline (Is_Asynchronous_Call_Block);
pragma Inline (Set_Interface_List);
pragma Inline (Set_Interface_Present);
pragma Inline (Set_Intval);
+ pragma Inline (Set_Is_Abort_Block);
pragma Inline (Set_Is_Accessibility_Actual);
pragma Inline (Set_Is_Analyzed_Pragma);
pragma Inline (Set_Is_Asynchronous_Call_Block);
projects / gcc.git / commitdiff