+2018-01-11 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_aggr.adb (Convert_Aggr_In_Object_Decl): Update the call to
+ Establish_Transient_Scope.
+ (Convert_To_Assignments): Update the call to Establish_Transient_Scope.
+ (Expand_Array_Aggregate): Update the call to Establish_Transient_Scope.
+ * exp_ch6.adb (Expand_Call_Helper): Update the call to
+ Establish_Transient_Scope.
+ (Make_Build_In_Place_Call_In_Object_Declaration): Update the call to
+ Establish_Transient_Scope.
+ * exp_ch7.adb (Establish_Transient_Scope): Restructured. Delegate the
+ management of the secondary stack to an enclosing scope if there is no
+ suitable construct to wrap, and the transient scope was intended to
+ manage the secondary stack.
+ (Find_Node_To_Be_Wrapped): Restructured. A case_statement_alternative
+ is a valid boundary for a transient expression which comes from the
+ statements of the alternative, otherwise alternatives cannot be
+ wrapped. Assignments of controlled objects which have controlled
+ actions suppressed now stop the traversal as there is no point in
+ looking for an enclosing construct. Add several N_xxx_Body choices to
+ the termination conditions for completeness.
+ * exp_ch7.ads (Establish_Transient_Scope): Update the parameter profile
+ and the associated comment on usage.
+ * exp_smem.adb (Add_Shared_Var_Lock_Procs): Update the call to
+ Establish_Transient_Scope.
+ (Add_Write_After): Update the call to Establish_Transient_Scope.
+ * sem_res.adb (Check_Initialization_Call): Removed.
+ (Resolve_Actuals): Account for additional cases where finalization
+ actions are required by utilizing predicate Needs_Finalization rather
+ than Is_Controlled.
+ (Resolve_Call): Type initialization procedures can now utilize
+ transient scopes to manage the secondary stack, thus preventing leaks
+ during initialization. Remove the previous kludgy algorithm which
+ attempts to manage the secondary stack at the object creation site.
+
2018-01-11 Jerome Lambourg <lambourg@adacore.com>
* libgnat/g-soliop__qnx.ads: New.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2018, 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- --
and then Ekind (Current_Scope) /= E_Return_Statement
and then not Is_Limited_Type (Typ)
then
- Establish_Transient_Scope (Aggr, Sec_Stack => False);
+ Establish_Transient_Scope (Aggr, Manage_Sec_Stack => False);
end if;
declare
- Node_After : constant Node_Id := Next (N);
+ Node_After : constant Node_Id := Next (N);
begin
Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ));
Collect_Initialization_Statements (Obj, N, Node_After);
end;
+
Set_No_Initialization (N);
Initialize_Discriminants (N, Typ);
end Convert_Aggr_In_Object_Decl;
-- Should the condition be more restrictive ???
if Requires_Transient_Scope (Typ) and then not Inside_Init_Proc then
- Establish_Transient_Scope (N, Sec_Stack => False);
+ Establish_Transient_Scope (N, Manage_Sec_Stack => False);
end if;
-- If the aggregate is nonlimited, create a temporary. If it is limited
-- for default initialization, e.g. with Initialize_Scalars.
if Requires_Transient_Scope (Typ) then
- Establish_Transient_Scope (N, Sec_Stack => False);
+ Establish_Transient_Scope (N, Manage_Sec_Stack => False);
end if;
if Has_Default_Init_Comps (N) then
Set_No_Initialization (Tmp_Decl, True);
-- If we are within a loop, the temporary will be pushed on the
- -- stack at each iteration. If the aggregate is the expression for an
- -- allocator, it will be immediately copied to the heap and can
- -- be reclaimed at once. We create a transient scope around the
- -- aggregate for this purpose.
+ -- stack at each iteration. If the aggregate is the expression
+ -- for an allocator, it will be immediately copied to the heap
+ -- and can be reclaimed at once. We create a transient scope
+ -- around the aggregate for this purpose.
if Ekind (Current_Scope) = E_Loop
and then Nkind (Parent (Parent (N))) = N_Allocator
then
- Establish_Transient_Scope (N, Sec_Stack => False);
+ Establish_Transient_Scope (N, Manage_Sec_Stack => False);
end if;
Insert_Action (N, Tmp_Decl);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2018, 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- --
or else Nkind (Parent (N)) /= N_Function_Call
or else not Is_Build_In_Place_Function_Call (Parent (N)))
then
- Establish_Transient_Scope (Call_Node, Sec_Stack => True);
+ Establish_Transient_Scope (Call_Node, Manage_Sec_Stack => True);
end if;
end if;
end Expand_Call_Helper;
Attribute_Name => Name_Unrestricted_Access);
end if;
- -- In other indefinite cases, pass an indication to do the allocation on
- -- the secondary stack and set Caller_Object to Empty so that a null
+ -- In other indefinite cases, pass an indication to do the allocation
+ -- on the secondary stack and set Caller_Object to Empty so that a null
-- value will be passed for the caller's object address. A transient
-- scope is established to ensure eventual cleanup of the result.
(Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
Caller_Object := Empty;
- Establish_Transient_Scope (Obj_Decl, Sec_Stack => True);
+ Establish_Transient_Scope (Obj_Decl, Manage_Sec_Stack => True);
end if;
-- Pass along any finalization master actual, which is needed in the
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2018, 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- --
-- result. It creates a new scope on the scope stack in order to enclose
-- all transient variables generated.
- procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is
- Loc : constant Source_Ptr := Sloc (N);
- Iter_Loop : Entity_Id;
- Scop_Id : Entity_Id;
- Scop_Rec : Scope_Stack_Entry;
- Wrap_Node : Node_Id;
-
- begin
- -- Do not create a new transient scope if there is an existing transient
- -- scope on the stack.
-
- for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
- Scop_Rec := Scope_Stack.Table (Index);
- Scop_Id := Scop_Rec.Entity;
-
- -- The current scope is transient. If the scope being established
- -- needs to manage the secondary stack, then the existing scope
- -- overtakes that function.
-
- if Scop_Rec.Is_Transient then
- if Sec_Stack then
- Set_Uses_Sec_Stack (Scop_Id);
- end if;
-
- return;
-
- -- Prevent the search from going too far because transient blocks
- -- are bounded by packages and subprogram scopes. Reaching Standard
- -- should be impossible without hitting one of the other cases first
- -- unless Standard was manually pushed.
-
- elsif Scop_Id = Standard_Standard
- or else Ekind_In (Scop_Id, E_Entry,
- E_Entry_Family,
- E_Function,
- E_Package,
- E_Procedure,
- E_Subprogram_Body)
- then
- exit;
- end if;
- end loop;
+ procedure Establish_Transient_Scope
+ (N : Node_Id;
+ Manage_Sec_Stack : Boolean)
+ is
+ procedure Create_Transient_Scope (Constr : Node_Id);
+ -- Place a new scope on the scope stack in order to service construct
+ -- Constr. The new scope may also manage the secondary stack.
- Wrap_Node := Find_Node_To_Be_Wrapped (N);
+ procedure Delegate_Sec_Stack_Management;
+ -- Move the management of the secondary stack to the nearest enclosing
+ -- suitable scope.
- -- The context does not contain a node that requires a transient scope,
- -- nothing to do.
+ function Find_Enclosing_Transient_Scope return Entity_Id;
+ -- Examine the scope stack looking for the nearest enclosing transient
+ -- scope. Return Empty if no such scope exists.
- if No (Wrap_Node) then
- null;
+ function Is_OK_Construct (Constr : Node_Id) return Boolean;
+ -- Determine whether arbitrary node Constr is a suitable construct which
+ -- requires handling by a transient scope.
- -- If the node to wrap is an iteration_scheme, the expression is one of
- -- the bounds, and the expansion will make an explicit declaration for
- -- it (see Analyze_Iteration_Scheme, sem_ch5.adb), so do not apply any
- -- transformations here. Same for an Ada 2012 iterator specification,
- -- where a block is created for the expression that build the container.
+ function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean;
+ -- Determine whether arbitrary Id denotes a package or subprogram [body]
- elsif Nkind_In (Wrap_Node, N_Iteration_Scheme,
- N_Iterator_Specification)
- then
- null;
+ ----------------------------
+ -- Create_Transient_Scope --
+ ----------------------------
- -- In formal verification mode, if the node to wrap is a pragma check,
- -- this node and enclosed expression are not expanded, so do not apply
- -- any transformations here.
+ procedure Create_Transient_Scope (Constr : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
- elsif GNATprove_Mode
- and then Nkind (Wrap_Node) = N_Pragma
- and then Get_Pragma_Id (Wrap_Node) = Pragma_Check
- then
- null;
+ Iter_Loop : Entity_Id;
+ Trans_Scop : Entity_Id;
- -- Create a block entity to act as a transient scope. Note that when the
- -- node to be wrapped is an expression or a statement, a real physical
- -- block is constructed (see routines Wrap_Transient_Expression and
- -- Wrap_Transient_Statement) and inserted into the tree.
+ begin
+ Trans_Scop := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
+ Set_Etype (Trans_Scop, Standard_Void_Type);
- else
- Push_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
+ Push_Scope (Trans_Scop);
+ Set_Node_To_Be_Wrapped (Constr);
Set_Scope_Is_Transient;
- -- The transient scope must also take care of the secondary stack
- -- management.
+ -- The transient scope must also manage the secondary stack
- if Sec_Stack then
- Set_Uses_Sec_Stack (Current_Scope);
+ if Manage_Sec_Stack then
+ Set_Uses_Sec_Stack (Trans_Scop);
Check_Restriction (No_Secondary_Stack, N);
-- The expansion of iterator loops generates references to objects
-- machinery to manage the secondary stack (see routine
-- Process_Statements_For_Controlled_Objects).
- Iter_Loop := Find_Enclosing_Iterator_Loop (Current_Scope);
+ Iter_Loop := Find_Enclosing_Iterator_Loop (Trans_Scop);
if Present (Iter_Loop) then
Set_Uses_Sec_Stack (Iter_Loop);
end if;
end if;
- Set_Etype (Current_Scope, Standard_Void_Type);
- Set_Node_To_Be_Wrapped (Wrap_Node);
-
if Debug_Flag_W then
Write_Str (" <Transient>");
Write_Eol;
end if;
+ end Create_Transient_Scope;
+
+ -----------------------------------
+ -- Delegate_Sec_Stack_Management --
+ -----------------------------------
+
+ procedure Delegate_Sec_Stack_Management is
+ Scop_Id : Entity_Id;
+ Scop_Rec : Scope_Stack_Entry;
+
+ begin
+ for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
+ Scop_Rec := Scope_Stack.Table (Index);
+ Scop_Id := Scop_Rec.Entity;
+
+ -- Prevent the search from going too far or within the scope space
+ -- of another unit.
+
+ if Scop_Id = Standard_Standard then
+ return;
+
+ -- No transient scope should be encountered during the traversal
+ -- because Establish_Transient_Scope should have already handled
+ -- this case.
+
+ elsif Scop_Rec.Is_Transient then
+ pragma Assert (False);
+ return;
+
+ -- The construct which requires secondary stack management is
+ -- always enclosed by a package or subprogram scope.
+
+ elsif Is_Package_Or_Subprogram (Scop_Id) then
+ Set_Uses_Sec_Stack (Scop_Id);
+ Check_Restriction (No_Secondary_Stack, N);
+
+ return;
+ end if;
+ end loop;
+
+ -- At this point no suitable scope was found. This should never occur
+ -- because a construct is always enclosed by a compilation unit which
+ -- has a scope.
+
+ pragma Assert (False);
+ end Delegate_Sec_Stack_Management;
+
+ ------------------------------------
+ -- Find_Enclosing_Transient_Scope --
+ ------------------------------------
+
+ function Find_Enclosing_Transient_Scope return Entity_Id is
+ Scop_Id : Entity_Id;
+ Scop_Rec : Scope_Stack_Entry;
+
+ begin
+ for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
+ Scop_Rec := Scope_Stack.Table (Index);
+ Scop_Id := Scop_Rec.Entity;
+
+ -- Prevent the search from going too far or within the scope space
+ -- of another unit.
+
+ if Scop_Id = Standard_Standard
+ or else Is_Package_Or_Subprogram (Scop_Id)
+ then
+ exit;
+
+ elsif Scop_Rec.Is_Transient then
+ return Scop_Id;
+ end if;
+ end loop;
+
+ return Empty;
+ end Find_Enclosing_Transient_Scope;
+
+ ---------------------
+ -- Is_OK_Construct --
+ ---------------------
+
+ function Is_OK_Construct (Constr : Node_Id) return Boolean is
+ begin
+ -- Nothing to do when there is no construct to consider
+
+ if No (Constr) then
+ return False;
+
+ -- Nothing to do when the construct is an iteration scheme or an Ada
+ -- 2012 iterator because the expression is one of the bounds, and the
+ -- expansion will create an explicit declaration for it (see routine
+ -- Analyze_Iteration_Scheme).
+
+ elsif Nkind_In (Constr, N_Iteration_Scheme,
+ N_Iterator_Specification)
+ then
+ return False;
+
+ -- Nothing to do in formal verification mode when the construct is
+ -- pragma Check, because the pragma remains unexpanded.
+
+ elsif GNATprove_Mode
+ and then Nkind (Constr) = N_Pragma
+ and then Get_Pragma_Id (Constr) = Pragma_Check
+ then
+ return False;
+ end if;
+
+ return True;
+ end Is_OK_Construct;
+
+ ------------------------------
+ -- Is_Package_Or_Subprogram --
+ ------------------------------
+
+ function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean is
+ begin
+ return Ekind_In (Id, E_Entry,
+ E_Entry_Family,
+ E_Function,
+ E_Package,
+ E_Procedure,
+ E_Subprogram_Body);
+ end Is_Package_Or_Subprogram;
+
+ -- Local variables
+
+ Scop_Id : constant Entity_Id := Find_Enclosing_Transient_Scope;
+ Constr : Node_Id;
+
+ -- Start of processing for Establish_Transient_Scope
+
+ begin
+ -- Do not create a new transient scope if there is an existing transient
+ -- scope on the stack.
+
+ if Present (Scop_Id) then
+
+ -- If the transient scope was requested for purposes of managing the
+ -- secondary stack, then the existing scope must perform this task.
+
+ if Manage_Sec_Stack then
+ Set_Uses_Sec_Stack (Scop_Id);
+ end if;
+
+ return;
+ end if;
+
+ -- At this point it is known that the scope stack is free of transient
+ -- scopes. Locate the proper construct which must be serviced by a new
+ -- transient scope.
+
+ Constr := Find_Node_To_Be_Wrapped (N);
+
+ if Is_OK_Construct (Constr) then
+ Create_Transient_Scope (Constr);
+
+ -- Otherwise there is no suitable construct which requires handling by
+ -- a transient scope. If the transient scope was requested for purposes
+ -- of managing the secondary stack, delegate the work to an enclosing
+ -- scope.
+
+ elsif Manage_Sec_Stack then
+ Delegate_Sec_Stack_Management;
end if;
end Establish_Transient_Scope;
-----------------------------
function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is
- P : Node_Id;
- The_Parent : Node_Id;
+ Curr : Node_Id;
+ Prev : Node_Id;
begin
- The_Parent := N;
- P := Empty;
+ Curr := N;
+ Prev := Empty;
loop
- case Nkind (The_Parent) is
-
- -- Simple statement can be wrapped
-
- when N_Pragma =>
- return The_Parent;
-
- -- Usually assignments are good candidate for wrapping except
- -- when they have been generated as part of a controlled aggregate
- -- where the wrapping should take place more globally. Note that
- -- No_Ctrl_Actions may be set also for non-controlled assignements
- -- in order to disable the use of dispatching _assign, so we need
- -- to test explicitly for a controlled type here.
+ case Nkind (Curr) is
- when N_Assignment_Statement =>
- if No_Ctrl_Actions (The_Parent)
- and then Needs_Finalization (Etype (Name (The_Parent)))
- then
- null;
- else
- return The_Parent;
- end if;
-
- -- An entry call statement is a special case if it occurs in the
- -- context of a Timed_Entry_Call. In this case we wrap the entire
- -- timed entry call.
-
- when N_Entry_Call_Statement
- | N_Procedure_Call_Statement
- =>
- if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative
- and then Nkind_In (Parent (Parent (The_Parent)),
- N_Timed_Entry_Call,
- N_Conditional_Entry_Call)
- then
- return Parent (Parent (The_Parent));
- else
- return The_Parent;
- end if;
+ -- Declarations
- -- Object declarations are also a boundary for the transient scope
- -- even if they are not really wrapped. For further details, see
- -- Wrap_Transient_Declaration.
+ -- Declarations act as a boundary for a transient scope even if
+ -- they are not wrapped, see Wrap_Transient_Declaration.
when N_Object_Declaration
| N_Object_Renaming_Declaration
| N_Subtype_Declaration
=>
- return The_Parent;
+ return Curr;
+
+ -- Statements
- -- The expression itself is to be wrapped if its parent is a
- -- compound statement or any other statement where the expression
- -- is known to be scalar.
+ -- Statements and statement-like constructs act as a boundary for
+ -- a transient scope.
when N_Accept_Alternative
| N_Attribute_Definition_Clause
| N_Case_Statement
+ | N_Case_Statement_Alternative
| N_Code_Statement
| N_Delay_Alternative
| N_Delay_Until_Statement
| N_Iteration_Scheme
| N_Terminate_Alternative
=>
- pragma Assert (Present (P));
- return P;
+ pragma Assert (Present (Prev));
+ return Prev;
- when N_Attribute_Reference =>
- if Is_Procedure_Attribute_Name
- (Attribute_Name (The_Parent))
+ -- Assignment statements are usually wrapped in a transient block
+ -- except when they are generated as part of controlled aggregate
+ -- where the wrapping should take place more globally. Note that
+ -- No_Ctrl_Actions is set also for non-controlled assignments, in
+ -- order to disable the use of dispatching _assign, thus the test
+ -- for a controlled type.
+
+ when N_Assignment_Statement =>
+ if No_Ctrl_Actions (Curr)
+ and then Needs_Finalization (Etype (Name (Curr)))
then
- return The_Parent;
+ return Empty;
+ else
+ return Curr;
end if;
- -- A raise statement can be wrapped. This will arise when the
- -- expression in a raise_with_expression uses the secondary
- -- stack, for example.
+ -- An entry of procedure call is usually wrapped except when it
+ -- acts as the alternative of a conditional or timed entry call.
+ -- In that case wrap the context of the alternative.
- when N_Raise_Statement =>
- return The_Parent;
+ when N_Entry_Call_Statement
+ | N_Procedure_Call_Statement
+ =>
+ if Nkind (Parent (Curr)) = N_Entry_Call_Alternative
+ and then Nkind_In (Parent (Parent (Curr)),
+ N_Conditional_Entry_Call,
+ N_Timed_Entry_Call)
+ then
+ return Parent (Parent (Curr));
+ else
+ return Curr;
+ end if;
+
+ when N_Pragma
+ | N_Raise_Statement
+ =>
+ return Curr;
- -- If the expression is within the iteration scheme of a loop,
- -- we must create a declaration for it, followed by an assignment
- -- in order to have a usable statement to wrap.
+ -- A return statement is not wrapped when the associated function
+ -- would require wrapping.
+
+ when N_Simple_Return_Statement =>
+ if Requires_Transient_Scope (Etype
+ (Return_Applies_To (Return_Statement_Entity (Curr))))
+ then
+ return Empty;
+ else
+ return Curr;
+ end if;
+
+ -- Special
+
+ when N_Attribute_Reference =>
+ if Is_Procedure_Attribute_Name (Attribute_Name (Curr)) then
+ return Curr;
+ end if;
+
+ -- If the construct is within the iteration scheme of a loop, it
+ -- requires a declaration followed by an assignment, in order to
+ -- have a usable statement to wrap.
when N_Loop_Parameter_Specification =>
- return Parent (The_Parent);
+ return Parent (Curr);
- -- The following nodes contains "dummy calls" which don't need to
- -- be wrapped.
+ -- Termination
+
+ -- The following nodes represent "dummy contexts" which do not
+ -- need to be wrapped.
when N_Component_Declaration
| N_Discriminant_Specification
=>
return Empty;
- -- The return statement is not to be wrapped when the function
- -- itself needs wrapping at the outer-level
-
- when N_Simple_Return_Statement =>
- declare
- Applies_To : constant Entity_Id :=
- Return_Applies_To
- (Return_Statement_Entity (The_Parent));
- Return_Type : constant Entity_Id := Etype (Applies_To);
- begin
- if Requires_Transient_Scope (Return_Type) then
- return Empty;
- else
- return The_Parent;
- end if;
- end;
-
- -- If we leave a scope without having been able to find a node to
- -- wrap, something is going wrong but this can happen in error
- -- situation that are not detected yet (such as a dynamic string
- -- in a pragma export)
+ -- If the traversal leaves a scope without having been able to
+ -- find a construct to wrap, something is going wrong, but this
+ -- can happen in error situations that are not detected yet (such
+ -- as a dynamic string in a pragma Export).
when N_Block_Statement
+ | N_Entry_Body
| N_Package_Body
| N_Package_Declaration
+ | N_Protected_Body
| N_Subprogram_Body
+ | N_Task_Body
=>
return Empty;
- -- Otherwise continue the search
+ -- Default
when others =>
null;
end case;
- P := The_Parent;
- The_Parent := Parent (P);
+ Prev := Curr;
+ Curr := Parent (Curr);
end loop;
end Find_Node_To_Be_Wrapped;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2018, 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- --
-- a "scope node" that is to say one of the following: N_Block_Statement,
-- N_Subprogram_Body, N_Task_Body, N_Entry_Body.
- procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean);
- -- Push a new transient scope on the scope stack. N is the node responsible
- -- for the need of a transient scope. If Sec_Stack is True then the
- -- secondary stack is brought in, otherwise it isn't.
+ procedure Establish_Transient_Scope
+ (N : Node_Id;
+ Manage_Sec_Stack : Boolean);
+ -- Push a new transient scope on the scope stack. N is the node which must
+ -- be serviced by the transient scope. Set Manage_Sec_Stack when the scope
+ -- must mark and release the secondary stack.
function Node_To_Be_Wrapped return Node_Id;
-- Return the node to be wrapped if the current scope is transient
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2018, 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- --
else
Insert_Action (N, Vde);
- Establish_Transient_Scope (N, Sec_Stack => False);
+ Establish_Transient_Scope (N, Manage_Sec_Stack => False);
end if;
-- Mark object as locked in the current (transient) scope
---------------------
procedure Add_Write_After (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
Ent : constant Entity_Id := Entity (N);
+ Loc : constant Source_Ptr := Sloc (N);
Par : constant Node_Id := Insert_Node;
+
begin
if Present (Shared_Var_Procs_Instance (Ent)) then
if Nkind (Insert_Node) = N_Function_Call then
- Establish_Transient_Scope (Insert_Node, Sec_Stack => False);
+ Establish_Transient_Scope (Insert_Node, Manage_Sec_Stack => False);
+
Store_After_Actions_In_Scope (New_List (
Build_Shared_Var_Proc_Call (Loc, Ent, Name_Write)));
else
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2018, 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- --
-- an infinite recursion, and if so, outputs appropriate messages. Returns
-- True if an infinite recursion is detected, and False otherwise.
- procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id);
- -- If the type of the object being initialized uses the secondary stack
- -- directly or indirectly, create a transient scope for the call to the
- -- init proc. This is because we do not create transient scopes for the
- -- initialization of individual components within the init proc itself.
- -- Could be optimized away perhaps?
-
procedure Check_No_Direct_Boolean_Operators (N : Node_Id);
-- N is the node for a logical operator. If the operator is predefined, and
-- the root type of the operands is Standard.Boolean, then a check is made
return True;
end Check_Infinite_Recursion;
- -------------------------------
- -- Check_Initialization_Call --
- -------------------------------
-
- procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is
- Typ : constant Entity_Id := Etype (First_Formal (Nam));
-
- function Uses_SS (T : Entity_Id) return Boolean;
- -- Check whether the creation of an object of the type will involve
- -- use of the secondary stack. If T is a record type, this is true
- -- if the expression for some component uses the secondary stack, e.g.
- -- through a call to a function that returns an unconstrained value.
- -- False if T is controlled, because cleanups occur elsewhere.
-
- -------------
- -- Uses_SS --
- -------------
-
- function Uses_SS (T : Entity_Id) return Boolean is
- Comp : Entity_Id;
- Expr : Node_Id;
- Full_Type : Entity_Id := Underlying_Type (T);
-
- begin
- -- Normally we want to use the underlying type, but if it's not set
- -- then continue with T.
-
- if not Present (Full_Type) then
- Full_Type := T;
- end if;
-
- if Is_Array_Type (Full_Type) then
- return Uses_SS (Component_Type (Full_Type));
-
- elsif Is_Record_Type (Full_Type) then
- Comp := First_Component (Full_Type);
- while Present (Comp) loop
- if Ekind (Comp) = E_Component
- and then Nkind (Parent (Comp)) = N_Component_Declaration
- then
- -- The expression for a dynamic component may be rewritten
- -- as a dereference, so retrieve original node.
-
- Expr := Original_Node (Expression (Parent (Comp)));
-
- -- Return True if the expression is a call to a function
- -- (including an attribute function such as Image, or a
- -- user-defined operator) with a result that requires a
- -- transient scope.
-
- if (Nkind (Expr) = N_Function_Call
- or else Nkind (Expr) in N_Op
- or else (Nkind (Expr) = N_Attribute_Reference
- and then Present (Expressions (Expr))))
- and then Requires_Transient_Scope (Etype (Expr))
- then
- return True;
-
- elsif Uses_SS (Etype (Comp)) then
- return True;
- end if;
- end if;
-
- Next_Component (Comp);
- end loop;
-
- return False;
-
- else
- return False;
- end if;
- end Uses_SS;
-
- -- Start of processing for Check_Initialization_Call
-
- begin
- -- Establish a transient scope if the type needs it
-
- if Uses_SS (Typ) then
- Establish_Transient_Scope (First_Actual (N), Sec_Stack => True);
- end if;
- end Check_Initialization_Call;
-
---------------------------------------
-- Check_No_Direct_Boolean_Operators --
---------------------------------------
-- transient scope for it, so that it can receive the proper
-- finalization list.
- elsif Nkind (A) = N_Function_Call
+ elsif Expander_Active
+ and then Nkind (A) = N_Function_Call
and then Is_Limited_Record (Etype (F))
and then not Is_Constrained (Etype (F))
- and then Expander_Active
- and then (Is_Controlled (Etype (F)) or else Has_Task (Etype (F)))
+ and then (Needs_Finalization (Etype (F))
+ or else Has_Task (Etype (F)))
then
- Establish_Transient_Scope (A, Sec_Stack => False);
+ Establish_Transient_Scope (A, Manage_Sec_Stack => False);
Resolve (A, Etype (F));
-- A small optimization: if one of the actuals is a concatenation
-- static string, and we want to preserve warnings involving
-- sequences of such statements.
- elsif Nkind (A) = N_Op_Concat
+ elsif Expander_Active
+ and then Nkind (A) = N_Op_Concat
and then Nkind (N) = N_Procedure_Call_Statement
- and then Expander_Active
- and then
- not (Is_Intrinsic_Subprogram (Nam)
- and then Chars (Nam) = Name_Asm)
+ and then not (Is_Intrinsic_Subprogram (Nam)
+ and then Chars (Nam) = Name_Asm)
and then not Static_Concatenation (A)
then
- Establish_Transient_Scope (A, Sec_Stack => False);
+ Establish_Transient_Scope (A, Manage_Sec_Stack => False);
Resolve (A, Etype (F));
else
and then Is_Array_Type (Etype (F))
and then not Same_Ancestor (Etype (F), Etype (Expression (A)))
and then
- (Is_Limited_Type (Etype (F))
- or else Is_Limited_Type (Etype (Expression (A))))
+ (Is_Limited_Type (Etype (F))
+ or else Is_Limited_Type (Etype (Expression (A))))
then
Error_Msg_N
- ("conversion between unrelated limited array types "
- & "not allowed ('A'I-00246)", A);
+ ("conversion between unrelated limited array types not "
+ & "allowed ('A'I-00246)", A);
if Is_Limited_Type (Etype (F)) then
Explain_Limited_Type (Etype (F), A);
-- enabled only, otherwise the transient scope will not
-- be removed in the expansion of the wrapped construct.
- if (Is_Controlled (DDT) or else Has_Task (DDT))
- and then Expander_Active
+ if Expander_Active
+ and then (Needs_Finalization (DDT)
+ or else Has_Task (DDT))
then
- Establish_Transient_Scope (A, Sec_Stack => False);
+ Establish_Transient_Scope
+ (A, Manage_Sec_Stack => False);
end if;
end;
-- is already present. It may not be available if e.g. the subprogram is
-- declared in a child instance.
- -- If this is an initialization call for a type whose construction
- -- uses the secondary stack, and it is not a nested call to initialize
- -- a component, we do need to create a transient scope for it. We
- -- check for this by traversing the type in Check_Initialization_Call.
-
if Is_Inlined (Nam)
and then Has_Pragma_Inline (Nam)
and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration
null;
elsif Expander_Active
- and then Is_Type (Etype (Nam))
+ and then Ekind (Nam) = E_Function
and then Requires_Transient_Scope (Etype (Nam))
- and then
- (not Within_Init_Proc
- or else
- (not Is_Init_Proc (Nam) and then Ekind (Nam) /= E_Function))
then
- Establish_Transient_Scope (N, Sec_Stack => True);
+ Establish_Transient_Scope (N, Manage_Sec_Stack => True);
- -- If the call appears within the bounds of a loop, it will
- -- be rewritten and reanalyzed, nothing left to do here.
+ -- If the call appears within the bounds of a loop, it will be
+ -- rewritten and reanalyzed, nothing left to do here.
if Nkind (N) /= N_Function_Call then
return;
end if;
-
- elsif Is_Init_Proc (Nam)
- and then not Within_Init_Proc
- then
- Check_Initialization_Call (N, Nam);
end if;
-- A protected function cannot be called within the definition of the
Set_Analyzed (N, True);
end;
- -- Protected functions can return on the secondary stack, in which
- -- case we must trigger the transient scope mechanism.
+ -- Protected functions can return on the secondary stack, in which case
+ -- we must trigger the transient scope mechanism.
elsif Expander_Active
and then Requires_Transient_Scope (Etype (Nam))
then
- Establish_Transient_Scope (N, Sec_Stack => True);
+ Establish_Transient_Scope (N, Manage_Sec_Stack => True);
end if;
end Resolve_Entry_Call;
projects / gcc.git / commitdiff