public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r12-2061] [Ada] Transient scope cleanup
@ 2021-07-06 14:48 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2021-07-06 14:48 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:f037632e655c8348b06ffa797c9b1041a5a823ec
commit r12-2061-gf037632e655c8348b06ffa797c9b1041a5a823ec
Author: Bob Duff <duff@adacore.com>
Date: Fri May 7 10:41:03 2021 -0400
[Ada] Transient scope cleanup
gcc/ada/
* sem.ads (Node_To_Be_Wrapped): Minor comment fix.
* exp_ch7.adb (Establish_Transient_Scope): Misc cleanups and
comment improvements.
(Set_Node_To_Be_Wrapped): Remove -- not worth putting this code
in a separate procedure, called only once.
* sem_util.adb (Requires_Transient_Scope): Assert that our
parameter has the right Kind. It probably shouldn't be E_Void,
but that is passed in in some cases.
(Ensure_Minimum_Decoration): Move the call later, so we know Typ
is Present, and remove "if Present (Typ)" from this procedure.
* exp_aggr.adb (Convert_To_Assignments): Use membership test,
and avoid the "if False" idiom.
(Expand_Array_Aggregate): Remove a ??? comment.
* sem_ch8.adb (Push_Scope): Take advantage of the full coverage
rules for aggregates.
* sem_res.adb (Resolve_Declare_Expression): Remove test for
Is_Type -- that's all it can be. Use named notation in call to
Establish_Transient_Scope.
* libgnat/a-cdlili.adb (Adjust): Remove redundant code.
(Clear): Remove "pragma Warnings (Off);", which wasn't actually
suppressing any warnings.
Diff:
---
gcc/ada/exp_aggr.adb | 12 +-
gcc/ada/exp_ch7.adb | 474 +++++++++++++++++++++----------------------
gcc/ada/libgnat/a-cdlili.adb | 7 -
gcc/ada/sem.ads | 2 +-
gcc/ada/sem_ch8.adb | 86 ++++----
gcc/ada/sem_res.adb | 3 +-
gcc/ada/sem_util.adb | 12 +-
7 files changed, 287 insertions(+), 309 deletions(-)
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 7978b1caf7c..1b084366605 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -4919,13 +4919,11 @@ package body Exp_Aggr is
-- Just set the Delay flag in the cases where the transformation will be
-- done top down from above.
- if False
-
+ if
-- Internal aggregate (transformed when expanding the parent)
- or else Parent_Kind = N_Aggregate
- or else Parent_Kind = N_Extension_Aggregate
- or else Parent_Kind = N_Component_Association
+ Parent_Kind in
+ N_Aggregate | N_Extension_Aggregate | N_Component_Association
-- Allocator (see Convert_Aggr_In_Allocator)
@@ -6601,8 +6599,8 @@ package body Exp_Aggr is
-- For assignments we do the assignment in place if all the component
-- associations have compile-time known values, or are default-
-- initialized limited components, e.g. tasks. For other cases we
- -- create a temporary. The analysis for safety of on-line assignment
- -- is delicate, i.e. we don't know how to do it fully yet ???
+ -- create a temporary. A full analysis for safety of in-place assignment
+ -- is delicate.
-- For allocators we assign to the designated object in place if the
-- aggregate meets the same conditions as other in-place assignments.
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 469c9fbfb88..4c1e16d9e32 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -131,11 +131,6 @@ package body Exp_Ch7 is
-- 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;
@@ -155,9 +150,6 @@ package body Exp_Ch7 is
-- 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
@@ -5151,37 +5143,47 @@ package body Exp_Ch7 is
(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
@@ -5232,37 +5234,34 @@ package body Exp_Ch7 is
-----------------------------------
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
@@ -5277,30 +5276,198 @@ package body Exp_Ch7 is
------------------------------------
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 --
------------------------------
@@ -5323,8 +5490,8 @@ package body Exp_Ch7 is
-- 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
@@ -5338,9 +5505,8 @@ package body Exp_Ch7 is
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);
@@ -5950,177 +6116,6 @@ package body Exp_Ch7 is
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 --
---------------------------------
@@ -9890,15 +9885,6 @@ package body Exp_Ch7 is
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 --
----------------------------
diff --git a/gcc/ada/libgnat/a-cdlili.adb b/gcc/ada/libgnat/a-cdlili.adb
index 73c1e6d7827..75961a29ddb 100644
--- a/gcc/ada/libgnat/a-cdlili.adb
+++ b/gcc/ada/libgnat/a-cdlili.adb
@@ -130,11 +130,6 @@ is
pragma Assert (Container.Last.Next = null);
pragma Assert (Container.Length > 0);
- Container.First := null;
- Container.Last := null;
- Container.Length := 0;
- Zero_Counts (Container.TC);
-
Container.First := new Node_Type'(Src.Element, null, null);
Container.Last := Container.First;
Container.Length := 1;
@@ -232,9 +227,7 @@ is
Container.Last := null;
Container.Length := 0;
- pragma Warnings (Off);
Free (X);
- pragma Warnings (On);
end Clear;
------------------------
diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads
index a56ce937b91..2fdccf756a6 100644
--- a/gcc/ada/sem.ads
+++ b/gcc/ada/sem.ads
@@ -533,7 +533,7 @@ package Sem is
-- See Sem_Ch10 (Install_Parents, Remove_Parents).
Node_To_Be_Wrapped : Node_Id;
- -- Only used in transient scopes. Records the node which will be wrapped
+ -- Only used in transient scopes. Records the node that will be wrapped
-- by the transient block.
Actions_To_Be_Wrapped : Scope_Actions;
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index d3bbfebd0e7..f056a189b2d 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -8995,6 +8995,28 @@ package body Sem_Ch8 is
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;
@@ -9023,49 +9045,27 @@ package body Sem_Ch8 is
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: ");
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 494904faa55..3ebf93ae080 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -7521,7 +7521,6 @@ package body Sem_Res is
Node := First (Actions (N));
while Present (Node) loop
if Nkind (Node) = N_Object_Declaration
- and then Is_Type (Etype (Defining_Identifier (Node)))
and then Requires_Transient_Scope
(Etype (Defining_Identifier (Node)))
then
@@ -7534,7 +7533,7 @@ package body Sem_Res is
end;
if Need_Transient_Scope then
- Establish_Transient_Scope (Decl, True);
+ Establish_Transient_Scope (Decl, Manage_Sec_Stack => True);
else
Push_Scope (Scope (Defining_Identifier (Decl)));
end if;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 038c1ee686b..5c6a70134af 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -26956,6 +26956,8 @@ package body Sem_Util is
-- generated before the next instruction.
function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
+ pragma Assert (if Present (Id) then Ekind (Id) in E_Void | Type_Kind);
+
function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean;
-- This is called for untagged records and protected types, with
-- nondefaulted discriminants. Returns True if the size of function
@@ -27036,8 +27038,7 @@ package body Sem_Util is
-- Do not set Has_Controlled_Component on a class-wide equivalent
-- type. See Make_CW_Equivalent_Type.
- if Present (Typ)
- and then not Is_Frozen (Typ)
+ if not Is_Frozen (Typ)
and then Is_Base_Type (Typ)
and then (Is_Record_Type (Typ)
or else Is_Concurrent_Type (Typ)
@@ -27154,19 +27155,20 @@ package body Sem_Util is
-- Start of processing for Requires_Transient_Scope
begin
- Ensure_Minimum_Decoration (Id);
-
-- This is a private type which is not completed yet. This can only
-- happen in a default expression (of a formal parameter or of a
-- record component). Do not expand transient scope in this case.
if No (Typ) then
return False;
+ end if;
+
+ Ensure_Minimum_Decoration (Id);
-- Do not expand transient scope for non-existent procedure return or
-- string literal types.
- elsif Typ = Standard_Void_Type
+ if Typ = Standard_Void_Type
or else Ekind (Typ) = E_String_Literal_Subtype
then
return False;
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-07-06 14:48 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-07-06 14:48 [gcc r12-2061] [Ada] Transient scope cleanup Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).