-- Transient Blocks and Finalization Management --
--------------------------------------------------
- function Find_Transient_Context (N : Node_Id) return Node_Id;
- -- Locate a suitable context for arbitrary node N which may need to be
- -- serviced by a transient scope. Return Empty if no suitable context is
- -- available.
-
procedure Insert_Actions_In_Scope_Around
(N : Node_Id;
Clean : Boolean;
-- involves controlled objects or secondary stack usage, the corresponding
-- cleanup actions are performed at the end of the block.
- procedure Set_Node_To_Be_Wrapped (N : Node_Id);
- -- Set the field Node_To_Be_Wrapped of the current scope
-
procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id);
-- Shared processing for Store_xxx_Actions_In_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.
+ function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean;
+ -- Determine whether arbitrary Id denotes a package or subprogram [body]
+
+ function Find_Enclosing_Transient_Scope return Entity_Id;
+ -- Examine the scope stack looking for the nearest enclosing transient
+ -- scope within the innermost enclosing package or subprogram. Return
+ -- Empty if no such scope exists.
+
+ function Find_Transient_Context (N : Node_Id) return Node_Id;
+ -- Locate a suitable context for arbitrary node N which may need to be
+ -- serviced by a transient scope. Return Empty if no suitable context
+ -- is available.
procedure Delegate_Sec_Stack_Management;
-- Move the management of the secondary stack to the nearest enclosing
-- suitable scope.
- 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.
-
- function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean;
- -- Determine whether arbitrary Id denotes a package or subprogram [body]
+ procedure Create_Transient_Scope (Context : Node_Id);
+ -- Place a new scope on the scope stack in order to service construct
+ -- Context. Context is the node found by Find_Transient_Context. The
+ -- new scope may also manage the secondary stack.
----------------------------
-- Create_Transient_Scope --
----------------------------
- procedure Create_Transient_Scope (Constr : Node_Id) is
+ procedure Create_Transient_Scope (Context : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Iter_Loop : Entity_Id;
- Trans_Scop : Entity_Id;
+ Trans_Scop : constant Entity_Id :=
+ New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
begin
- Trans_Scop := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
Set_Etype (Trans_Scop, Standard_Void_Type);
+ -- Push a new scope, and set its Node_To_Be_Wrapped and Is_Transient
+ -- fields.
+
Push_Scope (Trans_Scop);
- Set_Node_To_Be_Wrapped (Constr);
+ Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := Context;
Set_Scope_Is_Transient;
-- The transient scope must also manage the secondary stack
-----------------------------------
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.
+ declare
+ Scope : Scope_Stack_Entry renames Scope_Stack.Table (Index);
+ begin
+ -- Prevent the search from going too far or within the scope
+ -- space of another unit.
- if Scop_Id = Standard_Standard then
- return;
+ if Scope.Entity = Standard_Standard then
+ return;
- -- No transient scope should be encountered during the traversal
- -- because Establish_Transient_Scope should have already handled
- -- this case.
+ -- 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;
+ elsif Scope.Is_Transient then
+ raise Program_Error;
- -- The construct which requires secondary stack management is
- -- always enclosed by a package or subprogram scope.
+ -- The construct that 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);
+ elsif Is_Package_Or_Subprogram (Scope.Entity) then
+ Set_Uses_Sec_Stack (Scope.Entity);
+ Check_Restriction (No_Secondary_Stack, N);
- return;
- end if;
+ return;
+ end if;
+ end;
end loop;
-- At this point no suitable scope was found. This should never occur
------------------------------------
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.
+ declare
+ Scope : Scope_Stack_Entry renames Scope_Stack.Table (Index);
+ begin
+ -- 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;
+ if Scope.Entity = Standard_Standard
+ or else Is_Package_Or_Subprogram (Scope.Entity)
+ then
+ exit;
- elsif Scop_Rec.Is_Transient then
- return Scop_Id;
- end if;
+ elsif Scope.Is_Transient then
+ return Scope.Entity;
+ end if;
+ end;
end loop;
return Empty;
end Find_Enclosing_Transient_Scope;
+ ----------------------------
+ -- Find_Transient_Context --
+ ----------------------------
+
+ function Find_Transient_Context (N : Node_Id) return Node_Id is
+ Curr : Node_Id := N;
+ Prev : Node_Id := Empty;
+
+ begin
+ while Present (Curr) loop
+ case Nkind (Curr) is
+
+ -- Declarations
+
+ -- 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 Curr;
+
+ -- Statements
+
+ -- 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_Delay_Relative_Statement
+ | N_Discriminant_Association
+ | N_Elsif_Part
+ | N_Entry_Body_Formal_Part
+ | N_Exit_Statement
+ | N_If_Statement
+ | N_Iteration_Scheme
+ | N_Terminate_Alternative
+ =>
+ pragma Assert (Present (Prev));
+ return Prev;
+
+ when N_Assignment_Statement =>
+ return Curr;
+
+ when N_Entry_Call_Statement
+ | N_Procedure_Call_Statement
+ =>
+ -- When an entry or procedure call acts as the alternative
+ -- of a conditional or timed entry call, the proper context
+ -- is that of the alternative.
+
+ if Nkind (Parent (Curr)) = N_Entry_Call_Alternative
+ and then Nkind (Parent (Parent (Curr))) in
+ N_Conditional_Entry_Call | N_Timed_Entry_Call
+ then
+ return Parent (Parent (Curr));
+
+ -- General case for entry or procedure calls
+
+ else
+ return Curr;
+ end if;
+
+ when N_Pragma =>
+
+ -- Pragma Check is not a valid transient context in
+ -- GNATprove mode because the pragma must remain unchanged.
+
+ if GNATprove_Mode
+ and then Get_Pragma_Id (Curr) = Pragma_Check
+ then
+ return Empty;
+
+ -- General case for pragmas
+
+ else
+ return Curr;
+ end if;
+
+ when N_Raise_Statement =>
+ return Curr;
+
+ when N_Simple_Return_Statement =>
+
+ -- A return statement is not a valid transient context when
+ -- the function itself requires transient scope management
+ -- because the result will be reclaimed too early.
+
+ if Requires_Transient_Scope (Etype
+ (Return_Applies_To (Return_Statement_Entity (Curr))))
+ then
+ return Empty;
+
+ -- General case for return statements
+
+ else
+ return Curr;
+ end if;
+
+ -- Special
+
+ when N_Attribute_Reference =>
+ if Is_Procedure_Attribute_Name (Attribute_Name (Curr)) then
+ return Curr;
+ end if;
+
+ -- An Ada 2012 iterator specification is not a valid context
+ -- because Analyze_Iterator_Specification already employs
+ -- special processing for it.
+
+ when N_Iterator_Specification =>
+ return Empty;
+
+ when N_Loop_Parameter_Specification =>
+
+ -- An iteration scheme is not a valid context because
+ -- routine Analyze_Iteration_Scheme already employs
+ -- special processing.
+
+ if Nkind (Parent (Curr)) = N_Iteration_Scheme then
+ return Empty;
+ else
+ return Parent (Curr);
+ end if;
+
+ -- Termination
+
+ -- The following nodes represent "dummy contexts" which do not
+ -- need to be wrapped.
+
+ when N_Component_Declaration
+ | N_Discriminant_Specification
+ | N_Parameter_Specification
+ =>
+ return Empty;
+
+ -- 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;
+
+ -- Default
+
+ when others =>
+ null;
+ end case;
+
+ Prev := Curr;
+ Curr := Parent (Curr);
+ end loop;
+
+ return Empty;
+ end Find_Transient_Context;
+
------------------------------
-- Is_Package_Or_Subprogram --
------------------------------
-- 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.
+ -- Do not create a new transient scope if there is already an enclosing
+ -- transient scope within the innermost enclosing package or subprogram.
if Present (Trans_Id) then
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.
+ -- Find the construct that must be serviced by a new transient scope, if
+ -- it exists.
Context := Find_Transient_Context (N);
end if;
end Expand_N_Package_Declaration;
- ----------------------------
- -- Find_Transient_Context --
- ----------------------------
-
- function Find_Transient_Context (N : Node_Id) return Node_Id is
- Curr : Node_Id;
- Prev : Node_Id;
-
- begin
- Curr := N;
- Prev := Empty;
- while Present (Curr) loop
- case Nkind (Curr) is
-
- -- Declarations
-
- -- 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 Curr;
-
- -- Statements
-
- -- 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_Delay_Relative_Statement
- | N_Discriminant_Association
- | N_Elsif_Part
- | N_Entry_Body_Formal_Part
- | N_Exit_Statement
- | N_If_Statement
- | N_Iteration_Scheme
- | N_Terminate_Alternative
- =>
- pragma Assert (Present (Prev));
- return Prev;
-
- when N_Assignment_Statement =>
- return Curr;
-
- when N_Entry_Call_Statement
- | N_Procedure_Call_Statement
- =>
- -- When an entry or procedure call acts as the alternative of a
- -- conditional or timed entry call, the proper context is that
- -- of the alternative.
-
- if Nkind (Parent (Curr)) = N_Entry_Call_Alternative
- and then Nkind (Parent (Parent (Curr))) in
- N_Conditional_Entry_Call | N_Timed_Entry_Call
- then
- return Parent (Parent (Curr));
-
- -- General case for entry or procedure calls
-
- else
- return Curr;
- end if;
-
- when N_Pragma =>
-
- -- Pragma Check is not a valid transient context in GNATprove
- -- mode because the pragma must remain unchanged.
-
- if GNATprove_Mode
- and then Get_Pragma_Id (Curr) = Pragma_Check
- then
- return Empty;
-
- -- General case for pragmas
-
- else
- return Curr;
- end if;
-
- when N_Raise_Statement =>
- return Curr;
-
- when N_Simple_Return_Statement =>
-
- -- A return statement is not a valid transient context when the
- -- function itself requires transient scope management because
- -- the result will be reclaimed too early.
-
- if Requires_Transient_Scope (Etype
- (Return_Applies_To (Return_Statement_Entity (Curr))))
- then
- return Empty;
-
- -- General case for return statements
-
- else
- return Curr;
- end if;
-
- -- Special
-
- when N_Attribute_Reference =>
- if Is_Procedure_Attribute_Name (Attribute_Name (Curr)) then
- return Curr;
- end if;
-
- -- An Ada 2012 iterator specification is not a valid context
- -- because Analyze_Iterator_Specification already employs special
- -- processing for it.
-
- when N_Iterator_Specification =>
- return Empty;
-
- when N_Loop_Parameter_Specification =>
-
- -- An iteration scheme is not a valid context because routine
- -- Analyze_Iteration_Scheme already employs special processing.
-
- if Nkind (Parent (Curr)) = N_Iteration_Scheme then
- return Empty;
- else
- return Parent (Curr);
- end if;
-
- -- Termination
-
- -- The following nodes represent "dummy contexts" which do not
- -- need to be wrapped.
-
- when N_Component_Declaration
- | N_Discriminant_Specification
- | N_Parameter_Specification
- =>
- return Empty;
-
- -- 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;
-
- -- Default
-
- when others =>
- null;
- end case;
-
- Prev := Curr;
- Curr := Parent (Curr);
- end loop;
-
- return Empty;
- end Find_Transient_Context;
-
---------------------------------
-- Has_Simple_Protected_Object --
---------------------------------
return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
end Node_To_Be_Wrapped;
- ----------------------------
- -- Set_Node_To_Be_Wrapped --
- ----------------------------
-
- procedure Set_Node_To_Be_Wrapped (N : Node_Id) is
- begin
- Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N;
- end Set_Node_To_Be_Wrapped;
-
----------------------------
-- Store_Actions_In_Scope --
----------------------------
procedure Push_Scope (S : Entity_Id) is
E : constant Entity_Id := Scope (S);
+ function Component_Alignment_Default return Component_Alignment_Kind;
+ -- Return Component_Alignment_Kind for the newly-pushed scope.
+
+ function Component_Alignment_Default return Component_Alignment_Kind is
+ begin
+ -- Each new scope pushed onto the scope stack inherits the component
+ -- alignment of the previous scope. This emulates the "visibility"
+ -- semantics of pragma Component_Alignment.
+
+ if Scope_Stack.Last > Scope_Stack.First then
+ return Scope_Stack.Table
+ (Scope_Stack.Last - 1).Component_Alignment_Default;
+
+ -- Otherwise, this is the first scope being pushed on the scope
+ -- stack. Inherit the component alignment from the configuration
+ -- form of pragma Component_Alignment (if any).
+
+ else
+ return Configuration_Component_Alignment;
+ end if;
+ end Component_Alignment_Default;
+
begin
if Ekind (S) = E_Void then
null;
Scope_Stack.Increment_Last;
- declare
- SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
-
- begin
- SST.Entity := S;
- SST.Save_Scope_Suppress := Scope_Suppress;
- SST.Save_Local_Suppress_Stack_Top := Local_Suppress_Stack_Top;
- SST.Save_Check_Policy_List := Check_Policy_List;
- SST.Save_Default_Storage_Pool := Default_Pool;
- SST.Save_No_Tagged_Streams := No_Tagged_Streams;
- SST.Save_SPARK_Mode := SPARK_Mode;
- SST.Save_SPARK_Mode_Pragma := SPARK_Mode_Pragma;
- SST.Save_Default_SSO := Default_SSO;
- SST.Save_Uneval_Old := Uneval_Old;
-
- -- Each new scope pushed onto the scope stack inherits the component
- -- alignment of the previous scope. This emulates the "visibility"
- -- semantics of pragma Component_Alignment.
-
- if Scope_Stack.Last > Scope_Stack.First then
- SST.Component_Alignment_Default :=
- Scope_Stack.Table
- (Scope_Stack.Last - 1).Component_Alignment_Default;
-
- -- Otherwise, this is the first scope being pushed on the scope
- -- stack. Inherit the component alignment from the configuration
- -- form of pragma Component_Alignment (if any).
-
- else
- SST.Component_Alignment_Default :=
- Configuration_Component_Alignment;
- end if;
-
- SST.Last_Subprogram_Name := null;
- SST.Is_Transient := False;
- SST.Node_To_Be_Wrapped := Empty;
- SST.Pending_Freeze_Actions := No_List;
- SST.Actions_To_Be_Wrapped := (others => No_List);
- SST.First_Use_Clause := Empty;
- SST.Is_Active_Stack_Base := False;
- SST.Previous_Visibility := False;
- SST.Locked_Shared_Objects := No_Elist;
- end;
+ Scope_Stack.Table (Scope_Stack.Last) :=
+ (Entity => S,
+ Save_Scope_Suppress => Scope_Suppress,
+ Save_Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
+ Save_Check_Policy_List => Check_Policy_List,
+ Save_Default_Storage_Pool => Default_Pool,
+ Save_No_Tagged_Streams => No_Tagged_Streams,
+ Save_SPARK_Mode => SPARK_Mode,
+ Save_SPARK_Mode_Pragma => SPARK_Mode_Pragma,
+ Save_Default_SSO => Default_SSO,
+ Save_Uneval_Old => Uneval_Old,
+ Component_Alignment_Default => Component_Alignment_Default,
+ Last_Subprogram_Name => null,
+ Is_Transient => False,
+ Node_To_Be_Wrapped => Empty,
+ Pending_Freeze_Actions => No_List,
+ Actions_To_Be_Wrapped => (others => No_List),
+ First_Use_Clause => Empty,
+ Is_Active_Stack_Base => False,
+ Previous_Visibility => False,
+ Locked_Shared_Objects => No_Elist);
if Debug_Flag_W then
Write_Str ("--> new scope: ");
projects / thirdparty / gcc.git / commitdiff
