[COMMITTED] ada: Fix restoration of parent link
When resetting the parent link after having restored the selected component node, the assertion used was incorrectly triggered when the traversal hits the members of the parameters association list, as in: This.Some_Func (Param1, Param2).Dispatching_Call When restoring the selected component for Dispatching_Call, the assertion was wrongly triggered when passed Param1 and Param2. gcc/ada/ * contracts.adb (Restore_Original_Selected_Component): Adjust assertion. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/contracts.adb | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 012ea33cf89..9d02887cfa1 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -4954,7 +4954,8 @@ package body Contracts is begin if Par /= Parent_Node then - pragma Assert (not Is_List_Member (Node)); + pragma Assert (not Is_List_Member (Node) + or else Nkind (Par) = N_Function_Call); Set_Parent (Node, Parent_Node); end if; -- 2.40.0
[COMMITTED] ada: Analyze pre/post on access-to-subprogram without a wrapper
From: Piotr Trojanek Aspects Pre/Post attached to an access-to-subprogram type were relocated to a spec of a wrapper subprogram and analyzed there; the body of the wrapper was only created with expansion enabled. However, there were several problems with this approach. When switch -gnat2022 was missing, we didn't relocate the Pre/Post aspects to wrapper and complained that their placement is incorrect (because we wrongly assumed that relocation is unconditional). Now we gently inform, that these aspects are Ada 2022 features that require -gnat20222 switch. When switch -gnata was missing, we entirely bypassed analysis of the Pre/Post aspects on access-to-subprogram. This was unlike for Pre/Post aspects on subprograms, which are checked for legality regardless of the -gnata switch. Finally, in the GNATprove backend we were picking the Pre/Post contract on an access-to-subprogram type from the wrapper, which was awkward as otherwise we had to ignore the wrapper specs and special-case for their missing bodies. In general, it is cleaner for GNATprove to extract the aspect expressions from where they originally appear and not from various expansion artifacts like access-to-subprogram wrappers (but the same applies to predication functions, type invariant procedures and default initialization procedures). Now we analyze the Pre/Post aspects on the types where they are originally attached, regardless of the -gnata switch. Once we adapt GNATprove to pick the aspect expression from there, we will stop creating the wrapper spec when expansion is disabled. gcc/ada/ * contracts.adb (Add_Pre_Post_Condition): Adapt to handle pre/post of an access-to-subprogram type. (Analyze_Type_Contract): Analyze pre/post of an access-to-subprogram. * contracts.ads (Analyze_Type_Contract): Adapt comment. * sem_ch3.adb (Build_Access_Subprogram_Wrapper): Copy pre/post aspects to wrapper spec and keep it on the type. * sem_prag.adb (Analyze_Pre_Post_Condition): Expect pre/post aspects on access-to-subprogram and complain if they appear without -gnat2022 switch. (Analyze_Pre_Post_Condition_In_Decl_Part): Adapt to handle pre/post on an access-to-subprogram type entity. * sem_attr.adb (Analyze_Attribute_Old_Result): Likewise. (Result): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/contracts.adb | 20 ++-- gcc/ada/contracts.ads | 2 ++ gcc/ada/sem_attr.adb | 13 + gcc/ada/sem_ch3.adb | 15 +++ gcc/ada/sem_prag.adb | 22 ++ 5 files changed, 54 insertions(+), 18 deletions(-) diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index d3ceaa92e10..012ea33cf89 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -311,10 +311,13 @@ package body Contracts is -- The four volatility refinement pragmas are ok for all types. -- Part_Of is ok for task types and protected types. -- Depends and Global are ok for task types. + -- + -- Precondition and Postcondition are added separately; they are allowed + -- for access-to-subprogram types. elsif Is_Type (Id) then declare -Is_OK : constant Boolean := +Is_OK_Classification : constant Boolean := Prag_Nam in Name_Async_Readers | Name_Async_Writers | Name_Effective_Reads @@ -326,9 +329,16 @@ package body Contracts is | Name_Global) or else (Ekind (Id) = E_Protected_Type and Prag_Nam = Name_Part_Of); + begin -if Is_OK then +if Is_OK_Classification then Add_Classification; + +elsif Ekind (Id) in Access_Subprogram_Kind +and then Prag_Nam in Name_Precondition + | Name_Postcondition +then + Add_Pre_Post_Condition; else -- The pragma is not a proper contract item @@ -1580,6 +1590,12 @@ package body Contracts is begin Check_Type_Or_Object_External_Properties (Type_Or_Obj_Id => Type_Id); + + -- Analyze Pre/Post on access-to-subprogram type + + if Is_Access_Subprogram_Type (Type_Id) then + Analyze_Entry_Or_Subprogram_Contract (Type_Id); + end if; end Analyze_Type_Contract; --- diff --git a/gcc/ada/contracts.ads b/gcc/ada/contracts.ads index 0625b9fc029..d52e1aaed4a 100644 --- a/gcc/ada/contracts.ads +++ b/gcc/ada/contracts.ads @@ -139,6 +139,8 @@ package Contracts is --Async_Writers --Effective_Reads --Effective_Writes + --Postcondition + --Precondition -- -- In the case of a protected or task type, there will also be -- a call
[COMMITTED] ada: Restore SPARK_Mode On for numerical functions
From: Yannick Moy GNATprove has ad-hoc support for the standard numerical functions, which consists in emitting an unprovable preconditions on cases which could lead to an overflow. These functions are thus valid to call from SPARK code. gcc/ada/ * libgnat/a-ngelfu.ads: Restore SPARK_Mode from context. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/a-ngelfu.ads | 6 -- 1 file changed, 6 deletions(-) diff --git a/gcc/ada/libgnat/a-ngelfu.ads b/gcc/ada/libgnat/a-ngelfu.ads index ae06ea710eb..f6d6c9643af 100644 --- a/gcc/ada/libgnat/a-ngelfu.ads +++ b/gcc/ada/libgnat/a-ngelfu.ads @@ -116,17 +116,14 @@ is Post => (if X = 0.0 then Tan'Result = 0.0); function Tan (X, Cycle : Float_Type'Base) return Float_Type'Base with - SPARK_Mode => Off, -- Tan can overflow for some values of X and Cycle Pre => Cycle > 0.0 and then abs Float_Type'Base'Remainder (X, Cycle) /= 0.25 * Cycle, Post => (if X = 0.0 then Tan'Result = 0.0); function Cot (X : Float_Type'Base) return Float_Type'Base with - SPARK_Mode => Off, -- Cot can overflow for some values of X Pre => X /= 0.0; function Cot (X, Cycle : Float_Type'Base) return Float_Type'Base with - SPARK_Mode => Off, -- Cot can overflow for some values of X and Cycle Pre => Cycle > 0.0 and then X /= 0.0 and then Float_Type'Base'Remainder (X, Cycle) /= 0.0 @@ -179,11 +176,9 @@ is Post => (if X > 0.0 and then Y = 0.0 then Arccot'Result = 0.0); function Sinh (X : Float_Type'Base) return Float_Type'Base with - SPARK_Mode => Off, -- Sinh can overflow for some values of X Post => (if X = 0.0 then Sinh'Result = 0.0); function Cosh (X : Float_Type'Base) return Float_Type'Base with - SPARK_Mode => Off, -- Cosh can overflow for some values of X Post => Cosh'Result >= 1.0 and then (if X = 0.0 then Cosh'Result = 1.0); @@ -192,7 +187,6 @@ is and then (if X = 0.0 then Tanh'Result = 0.0); function Coth (X : Float_Type'Base) return Float_Type'Base with - SPARK_Mode => Off, -- Coth can overflow for some values of X Pre => X /= 0.0, Post => abs Coth'Result >= 1.0; -- 2.40.0
[COMMITTED] ada: Simplify removal of formals from the scope
From: Piotr Trojanek Calls to Install_Formals are typically enclosed by Push_Scope/End_Scope. There were just two such calls that instead used Pop_Scope, but most likely that was by mistake. Cleanup related to handling of class-wide contracts. Behavior appears to be unaffected. gcc/ada/ * contracts.adb (Remove_Formals): Remove. (Preanalyze_Condition): Replace Pop_Scope with End_Scope. * sem_ch13.adb (Build_Discrete_Static_Predicate): Replace Pop_Scope with End_Scope; enclose Install_Formals within Push_Scope/End_Scope. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/contracts.adb | 21 + gcc/ada/sem_ch13.adb | 4 ++-- 2 files changed, 3 insertions(+), 22 deletions(-) diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 9d02887cfa1..65f341abc8f 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -4846,9 +4846,6 @@ package body Contracts is -- Traverse Expr and clear the Controlling_Argument of calls to -- nonabstract functions. - procedure Remove_Formals (Id : Entity_Id); - -- Remove formals from homonym chains and make them not visible - procedure Restore_Original_Selected_Component; -- Traverse Expr searching for dispatching calls to functions whose -- original node was a selected component, and replace them with @@ -4898,21 +4895,6 @@ package body Contracts is Remove_Ctrl_Args (Expr); end Remove_Controlling_Arguments; - - -- Remove_Formals -- - - - procedure Remove_Formals (Id : Entity_Id) is - F : Entity_Id := First_Formal (Id); - - begin - while Present (F) loop -Set_Is_Immediately_Visible (F, False); -Remove_Homonym (F); -Next_Formal (F); - end loop; - end Remove_Formals; - - -- Restore_Original_Selected_Component -- - @@ -5032,8 +5014,7 @@ package body Contracts is Preanalyze_Spec_Expression (Expr, Standard_Boolean); Inside_Class_Condition_Preanalysis := False; - Remove_Formals (Subp); - Pop_Scope; + End_Scope; -- If this preanalyzed condition has occurrences of dispatching calls -- using the Object.Operation notation, during preanalysis such calls diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 958b26ebb0d..85c9d92e630 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -9757,10 +9757,10 @@ package body Sem_Ch13 is -- Resolve new expression in function context - Install_Formals (Predicate_Function (Typ)); Push_Scope (Predicate_Function (Typ)); + Install_Formals (Predicate_Function (Typ)); Analyze_And_Resolve (Expr, Standard_Boolean); - Pop_Scope; + End_Scope; end if; end; end; -- 2.40.0
[COMMITTED] ada: Spurious error on string interpolation
From: Javier Miranda
The frontend reports spurious errors on operators found in
interpolated string literals.
gcc/ada/
* scans.ads (Inside_Interpolated_String_Expression): New variable.
* par-ch2.adb (P_Interpolated_String_Literal): Set/clear new
variable when parsing interpolated string expressions.
* scng.adb (Set_String): Skip processing operator symbols when we
arescanning an interpolated string literal.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/par-ch2.adb | 17 +
gcc/ada/scans.ads | 3 +++
gcc/ada/scng.adb| 10 +-
3 files changed, 25 insertions(+), 5 deletions(-)
diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb
index b6814bdec17..af92f5ac353 100644
--- a/gcc/ada/par-ch2.adb
+++ b/gcc/ada/par-ch2.adb
@@ -225,6 +225,7 @@ package body Ch2 is
function P_Interpolated_String_Literal return Node_Id is
Elements_List : constant List_Id := New_List;
NL_Node : Node_Id;
+ Saved_State : constant Boolean := Inside_Interpolated_String_Literal;
String_Node : Node_Id;
begin
@@ -245,9 +246,17 @@ package body Ch2 is
-- Interpolated expression
if Token = Tok_Left_Curly_Bracket then
- Scan; -- past '{'
- Append_To (Elements_List, P_Expression);
- T_Right_Curly_Bracket;
+ declare
+ Saved_In_Expr : constant Boolean :=
+Inside_Interpolated_String_Expression;
+
+ begin
+ Scan; -- past '{'
+ Inside_Interpolated_String_Expression := True;
+ Append_To (Elements_List, P_Expression);
+ Inside_Interpolated_String_Expression := Saved_In_Expr;
+ T_Right_Curly_Bracket;
+ end;
else
if Prev_Token = Tok_String_Literal then
NL_Node := New_Node (N_String_Literal, Token_Ptr);
@@ -266,7 +275,7 @@ package body Ch2 is
end loop;
end if;
- Inside_Interpolated_String_Literal := False;
+ Inside_Interpolated_String_Literal := Saved_State;
Set_Expressions (String_Node, Elements_List);
return String_Node;
diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads
index 19e13b6c703..00381bb4a55 100644
--- a/gcc/ada/scans.ads
+++ b/gcc/ada/scans.ads
@@ -482,6 +482,9 @@ package Scans is
-- or aspect. Used to allow/require nonstandard style rules for =>+ with
-- -gnatyt.
+ Inside_Interpolated_String_Expression : Boolean := False;
+ -- True while parsing an interpolated string expression
+
Inside_Interpolated_String_Literal : Boolean := False;
-- True while parsing an interpolated string literal
diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb
index abf9c68cd3d..c2707df5cab 100644
--- a/gcc/ada/scng.adb
+++ b/gcc/ada/scng.adb
@@ -951,12 +951,20 @@ package body Scng is
C3 : Character;
begin
+-- Skip processing operator symbols if we are scanning an
+-- interpolated string literal.
+
+if Inside_Interpolated_String_Literal
+ and then not Inside_Interpolated_String_Expression
+then
+ null;
+
-- Token_Name is currently set to Error_Name. The following
-- section of code resets Token_Name to the proper Name_Op_xx
-- value if the string is a valid operator symbol, otherwise it is
-- left set to Error_Name.
-if Slen = 1 then
+elsif Slen = 1 then
C1 := Source (Token_Ptr + 1);
case C1 is
--
2.40.0
[COMMITTED] ada: Add QNX specific version of System.Parameters
From: Johannes Kliemann The QNX runtimes used the default implementation of System.Parameters that defines a default stack size of 2 MB. The QNX specific version uses the QNX default stack size of 256 KB instead. gcc/ada/ * Makefile.rtl (QNX): Use s-parame__qnx.adb for s-parame.adb. * libgnat/s-parame__qnx.adb: Add QNX specific version of System.Parameters. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/Makefile.rtl | 1 + gcc/ada/libgnat/s-parame__qnx.adb | 81 +++ 2 files changed, 82 insertions(+) create mode 100644 gcc/ada/libgnat/s-parame__qnx.adb diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 2cfdd8dc613..3da32fa6668 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -1412,6 +1412,7 @@ ifeq ($(strip $(filter-out arm aarch64 %qnx,$(target_cpu) $(target_os))),) s-taspri.adshttp://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +-- + +-- This is the version for AArch64 QNX + +package body System.Parameters is + + - + -- Adjust_Storage_Size -- + - + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type is + begin + if Size = Unspecified_Size then + return Default_Stack_Size; + elsif Size < Minimum_Stack_Size then + return Minimum_Stack_Size; + else + return Size; + end if; + end Adjust_Storage_Size; + + + -- Default_Stack_Size -- + + + function Default_Stack_Size return Size_Type is + Default_Stack_Size : constant Integer; + pragma Import (C, Default_Stack_Size, "__gl_default_stack_size"); + begin + if Default_Stack_Size = -1 then + -- 256K is the default stack size on aarch64 QNX + return 256 * 1024; + elsif Size_Type (Default_Stack_Size) < Minimum_Stack_Size then + return Minimum_Stack_Size; + else + return Size_Type (Default_Stack_Size); + end if; + end Default_Stack_Size; + + + -- Minimum_Stack_Size -- + + + function Minimum_Stack_Size return Size_Type is + begin + -- 256 is the value of PTHREAD_STACK_MIN on QNX and + -- 12K is required for stack-checking. The value is + -- rounded up to a multiple of a 4K page. + return 16 * 1024; + end Minimum_Stack_Size; + +end System.Parameters; -- 2.40.0
[COMMITTED] ada: Refining handling of inlining for CCG
From: Arnaud Charlet By marking relevant functions inline when -gnatn is used. gcc/ada/ * sem_ch7.adb: Refine handling of inlining for CCG Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_ch7.adb | 9 ++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index aed09f30934..ecb4bbe3e56 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -319,8 +319,9 @@ package body Sem_Ch7 is function Set_Referencer_Of_Non_Subprograms return Boolean is begin -- An inlined subprogram body acts as a referencer - -- unless we generate C code since inlining is then - -- handled by the C compiler. + -- unless we generate C code without -gnatn where we want + -- to favor generating static inline functions as much as + -- possible. -- Note that we test Has_Pragma_Inline here in addition -- to Is_Inlined. We are doing this for a client, since @@ -329,7 +330,9 @@ package body Sem_Ch7 is -- should occur, so we need to catch all cases where the -- subprogram may be inlined by the client. - if (not CCG_Mode or else Has_Pragma_Inline_Always (Decl_Id)) + if (not CCG_Mode + or else Has_Pragma_Inline_Always (Decl_Id) + or else Inline_Active) and then (Is_Inlined (Decl_Id) or else Has_Pragma_Inline (Decl_Id)) then -- 2.40.0
[COMMITTED] ada: Fix retrieval of spec entity from entry body entity
From: Piotr Trojanek When retrieving entities of subprogram spec we only handled functions and procedures, but not entries. This had no consequences, because we then only applied checks to functions, but still is worth a cleanup, so the code is easier to adapt for access-to-subprogram entities as well. gcc/ada/ * sem_util.adb (Check_Result_And_Post_State): Properly handle entry bodies. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_util.adb | 3 +++ 1 file changed, 3 insertions(+) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 1839214332d..d71329bbcb2 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -4582,6 +4582,9 @@ package body Sem_Util is then Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl); + elsif Nkind (Subp_Decl) = N_Entry_Body then + Spec_Id := Corresponding_Spec (Subp_Decl); + else Spec_Id := Subp_Id; end if; -- 2.40.0
[COMMITTED] ada: Tune message for pre/post on access-to-subprogram in old Ada
From: Piotr Trojanek
Fix grammar in error message; make it consistent with a similar message
for pre/postcondition on formal subprogram.
gcc/ada/
* sem_prag.adb (Analyze_Pre_Post_Condition): Tune error message.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_prag.adb | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 88dacf5cc57..b74c60cd183 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -5245,7 +5245,7 @@ package body Sem_Prag is
then
if Ada_Version < Ada_2022 then
Error_Msg_Ada_2022_Feature
- ("pre/postcondition access-to-subprogram", Loc);
+ ("pre/postcondition on access-to-subprogram", Loc);
raise Pragma_Exit;
end if;
--
2.40.0
[COMMITTED] ada: Fix spurious error on nested instantiations with generic renaming
From: Eric Botcazou The problem is that the renaming slightly changes the form of a global reference that was saved during the analysis of a generic package, and that is sufficient to fool the code adjusting global references during the instantiation. gcc/ada/ * sem_ch12.adb (Copy_Generic_Node): Test the original node kind for the sake of consistency. For identifiers and other entity names and operators, accept an expanded name as associated node. Replace "or" with "or else" in condtion and fix its formatting. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_ch12.adb | 27 ++- 1 file changed, 18 insertions(+), 9 deletions(-) diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index a9a3e322917..2562d1a0812 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -7953,11 +7953,11 @@ package body Sem_Ch12 is -- Special casing for identifiers and other entity names and operators - if Nkind (New_N) in N_Character_Literal -| N_Expanded_Name -| N_Identifier -| N_Operator_Symbol -| N_Op + if Nkind (N) in N_Character_Literal +| N_Expanded_Name +| N_Identifier +| N_Operator_Symbol +| N_Op then if not Instantiating then @@ -8161,6 +8161,15 @@ package body Sem_Ch12 is then Set_Entity (New_N, Assoc); + -- Cope with the rewriting into expanded name that may have + -- occurred in between, e.g. in Check_Generic_Child_Unit for + -- generic renaming declarations. + + elsif Nkind (Assoc) = N_Expanded_Name then + Rewrite (N, New_Copy_Tree (Assoc)); + Set_Associated_Node (N, Assoc); + return Copy_Generic_Node (N, Parent_Id, Instantiating); + -- The name in the call may be a selected component if the -- call has not been analyzed yet, as may be the case for -- pre/post conditions in a generic unit. @@ -8171,10 +8180,10 @@ package body Sem_Ch12 is Set_Entity (New_N, Entity (Name (Assoc))); elsif Nkind (Assoc) in N_Entity -and then (Expander_Active or -(GNATprove_Mode - and then not In_Spec_Expression - and then not Inside_A_Generic)) +and then (Expander_Active + or else (GNATprove_Mode + and then not In_Spec_Expression + and then not Inside_A_Generic)) then -- Inlining case: we are copying a tree that contains -- global entities, which are preserved in the copy to be -- 2.40.0
[COMMITTED] ada: Crash on aggregate for tagged record with discriminants
From: Javier Miranda The frontend may crash processing an aggregate initializing a derived tagged record type that has discriminants. gcc/ada/ * sem_aggr.adb (Resolve_Record_Aggregate): For aggregates of derived tagged record types with discriminants, when collecting components from ancestors, pass to subprogram Gather_Components the parent type. Required to report errors on wrong aggregate components. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_aggr.adb | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index fd0779e66d7..edd495b8359 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -5632,7 +5632,7 @@ package body Sem_Aggr is end if; Record_Def := Type_Definition (Parent (Base_Type (Parent_Typ))); - Gather_Components (Empty, + Gather_Components (Parent_Typ, Component_List (Record_Extension_Part (Record_Def)), Governed_By => New_Assoc_List, Into => Components, -- 2.40.0
[COMMITTED] ada: Tune message for missing 'Result in Contract_Cases
From: Piotr Trojanek
Make the message consistent with the one for postcondition.
gcc/ada/
* sem_util.adb (Check_Result_And_Post_State): Tune message.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_util.adb | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 9d12ee71d93..1839214332d 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -4644,7 +4644,8 @@ package body Sem_Util is
-- attribute 'Result.
elsif Present (Case_Prag) and then not Seen_In_Case then
- Error_Msg_N ("contract cases do not mention result?.t?", Case_Prag);
+ Error_Msg_N
+ ("contract cases do not mention function result?.t?", Case_Prag);
-- The function has non-trivial postconditions only and they do not
-- mention attribute 'Result.
--
2.40.0
[COMMITTED] ada: Fix crash on vector initialization
Initializing a vector using Vec : V.Vector := [Some_Type'(Some_Abstract_Type with F => 0)]; may crash the compiler. The expander marks the N_Extension_Aggregate for delayed expansion which never happens and incorrectly ends up in gigi. The delayed expansion is needed for nested aggregates, which the original code is testing for, but container aggregates are handled differently. Such assignments to container aggregates are later transformed into procedure calls to the procedures named in the Aggregate aspect definition, for which the delayed expansion is not required/expected. gcc/ada/ * exp_aggr.adb (Convert_To_Assignments): Do not mark node for delayed expansion if parent type has the Aggregate aspect. * sem_util.adb (Is_Container_Aggregate): Move... * sem_util.ads (Is_Container_Aggregate): ... here and make it public. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 7 +-- gcc/ada/sem_util.adb | 3 --- gcc/ada/sem_util.ads | 3 +++ 3 files changed, 8 insertions(+), 5 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index a6a7d810185..75e5e1402df 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -5000,9 +5000,12 @@ package body Exp_Aggr is if -- Internal aggregate (transformed when expanding the parent) + -- excluding the Container aggregate as these are transformed to + -- procedure call later. - Parent_Kind in - N_Aggregate | N_Extension_Aggregate | N_Component_Association + (Parent_Kind in +N_Component_Association | N_Aggregate | N_Extension_Aggregate +and then not Is_Container_Aggregate (Parent_Node)) -- Allocator (see Convert_Aggr_In_Allocator) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 64abfb11ce5..a42b2dff60f 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -132,9 +132,6 @@ package body Sem_Util is -- Determine whether arbitrary entity Id denotes an atomic object as per -- RM C.6(7). - function Is_Container_Aggregate (Exp : Node_Id) return Boolean; - -- Is the given expression a container aggregate? - generic with function Is_Effectively_Volatile_Entity (Id : Entity_Id) return Boolean; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index b5bcd267e33..d1bbc6af0e8 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1475,6 +1475,9 @@ package Sem_Util is -- Return True if the loop has no side effect and can therefore be -- marked for removal. Return False if N is not a N_Loop_Statement. + function Is_Container_Aggregate (Exp : Node_Id) return Boolean; + -- Is the given expression a container aggregate? + function Is_Newly_Constructed (Exp : Node_Id; Context_Requires_NC : Boolean) return Boolean; -- Indicates whether a given expression is "newly constructed" (RM 4.4). -- 2.40.0
[COMMITTED] ada: Reuse routine for getting from body entity to spec entity
From: Piotr Trojanek Cleanup related to handling of access-to-subprogram types with Pre and Post aspects. Behavior is unaffected. gcc/ada/ * sem_util.adb (Check_Result_And_Post_State): Replace low-level navigation with a high-level Unique_Entity. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_util.adb | 22 +- 1 file changed, 1 insertion(+), 21 deletions(-) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index d71329bbcb2..64abfb11ce5 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -4546,13 +4546,12 @@ package body Sem_Util is -- Local variables Items: constant Node_Id := Contract (Subp_Id); - Subp_Decl: constant Node_Id := Unit_Declaration_Node (Subp_Id); Case_Prag: Node_Id := Empty; Post_Prag: Node_Id := Empty; Prag : Node_Id; Seen_In_Case : Boolean := False; Seen_In_Post : Boolean := False; - Spec_Id : Entity_Id; + Spec_Id : constant Entity_Id := Unique_Entity (Subp_Id); -- Start of processing for Check_Result_And_Post_State @@ -4570,25 +4569,6 @@ package body Sem_Util is return; end if; - -- Retrieve the entity of the subprogram spec (if any) - - if Nkind (Subp_Decl) = N_Subprogram_Body -and then Present (Corresponding_Spec (Subp_Decl)) - then - Spec_Id := Corresponding_Spec (Subp_Decl); - - elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub -and then Present (Corresponding_Spec_Of_Stub (Subp_Decl)) - then - Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl); - - elsif Nkind (Subp_Decl) = N_Entry_Body then - Spec_Id := Corresponding_Spec (Subp_Decl); - - else - Spec_Id := Subp_Id; - end if; - -- Examine all postconditions for attribute 'Result and a post-state Prag := Pre_Post_Conditions (Items); -- 2.40.0
[COMMITTED] ada: Repair support for user-defined literals in arithmetic operators
From: Eric Botcazou
It was partially broken to fix a regression in error reporting, because the
fix was applied to the first pass of resolution instead of the second pass,
as needs to be done for user-defined literals.
gcc/ada/
* sem_ch4.ads (Unresolved_Operator): New procedure.
* sem_ch4.adb (Has_Possible_Literal_Aspects): Rename into...
(Has_Possible_User_Defined_Literal): ...this. Tidy up.
(Operator_Check): Accept again unresolved operators if they have a
possible user-defined literal as operand. Factor out the handling
of the general error message into...
(Unresolved_Operator): ...this new procedure.
* sem_res.adb (Resolve): Be prepared for unresolved operators on
entry in Ada 2022 or later. If they are still unresolved on exit,
call Unresolved_Operator to give the error message.
(Try_User_Defined_Literal): Tidy up.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_ch4.adb | 254 +---
gcc/ada/sem_ch4.ads | 3 +
gcc/ada/sem_res.adb | 54 ++
3 files changed, 156 insertions(+), 155 deletions(-)
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index c8bb99b6716..c76f2874957 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -256,8 +256,8 @@ package body Sem_Ch4 is
-- type is not directly visible. The routine uses this type to emit a more
-- informative message.
- function Has_Possible_Literal_Aspects (N : Node_Id) return Boolean;
- -- Ada_2022: if an operand is a literal it may be subject to an
+ function Has_Possible_User_Defined_Literal (N : Node_Id) return Boolean;
+ -- Ada 2022: if an operand is a literal, it may be subject to an
-- implicit conversion to a type for which a user-defined literal
-- function exists. During the first pass of type resolution we do
-- not know the context imposed on the literal, so we assume that
@@ -7572,19 +7572,11 @@ package body Sem_Ch4 is
if Etype (N) = Any_Type then
declare
-L : Node_Id;
-R : Node_Id;
-Op_Id : Entity_Id := Empty;
+L : constant Node_Id :=
+ (if Nkind (N) in N_Binary_Op then Left_Opnd (N) else Empty);
+R : constant Node_Id := Right_Opnd (N);
begin
-R := Right_Opnd (N);
-
-if Nkind (N) in N_Binary_Op then
- L := Left_Opnd (N);
-else
- L := Empty;
-end if;
-
-- If either operand has no type, then don't complain further,
-- since this simply means that we have a propagated error.
@@ -7665,9 +7657,10 @@ package body Sem_Ch4 is
then
return;
-elsif Present (Entity (N))
- and then Has_Possible_Literal_Aspects (N)
-then
+-- The handling of user-defined literals is deferred to the second
+-- pass of resolution.
+
+elsif Has_Possible_User_Defined_Literal (N) then
return;
-- If we have a logical operator, one of whose operands is
@@ -7882,117 +7875,19 @@ package body Sem_Ch4 is
end if;
end if;
--- If we fall through then just give general message. Note that in
--- the following messages, if the operand is overloaded we choose
--- an arbitrary type to complain about, but that is probably more
--- useful than not giving a type at all.
-
-if Nkind (N) in N_Unary_Op then
- Error_Msg_Node_2 := Etype (R);
- Error_Msg_N ("operator& not defined for}", N);
- return;
-
-else
- if Nkind (N) in N_Binary_Op then
- if not Is_Overloaded (L)
-and then not Is_Overloaded (R)
-and then Base_Type (Etype (L)) = Base_Type (Etype (R))
- then
- Error_Msg_Node_2 := First_Subtype (Etype (R));
- Error_Msg_N ("there is no applicable operator& for}", N);
-
- else
- -- Another attempt to find a fix: one of the candidate
- -- interpretations may not be use-visible. This has
- -- already been checked for predefined operators, so
- -- we examine only user-defined functions.
-
- Op_Id := Get_Name_Entity_Id (Chars (N));
-
- while Present (Op_Id) loop
-if Ekind (Op_Id) /= E_Operator
- and then Is_Overloadable (Op_Id)
-then
- if not Is_Immediately_Visible (Op_Id)
- and then not In_Use (Scope (Op_Id))
- and then not Is_Abstract_Subprogram (Op_Id)
-
[COMMITTED] ada: Accept parameters of enclosing subprograms in exceptional cases
From: Piotr Trojanek Rules about parameters of modes OUT and IN OUT in aspect Exceptional_Cases only apply to the parameters of the current subprogram. gcc/ada/ * sem_res.adb (Resolve_Entity_Name): Refine rules for Exceptional_Cases. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_res.adb | 1 + 1 file changed, 1 insertion(+) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 6d4bef8d38e..066072a6afe 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8122,6 +8122,7 @@ package body Sem_Res is -- data from the object. if Ekind (E) in E_Out_Parameter | E_In_Out_Parameter + and then Scope (E) = Current_Scope and then Within_Exceptional_Cases_Consequence (N) and then not In_Attribute_Old (N) and then not (Nkind (Parent (N)) = N_Attribute_Reference -- 2.40.0
[COMMITTED] ada: Restore parent link for both lists and nodes in class-wide condition
From: Piotr Trojanek When preanalysing class-wide conditions, we restore "Function (Object)" to its original "Object.Function" notation. This requires the Parent links to be fixed. We did it for nodes; now we do it for lists as well. This patch is enough to fix assertion failure in CCG and to make the tree well-connected. Perhaps there is a more elegant solution, but that remains to be investigated. gcc/ada/ * contracts.adb (Fix_Parent): Fir part both for lists and nodes. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/contracts.adb | 8 +--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 65f341abc8f..15b65ee4c06 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -4936,9 +4936,11 @@ package body Contracts is begin if Par /= Parent_Node then - pragma Assert (not Is_List_Member (Node) - or else Nkind (Par) = N_Function_Call); - Set_Parent (Node, Parent_Node); + if Is_List_Member (Node) then + Set_List_Parent (List_Containing (Node), Parent_Node); + else + Set_Parent (Node, Parent_Node); + end if; end if; return OK; -- 2.40.0
[COMMITTED] ada: Fix wrong finalization for call to BIP function in conditional expression
From: Eric Botcazou This happens when the call is a dependent expression of the conditional expression, and the conditional expression is either the expression of a simple return statement or the return expression of an expression function. The reason is that the special processing of "tail calls" for BIP functions, i.e. calls that are the expression of simple return statements or the return expression of expression functions, is not applied. This change makes sure that it is applied by distributing the simple return statements enclosing conditional expressions into the dependent expressions of the conditional expressions in almost all cases. As a side effect, this elides a temporary in the nonlimited by-reference case, as well as a pair of calls to Adjust/Finalize in the nonlimited controlled case. gcc/ada/ * exp_ch4.adb (Expand_N_Case_Expression): Distribute simple return statements enclosing the conditional expression into the dependent expressions in almost all cases. (Expand_N_If_Expression): Likewise. (Process_Transient_In_Expression): Adjust to the above distribution. * exp_ch6.adb (Expand_Ctrl_Function_Call): Deal with calls in the dependent expressions of a conditional expression. * sem_ch6.adb (Analyze_Function_Return): Deal with the rewriting of a simple return statement during the resolution of its expression. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch4.adb | 171 +++- gcc/ada/exp_ch6.adb | 10 ++- gcc/ada/sem_ch6.adb | 12 +++- 3 files changed, 138 insertions(+), 55 deletions(-) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 7be240bce0e..3f864f2675c 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -5401,17 +5401,6 @@ package body Exp_Ch4 is -- when minimizing expressions with actions (e.g. when generating C -- code) since it allows us to do the optimization below in more cases. - -- Small optimization: when the case expression appears in the context - -- of a simple return statement, expand into - - --case X is - -- when A => - -- return AX; - -- when B => - -- return BX; - -- ... - --end case; - Case_Stmt := Make_Case_Statement (Loc, Expression => Expression (N), @@ -5425,17 +5414,29 @@ package body Exp_Ch4 is Set_From_Conditional_Expression (Case_Stmt); Acts := New_List; + -- Small optimization: when the case expression appears in the context + -- of a simple return statement, expand into + + --case X is + -- when A => + -- return AX; + -- when B => + -- return BX; + -- ... + --end case; + + -- This makes the expansion much easier when expressions are calls to + -- a BIP function. But do not perform it when the return statement is + -- within a predicate function, as this causes spurious errors. + + Optimize_Return_Stmt := +Nkind (Par) = N_Simple_Return_Statement and then not In_Predicate; + -- Scalar/Copy case if Is_Copy_Type (Typ) then Target_Typ := Typ; - -- Do not perform the optimization when the return statement is - -- within a predicate function, as this causes spurious errors. - - Optimize_Return_Stmt := - Nkind (Par) = N_Simple_Return_Statement and then not In_Predicate; - -- Otherwise create an access type to handle the general case using -- 'Unrestricted_Access. @@ -5498,16 +5499,6 @@ package body Exp_Ch4 is -- scalar types. This approach avoids big copies and covers the -- limited and unconstrained cases. --- Generate: ---AX'Unrestricted_Access - -if not Is_Copy_Type (Typ) then - Alt_Expr := - Make_Attribute_Reference (Alt_Loc, - Prefix => Relocate_Node (Alt_Expr), - Attribute_Name => Name_Unrestricted_Access); -end if; - -- Generate: --return AX['Unrestricted_Access]; @@ -5520,6 +5511,13 @@ package body Exp_Ch4 is --Target := AX['Unrestricted_Access]; else + if not Is_Copy_Type (Typ) then + Alt_Expr := +Make_Attribute_Reference (Alt_Loc, + Prefix => Relocate_Node (Alt_Expr), + Attribute_Name => Name_Unrestricted_Access); + end if; + LHS := New_Occurrence_Of (Target, Loc); Set_Assignment_OK (LHS); @@ -5789,6 +5787,7 @@ package body Exp_Ch4 is Loc : constant Source_Ptr := Sloc (N); Thenx : constant Node_Id:= Next (Cond); Elsex : constant Node_Id:= Next (The
[COMMITTED] ada: Remove redundant protection against empty lists
From: Piotr Trojanek Calls to First on No_List intentionally return Empty, so explicit guards against No_List are unnecessary. Code cleanup; semantics is unaffected. gcc/ada/ * sem_util.adb (Check_Function_Writable_Actuals): Remove guard against a membership test with no alternatives; simplify with a membership test. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_util.adb | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a42b2dff60f..34ea06432cf 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2882,9 +2882,7 @@ package body Sem_Util is Collect_Identifiers (Right_Opnd (N)); end if; - if Nkind (N) in N_In | N_Not_In - and then Present (Alternatives (N)) - then + if Nkind (N) in N_Membership_Test then Expr := First (Alternatives (N)); while Present (Expr) loop Collect_Identifiers (Expr); -- 2.40.0
[COMMITTED] ada: Fix wrong result for membership test of null in null-excluding access type
From: Eric Botcazou The result must be False as per the RM 4.5.2 (30.2/4) clause. gcc/ada/ * exp_ch4.adb (Expand_N_In): Deal specifically with a null operand. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch4.adb | 8 +--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 3f864f2675c..537d7a6311c 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -6972,11 +6972,13 @@ package body Exp_Ch4 is -- If the null exclusion checks are not compatible, need to -- perform further checks. In other words, we cannot have - -- Ltyp including null and Typ excluding null. All other cases - -- are OK. + -- Ltyp including null or Lop being null, and Typ excluding + -- null. All other cases are OK. Check_Null_Exclusion := - Can_Never_Be_Null (Typ) and then not Can_Never_Be_Null (Ltyp); + Can_Never_Be_Null (Typ) + and then (not Can_Never_Be_Null (Ltyp) + or else Nkind (Lop) = N_Null); Typ := Designated_Type (Typ); end if; -- 2.40.0
[COMMITTED] ada: Default_Component_Value trumps Initialize/Normalize_Scalars
From: Steve Baird If the Default_Component_Value aspect is specified for an array type, then specifying Initialize_Scalars or Normalize_Scalars should have no effect on the default initialization of an object of the array type. gcc/ada/ * exp_ch3.adb (Expand_N_Object_Declaration.Default_Initialize_Object): Add test for specified Default_Component_Value aspect when deciding whether either Initialize_Scalars or Normalize_Scalars impacts default initialization of an array object. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch3.adb | 6 ++ 1 file changed, 6 insertions(+) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index e23a3fde15c..5f651bacafb 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6897,6 +6897,12 @@ package body Exp_Ch3 is and then not Has_Predicates (Component_Type (Typ)) + -- Array default component value takes precedence over + -- Init_Or_Norm_Scalars. + + and then No (Find_Aspect (Typ, + Aspect_Default_Component_Value)) + -- The component type must have a single initialization value and then Simple_Initialization_OK (Component_Type (Typ)) -- 2.40.0
[COMMITTED] ada: Fix memory leak in multi-dimensional array aggregate of Vector
From: Eric Botcazou It comes from a superfluous adjustment for subarray components. gcc/ada/ * exp_aggr.adb (Initialize_Array_Component): Fix condition detecting the nested case that requires an adjustment. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 75e5e1402df..c4a016ed3d4 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -1459,7 +1459,7 @@ package body Exp_Aggr is and then not Is_Build_In_Place_Function_Call (Init_Expr) and then not (Is_Array_Type (Comp_Typ) - and then Is_Controlled (Component_Type (Comp_Typ)) + and then Needs_Finalization (Component_Type (Comp_Typ)) and then Nkind (Expr) = N_Aggregate) then Adj_Call := -- 2.40.0
[COMMITTED] ada: Fix small fallout of previous change
From: Eric Botcazou The same guard must be added to Expand_Simple_Function_Return as the one that was added to Analyze_Function_Return. gcc/ada/ * exp_ch6.adb (Expand_Simple_Function_Return): Deal with a rewriting of the simple return during the adjustment of its expression. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch6.adb | 7 +++ 1 file changed, 7 insertions(+) diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index bd4f4a1412d..87560462315 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6641,6 +6641,13 @@ package body Exp_Ch6 is if Is_Boolean_Type (Exp_Typ) and then Nonzero_Is_True (Exp_Typ) then Adjust_Condition (Exp); Adjust_Result_Type (Exp, Exp_Typ); + + -- The adjustment of the expression may have rewritten the return + -- statement itself, e.g. when it is turned into an if expression. + + if Nkind (N) /= N_Simple_Return_Statement then +return; + end if; end if; -- Do validity check if enabled for returns -- 2.40.0
[COMMITTED] ada: Fix crash on semi-recursive call in access-to-subprogram contract
From: Piotr Trojanek Calls to access-to-subprogram from its own pre/post aspects are rejected as illegal, e.g.: type F is access function (X : Natural) return Boolean with Pre => F.all (X); but they caused an assertion failure in detection of recursive calls. Now they are properly recognized as recursive, but the error is suppressed, because it has been already posted at the call node. gcc/ada/ * sem_res.adb (Invoked_With_Different_Arguments): Use Get_Called_Entity, which properly deals with calls via an access-to-subprogram; fix inconsistent use of a Call object declared in enclosing subprogram. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_res.adb | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 1d4b9acb8ea..8a5f87b80ed 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -947,7 +947,7 @@ package body Sem_Res is -- function Invoked_With_Different_Arguments (N : Node_Id) return Boolean is - Subp : constant Entity_Id := Entity (Name (N)); + Subp : constant Entity_Id := Get_Called_Entity (N); Actual : Node_Id; Formal : Entity_Id; @@ -956,7 +956,7 @@ package body Sem_Res is -- Determine whether the formals of the invoked subprogram are not -- used as actuals in the call. - Actual := First_Actual (Call); + Actual := First_Actual (N); Formal := First_Formal (Subp); while Present (Actual) and then Present (Formal) loop -- 2.40.0
[COMMITTED] ada: Allow attributes like First and Last to be read in Exceptional_Cases
From: Piotr Trojanek Attributes that do not read data from the object can be safely used in consequences of Exceptional_Cases regardless of the parameter passing mode. gcc/ada/ * sem_res.adb (Resolve_Entity_Name): Relax rules for Exceptional_Cases. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_res.adb | 10 +- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index a31077a5f33..6d4bef8d38e 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8117,11 +8117,19 @@ package body Sem_Res is -- Parameters of modes OUT or IN OUT of the subprogram shall not -- occur in the consequences of an exceptional contract unless -- they are either passed by reference or occur in the prefix --- of a reference to the 'Old attribute. +-- of a reference to the 'Old attribute. For convenience, we also +-- allow them as prefixes of attributes that do not actually read +-- data from the object. if Ekind (E) in E_Out_Parameter | E_In_Out_Parameter and then Within_Exceptional_Cases_Consequence (N) and then not In_Attribute_Old (N) + and then not (Nkind (Parent (N)) = N_Attribute_Reference + and then +Attribute_Name (Parent (N)) in Name_Constrained + | Name_First + | Name_Last + | Name_Length) and then not Is_By_Reference_Type (Etype (E)) and then not Is_Aliased (E) then -- 2.40.0
[COMMITTED] ada: Fix internal error with pragma Compile_Time_{Warning, Error}
From: Eric Botcazou This happens when the pragmas are deferred to the back-end from an external unit to the main unit that is generic, because the back-end does not compile a main unit that is generic. gcc/ada/ * sem_prag.adb (Process_Compile_Time_Warning_Or_Error): Do not defer anything to the back-end when the main unit is generic. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_prag.adb | 9 +++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index b74c60cd183..0d62b04cc37 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -8137,7 +8137,9 @@ package body Sem_Prag is -- then. For example, if the expression is "Record_Type'Size /= 32" -- it might be known after the back end has determined the size of -- Record_Type. We do not defer validation if we're inside a generic - -- unit, because we will have more information in the instances. + -- unit, because we will have more information in the instances, and + -- this ultimately applies to the main unit itself, because it is not + -- compiled by the back end when it is generic. if Compile_Time_Known_Value (Arg1x) then Validate_Compile_Time_Warning_Or_Error (N, Sloc (Arg1)); @@ -8155,7 +8157,10 @@ package body Sem_Prag is end if; end loop; -if No (P) then +if No (P) + and then +Nkind (Unit (Cunit (Main_Unit))) not in N_Generic_Declaration +then Defer_Compile_Time_Warning_Error_To_BE (N); end if; end if; -- 2.40.0
[COMMITTED] ada: Fix wrong finalization for loop on indexed container
From: Eric Botcazou The problem is that a transient temporary created for the constant indexing of the container is finalized almost immediately after its creation. gcc/ada/ * exp_util.adb (Is_Finalizable_Transient.Is_Indexed_Container): New predicate to detect a temporary created to hold the result of a constant indexing on a container. (Is_Finalizable_Transient.Is_Iterated_Container): Adjust a couple of obsolete comments. (Is_Finalizable_Transient): Return False if Is_Indexed_Container returns True on the object. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_util.adb | 102 +-- 1 file changed, 99 insertions(+), 3 deletions(-) diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index f010dac4978..2582524b1dd 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -8323,6 +8323,13 @@ package body Exp_Util is function Is_Allocated (Trans_Id : Entity_Id) return Boolean; -- Determine whether transient object Trans_Id is allocated on the heap + function Is_Indexed_Container +(Trans_Id : Entity_Id; + First_Stmt : Node_Id) return Boolean; + -- Determine whether transient object Trans_Id denotes a container which + -- is in the process of being indexed in the statement list starting + -- from First_Stmt. + function Is_Iterated_Container (Trans_Id : Entity_Id; First_Stmt : Node_Id) return Boolean; @@ -8597,6 +8604,91 @@ package body Exp_Util is and then Nkind (Expr) = N_Allocator; end Is_Allocated; + -- + -- Is_Indexed_Container -- + -- + + function Is_Indexed_Container +(Trans_Id : Entity_Id; + First_Stmt : Node_Id) return Boolean + is + Aspect : Node_Id; + Call : Node_Id; + Index : Entity_Id; + Param : Node_Id; + Stmt : Node_Id; + Typ: Entity_Id; + + begin + -- It is not possible to iterate over containers in non-Ada 2012 code + + if Ada_Version < Ada_2012 then +return False; + end if; + + Typ := Etype (Trans_Id); + + -- Handle access type created for the reference below + + if Is_Access_Type (Typ) then +Typ := Designated_Type (Typ); + end if; + + -- Look for aspect Constant_Indexing. It may be part of a type + -- declaration for a container, or inherited from a base type + -- or parent type. + + Aspect := Find_Value_Of_Aspect (Typ, Aspect_Constant_Indexing); + + if Present (Aspect) then +Index := Entity (Aspect); + +-- Examine the statements following the container object and +-- look for a call to the default indexing routine where the +-- first parameter is the transient. Such a call appears as: + +-- It : Access_To_Constant_Reference_Type := +--Constant_Indexing (Tran_Id.all, ...)'reference; + +Stmt := First_Stmt; +while Present (Stmt) loop + + -- Detect an object declaration which is initialized by a + -- controlled function call. + + if Nkind (Stmt) = N_Object_Declaration + and then Present (Expression (Stmt)) + and then Nkind (Expression (Stmt)) = N_Reference + and then Nkind (Prefix (Expression (Stmt))) = N_Function_Call + then + Call := Prefix (Expression (Stmt)); + + -- The call must invoke the default indexing routine of + -- the container and the transient object must appear as + -- the first actual parameter. Skip any calls whose names + -- are not entities. + + if Is_Entity_Name (Name (Call)) +and then Entity (Name (Call)) = Index +and then Present (Parameter_Associations (Call)) + then + Param := First (Parameter_Associations (Call)); + + if Nkind (Param) = N_Explicit_Dereference + and then Entity (Prefix (Param)) = Trans_Id + then +return True; + end if; + end if; + end if; + + Next (Stmt); +end loop; + end if; + + return False; + end Is_Indexed_Container; + --- -- Is_Iterated_Container -- --- @@ -8621,7 +8713,7 @@ package body Exp_Util is Typ := Etype (Trans_Id); - -- Handle access type created for secondary stack use + -- Handle access type created for the reference below if Is_Access_Type
[COMMITTED] ada: Attach pre/post on access-to-subprogram to internal subprogram type
From: Piotr Trojanek Aspects Pre/Post that annotate access-to-subprogram type were attached to the source entity (whose kind is either E_Access_Subprogram_Type or E_Access_Protected_Subprogram_Type). However, it is more convenient to attach them to the internal entity (whose kind is E_Subprogram_Type), so that both Pre/Post aspects and First_Formal/Next_Formal chain are attached to the same entity, just like for ordinary subprograms. The drawback of having the Post aspect attached to an internal entity is that name in prefixes of attribute Result no longer match the name of entity where this Post aspect is attached. However, currently there is no code that relies on this matching and, in general, there are fewer routines that deal with attribute Result so they are easier to adapt than the code that queries the Pre/Post aspects. gcc/ada/ * contracts.adb (Add_Pre_Post_Condition): Attach pre/post aspects to E_Subprogram_Type entity. (Analyze_Entry_Or_Subprogram_Contract): Adapt to use full type declaration for a contract attached to E_Subprogram_Type entity. * sem_prag.adb (Analyze_Pre_Post_Condition): Add pre/post aspects to the designed type. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/contracts.adb | 12 gcc/ada/sem_prag.adb | 6 +- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 15b65ee4c06..7625abf9554 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -334,7 +334,7 @@ package body Contracts is if Is_OK_Classification then Add_Classification; -elsif Ekind (Id) in Access_Subprogram_Kind +elsif Ekind (Id) = E_Subprogram_Type and then Prag_Nam in Name_Precondition | Name_Postcondition then @@ -665,7 +665,10 @@ package body Contracts is Freeze_Id : Entity_Id := Empty) is Items : constant Node_Id := Contract (Subp_Id); - Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); + Subp_Decl : constant Node_Id := +(if Ekind (Subp_Id) = E_Subprogram_Type + then Associated_Node_For_Itype (Subp_Id) + else Unit_Declaration_Node (Subp_Id)); Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; @@ -1593,8 +1596,9 @@ package body Contracts is -- Analyze Pre/Post on access-to-subprogram type - if Is_Access_Subprogram_Type (Type_Id) then - Analyze_Entry_Or_Subprogram_Contract (Type_Id); + if Ekind (Type_Id) in Access_Subprogram_Kind then + Analyze_Entry_Or_Subprogram_Contract + (Directly_Designated_Type (Type_Id)); end if; end Analyze_Type_Contract; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 0d62b04cc37..0de410a2392 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -5265,7 +5265,11 @@ package body Sem_Prag is -- Chain the pragma on the contract for further processing by -- Analyze_Pre_Post_Condition_In_Decl_Part. - Add_Contract_Item (N, Subp_Id); + if Ekind (Subp_Id) in Access_Subprogram_Kind then +Add_Contract_Item (N, Directly_Designated_Type (Subp_Id)); + else +Add_Contract_Item (N, Subp_Id); + end if; -- Fully analyze the pragma when it appears inside an entry or -- subprogram body because it cannot benefit from forward references. -- 2.40.0
[COMMITTED] ada: Fix remaining failures in Roman Numbers test
From: Eric Botcazou The test is inspired from the example of user-defined literals given in the Ada 2022 RM. Mixed Arabic numbers/Roman numbers computations are rejected because the second resolution pass would try to resolve Arabic numbers only as user-defined literals. gcc/ada/ * sem_res.adb (Try_User_Defined_Literal): For arithmetic operators, also accept operands whose type is covered by the resolution type. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_res.adb | 8 ++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 066072a6afe..17b74ea65d5 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -1,12 +1,16 @@ package body Sem_Res is -- Both operands must have the same type as the context -- (ignoring for now fixed-point and exponentiation ops). - if Has_Applicable_User_Defined_Literal (Right_Opnd (N), Typ) then + if Covers (Typ, Etype (Right_Opnd (N))) + or else Has_Applicable_User_Defined_Literal (Right_Opnd (N), Typ) + then Resolve (Left_Opnd (N), Typ); Analyze_And_Resolve (N, Typ); return True; - elsif Has_Applicable_User_Defined_Literal (Left_Opnd (N), Typ) then + elsif Covers (Typ, Etype (Left_Opnd (N))) + or else Has_Applicable_User_Defined_Literal (Left_Opnd (N), Typ) + then Resolve (Right_Opnd (N), Typ); Analyze_And_Resolve (N, Typ); return True; -- 2.40.0
[COMMITTED] ada: Fix small fallout of previous change
From: Eric Botcazou It may lead to an infinite recursion if no interpretation exists. gcc/ada/ * sem_res.adb (Try_User_Defined_Literal): Restrict previous change to non-leaf nodes. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_res.adb | 10 ++ 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 17b74ea65d5..1d4b9acb8ea 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -1,15 +1,17 @@ package body Sem_Res is -- Both operands must have the same type as the context -- (ignoring for now fixed-point and exponentiation ops). - if Covers (Typ, Etype (Right_Opnd (N))) - or else Has_Applicable_User_Defined_Literal (Right_Opnd (N), Typ) + if Has_Applicable_User_Defined_Literal (Right_Opnd (N), Typ) + or else (Nkind (Left_Opnd (N)) in N_Op + and then Covers (Typ, Etype (Right_Opnd (N then Resolve (Left_Opnd (N), Typ); Analyze_And_Resolve (N, Typ); return True; - elsif Covers (Typ, Etype (Left_Opnd (N))) - or else Has_Applicable_User_Defined_Literal (Left_Opnd (N), Typ) + elsif Has_Applicable_User_Defined_Literal (Left_Opnd (N), Typ) + or else (Nkind (Right_Opnd (N)) in N_Op + and then Covers (Typ, Etype (Left_Opnd (N then Resolve (Right_Opnd (N), Typ); Analyze_And_Resolve (N, Typ); -- 2.40.0
[COMMITTED] ada: Fix memory leak in expression function returning Big_Integer
From: Eric Botcazou We fail to establish a transient scope around the return statement because the function returns a controlled type, but this is no longer problematic because controlled types are no longer returned on the secondary stack. gcc/ada/ * exp_ch7.adb (Establish_Transient_Scope.Find_Transient_Context): Bail out for a simple return statement only if the transient scope and the function both require secondary stack management, or else if the function is a thunk. * sem_res.adb (Resolve_Call): Do not create a transient scope when the call is the expression of a simple return statement. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch7.adb | 32 gcc/ada/sem_res.adb | 12 2 files changed, 28 insertions(+), 16 deletions(-) diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 1586e8fbfca..520bb099d33 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -4717,21 +4717,29 @@ package body Exp_Ch7 is return Curr; when N_Simple_Return_Statement => + declare + Fun_Id : constant Entity_Id := + Return_Applies_To (Return_Statement_Entity (Curr)); - -- 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; + begin + -- A transient context that must manage the secondary + -- stack cannot be a return statement of a function that + -- itself requires secondary stack management, because + -- the function's result would be reclaimed too early. + -- And returns of thunks never require transient scopes. + + if (Manage_Sec_Stack + and then Needs_Secondary_Stack (Etype (Fun_Id))) + or else Is_Thunk (Fun_Id) + then +return Empty; - -- General case for return statements + -- General case for return statements - else - return Curr; - end if; + else +return Curr; + end if; + end; -- Special diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 899b5b5c522..b16e48917f2 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6960,6 +6960,12 @@ package body Sem_Res is -- want to create a transient scope (this could occur in the case of a -- static string-returning call). + -- h) If the subprogram is an ignored ghost entity, because it does not + -- return anything. + + -- i) If the call is the expression of a simple return statement, since + -- it will be handled as a tail call by Expand_Simple_Function_Return. + if Is_Inlined (Nam) and then Has_Pragma_Inline (Nam) and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration @@ -6972,16 +6978,14 @@ package body Sem_Res is or else Is_Intrinsic_Subprogram (Nam) or else Is_Inlinable_Expression_Function (Nam) or else Is_Static_Function_Call (N) +or else Is_Ignored_Ghost_Entity (Nam) +or else Nkind (Parent (N)) = N_Simple_Return_Statement then null; - -- A return statement from an ignored Ghost function does not use the - -- secondary stack (or any other one). - elsif Expander_Active and then Ekind (Nam) in E_Function | E_Subprogram_Type and then Requires_Transient_Scope (Etype (Nam)) -and then not Is_Ignored_Ghost_Entity (Nam) then Establish_Transient_Scope (N, Needs_Secondary_Stack (Etype (Nam))); -- 2.40.0
[COMMITTED] ada: Fix wrong finalization for case expression in expression function
From: Eric Botcazou This happens when the case expression contains a single alternative. gcc/ada/ * exp_ch5.adb (Expand_N_Case_Statement): Do not remove the statement if it is the node to be wrapped by a transient scope. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch5.adb | 8 ++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 30af98b3fc0..2be6e7e021e 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -4127,11 +4127,15 @@ package body Exp_Ch5 is -- If there is only a single alternative, just replace it with the -- sequence of statements since obviously that is what is going to - -- be executed in all cases. + -- be executed in all cases, except if it is the node to be wrapped + -- by a transient scope, because this would cause the sequence of + -- statements to be leaked out of the transient scope. Len := List_Length (Alternatives (N)); - if Len = 1 then + if Len = 1 + and then not (Scope_Is_Transient and then Node_To_Be_Wrapped = N) + then -- We still need to evaluate the expression if it has any side -- effects. -- 2.40.0
[COMMITTED] ada: Fix bogus error on conditional expression with only user-defined literals
From: Eric Botcazou This implements the recursive resolution of conditional expressions whose dependent expressions are (all) user-defined literals the same way it is implemented for operators. gcc/ada/ * sem_res.adb (Has_Applicable_User_Defined_Literal): Make it clear that the predicate also checks the node itself. (Try_User_Defined_Literal): Move current implementation to... Deal only with literals, named numbers and conditional expressions whose dependent expressions are literals or named numbers. (Try_User_Defined_Literal_For_Operator): ...this. Remove multiple return False statements and put a single one at the end. (Resolve): Call Try_User_Defined_Literal instead of directly Has_Applicable_User_Defined_Literal for all nodes. Call Try_User_Defined_Literal_For_Operator for operator nodes. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_res.adb | 127 ++-- 1 file changed, 98 insertions(+), 29 deletions(-) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 8a5f87b80ed..899b5b5c522 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -111,10 +111,9 @@ package body Sem_Res is function Has_Applicable_User_Defined_Literal (N : Node_Id; Typ : Entity_Id) return Boolean; - -- If N is a literal or a named number, check whether Typ - -- has a user-defined literal aspect that can apply to N. - -- If present, replace N with a call to the corresponding - -- function and return True. + -- Check whether N is a literal or a named number, and whether Typ has a + -- user-defined literal aspect that may apply to N. In this case, replace + -- N with a call to the corresponding function and return True. procedure Check_Discriminant_Use (N : Node_Id); -- Enforce the restrictions on the use of discriminants when constraining @@ -306,11 +305,20 @@ package body Sem_Res is function Try_User_Defined_Literal (N : Node_Id; Typ : Entity_Id) return Boolean; - -- If an operator node has a literal operand, check whether the type - -- of the context, or the type of the other operand has a user-defined - -- literal aspect that can be applied to the literal to resolve the node. - -- If such aspect exists, replace literal with a call to the - -- corresponding function and return True, return false otherwise. + -- If the node is a literal or a named number or a conditional expression + -- whose dependent expressions are all literals or named numbers, and the + -- context type has a user-defined literal aspect, then rewrite the node + -- or its leaf nodes as calls to the corresponding function, which plays + -- the role of an implicit conversion. + + function Try_User_Defined_Literal_For_Operator + (N : Node_Id; + Typ : Entity_Id) return Boolean; + -- If an operator node has a literal operand, check whether the type of the + -- context, or that of the other operand has a user-defined literal aspect + -- that can be applied to the literal to resolve the node. If such aspect + -- exists, replace literal with a call to the corresponding function and + -- return True, return false otherwise. function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id; -- A universal_fixed expression in an universal context is unambiguous if @@ -600,6 +608,7 @@ package body Sem_Res is Analyze_And_Resolve (N, Typ); return True; + else return False; end if; @@ -3061,14 +3070,11 @@ package body Sem_Res is end; end if; --- If node is a literal and context type has a user-defined --- literal aspect, rewrite node as a call to the corresponding --- function, which plays the role of an implicit conversion. +-- Check whether the node is a literal or a named number or a +-- conditional expression whose dependent expressions are all +-- literals or named numbers. -if Nkind (N) in N_Numeric_Or_String_Literal | N_Identifier - and then Has_Applicable_User_Defined_Literal (N, Typ) -then - Analyze_And_Resolve (N, Typ); +if Try_User_Defined_Literal (N, Typ) then return; end if; @@ -3179,7 +3185,7 @@ package body Sem_Res is -- its operands may be a user-defined literal. elsif Nkind (N) in N_Op and then No (Entity (N)) then - if Try_User_Defined_Literal (N, Typ) then + if Try_User_Defined_Literal_For_Operator (N, Typ) then return; else Unresolved_Operator (N); @@ -13322,6 +13328,78 @@ package body Sem_Res is (N : Node_Id; Typ : Entity_Id) return Boolean is + begin + if Has_A
[COMMITTED] ada: Cleanup detection of type support subprogram entities
From: Piotr Trojanek
Avoid repeated calls to Get_TSS_Name. Code cleanup related to handling
of dispatching operations in GNATprove; semantics is unaffected.
gcc/ada/
* exp_aggr.adb (Convert_Aggr_In_Allocator): Replace Get_TSS_Name
with a high-level Is_TSS.
* sem_ch6.adb (Check_Conformance): Replace DECLARE block and
nested IF with a call to Get_TSS_Name and a membership test.
(Has_Reliable_Extra_Formals): Refactor repeated calls to
Get_TSS_Name.
* sem_disp.adb (Check_Dispatching_Operation): Replace repeated
calls to Get_TSS_Name with a membership test.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_aggr.adb | 3 +-
gcc/ada/sem_ch6.adb | 73 +++-
gcc/ada/sem_disp.adb | 6 ++--
3 files changed, 35 insertions(+), 47 deletions(-)
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index c4a016ed3d4..93fcac5439e 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -4487,8 +4487,7 @@ package body Exp_Aggr is
while Present (Stmt) loop
if Nkind (Stmt) = N_Procedure_Call_Statement
- and then Get_TSS_Name (Entity (Name (Stmt)))
-= TSS_Slice_Assign
+ and then Is_TSS (Entity (Name (Stmt)), TSS_Slice_Assign)
then
Param := First (Parameter_Associations (Stmt));
Insert_Actions
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 495e8b1c538..17c50f6e676 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -6005,41 +6005,35 @@ package body Sem_Ch6 is
-- avoids some redundant error messages.
and then not Error_Posted (New_Formal)
-then
- -- It is allowed to omit the null-exclusion in case of stream
- -- attribute subprograms. We recognize stream subprograms
- -- through their TSS-generated suffix.
- declare
- TSS_Name : constant TSS_Name_Type := Get_TSS_Name (New_Id);
+ -- It is allowed to omit the null-exclusion in case of stream
+ -- attribute subprograms. We recognize stream subprograms
+ -- through their TSS-generated suffix.
- begin
- if TSS_Name /= TSS_Stream_Read
-and then TSS_Name /= TSS_Stream_Write
-and then TSS_Name /= TSS_Stream_Input
-and then TSS_Name /= TSS_Stream_Output
- then
- -- Here we have a definite conformance error. It is worth
- -- special casing the error message for the case of a
- -- controlling formal (which excludes null).
+ and then Get_TSS_Name (New_Id) not in TSS_Stream_Read
+ | TSS_Stream_Write
+ | TSS_Stream_Input
+ | TSS_Stream_Output
+then
+ -- Here we have a definite conformance error. It is worth
+ -- special casing the error message for the case of a
+ -- controlling formal (which excludes null).
- if Is_Controlling_Formal (New_Formal) then
-Error_Msg_Node_2 := Scope (New_Formal);
-Conformance_Error
- ("\controlling formal & of & excludes null, "
- & "declaration must exclude null as well",
- New_Formal);
+ if Is_Controlling_Formal (New_Formal) then
+ Error_Msg_Node_2 := Scope (New_Formal);
+ Conformance_Error
+("\controlling formal & of & excludes null, "
+ & "declaration must exclude null as well",
+ New_Formal);
- -- Normal case (couldn't we give more detail here???)
+ -- Normal case (couldn't we give more detail here???)
- else
-Conformance_Error
- ("\type of & does not match!", New_Formal);
- end if;
+ else
+ Conformance_Error
+("\type of & does not match!", New_Formal);
+ end if;
- return;
- end if;
- end;
+ return;
end if;
end if;
@@ -10650,21 +10644,16 @@ package body Sem_Ch6 is
else
declare
-Typ : constant Entity_Id :=
-Underlying_Type (Find_Dispatching_Type (Alias_E));
+TSS_Name : constant TSS_Name_Type := Get_TSS_Name (E);
+Typ : constant Entity_Id :=
+ Underlying_Type (Find_Dispatching_Type (Alias_
[COMMITTED] ada: Fix spurious error on imported generic function with precondition
From: Eric Botcazou It occurs during the instantiation because the compiler forgets the context of the generic declaration. gcc/ada/ * freeze.adb (Wrap_Imported_Subprogram): Use Copy_Subprogram_Spec in both cases to copy the spec of the subprogram. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/freeze.adb | 8 +--- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 5d3413c1505..8ebf10bd576 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -6063,12 +6063,6 @@ package body Freeze is then -- Here we do the wrap --- Note on calls to Copy_Separate_Tree. The trees we are copying --- here are fully analyzed, but we definitely want fully syntactic --- unanalyzed trees in the body we construct, so that the analysis --- generates the right visibility, and that is exactly what the --- calls to Copy_Separate_Tree give us. - Prag := Copy_Import_Pragma; -- Fix up spec so it is no longer imported and has convention Ada @@ -6127,7 +6121,7 @@ package body Freeze is Specification => Copy_Subprogram_Spec (Spec), Declarations => New_List ( Make_Subprogram_Declaration (Loc, -Specification => Copy_Separate_Tree (Spec)), +Specification => Copy_Subprogram_Spec (Spec)), Prag), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, -- 2.40.0
[COMMITTED] ada: Call idiomatic routine in Expand_Simple_Function_Return
From: Eric Botcazou In the primary stack case, Insert_Actions is invoked when the expression is being rewritten, whereas Insert_List_Before_And_Analyze is invoked in the secondary stack case. The former is idiomatic, the latter is not. gcc/ada/ * exp_ch6.adb (Expand_Simple_Function_Return): Call Insert_Actions consistently when rewriting the expression. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch6.adb | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 87560462315..b19db8fb74d 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6895,7 +6895,7 @@ package body Exp_Ch6 is Temp := Make_Temporary (Loc, 'R', Alloc_Node); - Insert_List_Before_And_Analyze (N, New_List ( + Insert_Actions (Exp, New_List ( Make_Full_Type_Declaration (Loc, Defining_Identifier => Acc_Typ, Type_Definition => -- 2.40.0
[COMMITTED] ada: Remove extra whitespace from FOR loops
From: Piotr Trojanek
Whitespace cleanup.
gcc/ada/
* doc/gnat_ugn/gnat_and_program_execution.rst
(Some Useful Memory Pools): Remove extra whitespace from examples.
* sem_aggr.adb (Make_String_Into_Aggregate): Remove extra whitespace.
* gnat_ugn.texi: Regenerate.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst | 4 ++--
gcc/ada/gnat_ugn.texi | 6 +++---
gcc/ada/sem_aggr.adb| 2 +-
3 files changed, 6 insertions(+), 6 deletions(-)
diff --git a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
index 5dab2d45626..9eb6b1c60aa 100644
--- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
+++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
@@ -3530,12 +3530,12 @@ leak memory even though it does not perform explicit
deallocation:
for A'Storage_Pool use X;
v : A;
begin
- for I in 1 .. 50 loop
+ for I in 1 .. 50 loop
v := new Integer;
end loop;
end Internal;
begin
-for I in 1 .. 100 loop
+for I in 1 .. 100 loop
Internal;
end loop;
end Pooloc1;
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index be234881f37..3d94a1ad255 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -22302,12 +22302,12 @@ procedure Pooloc1 is
for A'Storage_Pool use X;
v : A;
begin
- for I in 1 .. 50 loop
+ for I in 1 .. 50 loop
v := new Integer;
end loop;
end Internal;
begin
- for I in 1 .. 100 loop
+ for I in 1 .. 100 loop
Internal;
end loop;
end Pooloc1;
@@ -29479,8 +29479,8 @@ to permit their use in free software.
@printindex ge
-@anchor{cf}@w{ }
@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{
}
+@anchor{cf}@w{ }
@c %**end of body
@bye
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index edd495b8359..73046267256 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -828,7 +828,7 @@ package body Sem_Aggr is
begin
P := Loc + 1;
- for J in 1 .. Strlen loop
+ for J in 1 .. Strlen loop
C := Get_String_Char (Str, J);
Set_Character_Literal_Name (C);
--
2.40.0
[COMMITTED] ada: Define sigset for systems that does not suport sockets
From: Cedric Landet In s-oscons-tmplt.c, sigset is defined inside the HAVE_SOCKETS bloc. A platform could require sigset without supporting sockets. gcc/ada/ * s-oscons-tmplt.c: move the definition of sigset out of the HAVE_SOCKETS bloc. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/s-oscons-tmplt.c | 10 +- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index 5480e55a5bb..28d42c5a459 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -1796,11 +1796,6 @@ CND(SIZEOF_struct_hostent, "struct hostent") #define SIZEOF_struct_servent (sizeof (struct servent)) CND(SIZEOF_struct_servent, "struct servent") -#if defined (__linux__) || defined (__ANDROID__) || defined (__QNX__) -#define SIZEOF_sigset (sizeof (sigset_t)) -CND(SIZEOF_sigset, "sigset") -#endif - #if defined(_WIN32) || defined(__vxworks) #define SIZEOF_nfds_t sizeof (int) * 8 #define SIZEOF_socklen_t sizeof (size_t) @@ -1938,6 +1933,11 @@ CST(Poll_Linkname, "") #endif /* HAVE_SOCKETS */ +#if defined (__linux__) || defined (__ANDROID__) || defined (__QNX__) +#define SIZEOF_sigset (sizeof (sigset_t)) +CND(SIZEOF_sigset, "sigset") +#endif + /* - -- 2.40.0
[COMMITTED] ada: Set g-spogwa as a GNATRTL_SOCKETS_OBJS
From: Cedric Landet g-spogwa.adb is the body of the procedure GNAT.Sockets.Poll.G_Wait. This is a socket specific procedure. It should only be built for systems that support sockets. gcc/ada/ * Makefile.rtl: Move g-spogwa$(objext) from GNATRTL_NONTASKING_OBJS to GNATRTL_SOCKETS_OBJS Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/Makefile.rtl | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 3da32fa6668..e2f437ff6e5 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -478,7 +478,6 @@ GNATRTL_NONTASKING_OBJS= \ g-speche$(objext) \ g-spipat$(objext) \ g-spitbo$(objext) \ - g-spogwa$(objext) \ g-sptabo$(objext) \ g-sptain$(objext) \ g-sptavs$(objext) \ @@ -856,7 +855,7 @@ GNATLIB_SHARED = gnatlib # to LIBGNAT_TARGET_PAIRS. GNATRTL_SOCKETS_OBJS = g-soccon$(objext) g-socket$(objext) g-socthi$(objext) \ - g-soliop$(objext) g-sothco$(objext) g-socpol$(objext) + g-soliop$(objext) g-sothco$(objext) g-socpol$(objext) g-spogwa$(objext) DUMMY_SOCKETS_TARGET_PAIRS = \ g-socket.adb
[COMMITTED] ada: Use Code_Address attribute to determine subprogram addresses
From: Patrick Bernardi The runtime used label addresses to determine the code address of subprograms because the subprogram's canonical address on some targets is a descriptor or a stub. Simplify the code by using the Code_Address attribute instead, which is designed to return the code address of a subprogram. This also works around a current GNAT-LLVM limitation where the address of a label is incorrectly calculated when using -O1. As a result, we can now build a-except.adb and g-debpoo.adb at -O1 again with GNAT-LLVM. gcc/ada/ * libgnat/a-excach.adb (Call_Chain): Replace Code_Address_For_AAA/ZZZ functions with AAA/ZZZ'Code_Address. * libgnat/a-except.adb (Code_Address_For_AAA/ZZZ): Delete. (AAA/ZZZ): New null procedures. * libgnat/g-debpoo.adb (Code_Address_For_Allocate_End): Delete. (Code_Address_For_Deallocate_End): Delete. (Code_Address_For_Dereference_End): Delete. (Allocate): Remove label and use Code_Address attribute to determine subprogram addresses. (Dellocate): Likewise. (Dereference): Likewise. (Allocate_End): Convert to null procedure. (Dellocate_End): Likewise. (Dereference_End): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/a-excach.adb | 4 +- gcc/ada/libgnat/a-except.adb | 60 - gcc/ada/libgnat/g-debpoo.adb | 73 +++- 3 files changed, 48 insertions(+), 89 deletions(-) diff --git a/gcc/ada/libgnat/a-excach.adb b/gcc/ada/libgnat/a-excach.adb index 840da0c439f..784194d421e 100644 --- a/gcc/ada/libgnat/a-excach.adb +++ b/gcc/ada/libgnat/a-excach.adb @@ -66,8 +66,8 @@ begin (Traceback => Excep.Tracebacks, Max_Len => Max_Tracebacks, Len => Excep.Num_Tracebacks, - Exclude_Min => Code_Address_For_AAA, - Exclude_Max => Code_Address_For_ZZZ, + Exclude_Min => AAA'Code_Address, + Exclude_Max => ZZZ'Code_Address, Skip_Frames => 3); end if; diff --git a/gcc/ada/libgnat/a-except.adb b/gcc/ada/libgnat/a-except.adb index 7d728d6acfa..20a773661ae 100644 --- a/gcc/ada/libgnat/a-except.adb +++ b/gcc/ada/libgnat/a-except.adb @@ -65,29 +65,32 @@ package body Ada.Exceptions is -- from C clients using the given external name, even though they are not -- technically visible in the Ada sense. - function Code_Address_For_AAA return System.Address; - function Code_Address_For_ZZZ return System.Address; - -- Return start and end of procedures in this package + procedure AAA; + procedure ZZZ; + -- Start and end of procedures in this package -- - -- These procedures are used to provide exclusion bounds in - -- calls to Call_Chain at exception raise points from this unit. The - -- purpose is to arrange for the exception tracebacks not to include - -- frames from subprograms involved in the raise process, as these are - -- meaningless from the user's standpoint. + -- These procedures are used to provide exclusion bounds in calls to + -- Call_Chain at exception raise points from this unit. The purpose is + -- to arrange for the exception tracebacks not to include frames from + -- subprograms involved in the raise process, as these are meaningless + -- from the user's standpoint. -- -- For these bounds to be meaningful, we need to ensure that the object - -- code for the subprograms involved in processing a raise is located - -- after the object code Code_Address_For_AAA and before the object - -- code Code_Address_For_ZZZ. This will indeed be the case as long as - -- the following rules are respected: + -- code for the subprograms involved in processing a raise is located after + -- the object code AAA and before the object code ZZZ. This will indeed be + -- the case as long as the following rules are respected: -- -- 1) The bodies of the subprograms involved in processing a raise - -- are located after the body of Code_Address_For_AAA and before the - -- body of Code_Address_For_ZZZ. + -- are located after the body of AAA and before the body of ZZZ. -- -- 2) No pragma Inline applies to any of these subprograms, as this -- could delay the corresponding assembly output until the end of -- the unit. + -- + -- To obtain the address of AAA and ZZZ, use the Code_Address attribute + -- instead of the Address attribute as the latter will return the address + -- of a stub or descriptor on some platforms. This include IA-64, + -- PowerPC/AIX, big-endian PowerPC64 and HPUX. procedure Call_Chain (Excep : EOA); -- Store up to Max_Tracebacks in Excep, corresponding to the current @@ -771,24 +774,15 @@ package body Ada.Exceptions is Rmsg_36 : constant String := "stream operation not allowed" & NUL; Rmsg_37 : constant String := "build-in-place mismatc
Re: [COMMITTED] ada: Remove the body of System.Storage_Elements
Jan-Benedict Glaw writes: > (A full build log is at > http://toolchain.lug-owl.de/laminar/jobs/gcc-aarch64-linux/74) > > Is this an issue with the patch? Or does it need a newer Ada compiler > to for building it? Hello Jan, IIUC, your base compiler is "g++ (Debian 20230315-1) 13.0.1 20230315". It looks like you are doing a native build with bootstrap. If that's the case it should work correctly. Can you elaborate how you build GCC? Thanks, Marc
[COMMITTED] ada: Fix coding style in init.c
From: Cedric Landet
The coding style rules require to avoid using FIXME comments. ??? is
preferred.
gcc/ada/
* init.c: Replace FIXME by ???
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/init.c | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/gcc/ada/init.c b/gcc/ada/init.c
index 5212a38490d..53ca142 100644
--- a/gcc/ada/init.c
+++ b/gcc/ada/init.c
@@ -248,7 +248,7 @@ __gnat_error_handler (int sig,
switch (sig)
{
case SIGSEGV:
- /* FIXME: we need to detect the case of a *real* SIGSEGV. */
+ /* ??? we need to detect the case of a *real* SIGSEGV. */
exception = &storage_error;
msg = "stack overflow or erroneous memory access";
break;
@@ -340,7 +340,7 @@ __gnat_error_handler (int sig, siginfo_t *si
ATTRIBUTE_UNUSED, void *ucontext)
switch (sig)
{
case SIGSEGV:
- /* FIXME: we need to detect the case of a *real* SIGSEGV. */
+ /* ??? we need to detect the case of a *real* SIGSEGV. */
exception = &storage_error;
msg = "stack overflow or erroneous memory access";
break;
--
2.40.0
[COMMITTED] ada: Fix visibility error with DIC or Type_Invariant aspect on generic type
From: Eric Botcazou The compiler fails to capture global references during the analysis of the aspect on the generic type because it analyzes a copy of the expression. gcc/ada/ * exp_util.adb (Build_DIC_Procedure_Body.Add_Own_DIC): When inside a generic unit, preanalyze the expression directly. (Build_Invariant_Procedure_Body.Add_Own_Invariants): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_util.adb | 19 +-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 2582524b1dd..4c4844594d2 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1853,7 +1853,15 @@ package body Exp_Util is begin pragma Assert (Present (DIC_Expr)); - Expr := New_Copy_Tree (DIC_Expr); + + -- We need to preanalyze the expression itself inside a generic to + -- be able to capture global references present in it. + + if Inside_A_Generic then +Expr := DIC_Expr; + else +Expr := New_Copy_Tree (DIC_Expr); + end if; -- Perform the following substitution: @@ -3111,7 +3119,14 @@ package body Exp_Util is return; end if; - Expr := New_Copy_Tree (Prag_Expr); + -- We need to preanalyze the expression itself inside a generic + -- to be able to capture global references present in it. + + if Inside_A_Generic then + Expr := Prag_Expr; + else + Expr := New_Copy_Tree (Prag_Expr); + end if; -- Substitute all references to type T with references to the -- _object formal parameter. -- 2.40.0
[COMMITTED] ada: Use generalized loop iteration in Put_Image routines
From: Eric Botcazou gcc/ada/ * libgnat/a-cidlli.adb (Put_Image): Simplify. * libgnat/a-coinve.adb (Put_Image): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/a-cidlli.adb | 13 + gcc/ada/libgnat/a-coinve.adb | 13 + 2 files changed, 10 insertions(+), 16 deletions(-) diff --git a/gcc/ada/libgnat/a-cidlli.adb b/gcc/ada/libgnat/a-cidlli.adb index 65582d152f0..9e6ad70a103 100644 --- a/gcc/ada/libgnat/a-cidlli.adb +++ b/gcc/ada/libgnat/a-cidlli.adb @@ -1283,22 +1283,19 @@ is is First_Time : Boolean := True; use System.Put_Images; + begin + Array_Before (S); - procedure Put_Elem (Position : Cursor); - procedure Put_Elem (Position : Cursor) is - begin + for X of V loop if First_Time then First_Time := False; else Simple_Array_Between (S); end if; - Element_Type'Put_Image (S, Element (Position)); - end Put_Elem; + Element_Type'Put_Image (S, X); + end loop; - begin - Array_Before (S); - Iterate (V, Put_Elem'Access); Array_After (S); end Put_Image; diff --git a/gcc/ada/libgnat/a-coinve.adb b/gcc/ada/libgnat/a-coinve.adb index 846f819a732..dd0e8cdee40 100644 --- a/gcc/ada/libgnat/a-coinve.adb +++ b/gcc/ada/libgnat/a-coinve.adb @@ -2679,22 +2679,19 @@ is is First_Time : Boolean := True; use System.Put_Images; + begin + Array_Before (S); - procedure Put_Elem (Position : Cursor); - procedure Put_Elem (Position : Cursor) is - begin + for X of V loop if First_Time then First_Time := False; else Simple_Array_Between (S); end if; - Element_Type'Put_Image (S, Element (Position)); - end Put_Elem; + Element_Type'Put_Image (S, X); + end loop; - begin - Array_Before (S); - Iterate (V, Put_Elem'Access); Array_After (S); end Put_Image; -- 2.40.0
[COMMITTED] ada: Only build access-to-subprogram wrappers when expander is active
From: Piotr Trojanek For access-to-subprogram types with Pre/Post aspects we create a wrapper routine that evaluates these aspects. Spec of this wrapper was created always, while its body was only created when expansion was enabled. Now we only create these wrappers when expansion is enabled. In particular, we don't create them in GNATprove mode; instead, GNATprove picks the Pre/Post expressions directly from the aspects. gcc/ada/ * exp_ch3.adb (Build_Access_Subprogram_Wrapper_Body): Build wrapper body if requested by routine that builds wrapper spec. * sem_ch3.adb (Analyze_Full_Type_Declaration): Only build wrapper when expander is active. (Build_Access_Subprogram_Wrapper): Remove special-case for GNATprove. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch3.adb | 4 gcc/ada/sem_ch3.adb | 12 ++-- 2 files changed, 2 insertions(+), 14 deletions(-) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 5f651bacafb..f8c99470dd7 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -583,10 +583,6 @@ package body Exp_Ch3 is Ptr : Entity_Id; begin - if not Expander_Active then - return; - end if; - -- Create List of actuals for indirect call. The last parameter of the -- subprogram declaration is the access value for the indirect call. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index f360be810b4..29733e9d31f 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3224,6 +3224,7 @@ package body Sem_Ch3 is if Ada_Version >= Ada_2022 and then Present (Aspect_Specifications (N)) + and then Expander_Active then Build_Access_Subprogram_Wrapper (N); end if; @@ -6915,16 +6916,7 @@ package body Sem_Ch3 is -- may be handled as a dispatching operation and erroneously registered -- in a dispatch table. - if not GNATprove_Mode then - Append_Freeze_Action (Id, New_Decl); - - -- Under GNATprove mode there is no such problem but we do not declare - -- it in the freezing actions since they are not analyzed under this - -- mode. - - else - Insert_After (Decl, New_Decl); - end if; + Append_Freeze_Action (Id, New_Decl); Set_Access_Subprogram_Wrapper (Designated_Type (Id), Subp); Build_Access_Subprogram_Wrapper_Body (Decl, New_Decl); -- 2.40.0
[COMMITTED] ada: Ensure Default_Stack_Size is greater than Minimum_Stack_Size
From: Johannes Kliemann The Default_Stack_Size function does not check that the binder specified default stack size is greater than the minimum stack size for the runtime. This can result in tasks using default stack sizes less than the minimum stack size because the Adjust_Storage_Size only adjusts storages sizes for tasks that explicitly specify a storage size. To avoid this, the binder specified default stack size is round up to the minimum stack size if required. gcc/ada/ * libgnat/s-parame.adb: Check that Default_Stack_Size >= Minimum_Stack_size. * libgnat/s-parame__rtems.adb: Ditto. * libgnat/s-parame__vxworks.adb: Check that Default_Stack_Size >= Minimum_Stack_size and use the proper Minimum_Stack_Size if Stack_Check_Limits is enabled. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/s-parame.adb | 2 ++ gcc/ada/libgnat/s-parame__rtems.adb | 2 ++ gcc/ada/libgnat/s-parame__vxworks.adb | 11 +-- 3 files changed, 13 insertions(+), 2 deletions(-) diff --git a/gcc/ada/libgnat/s-parame.adb b/gcc/ada/libgnat/s-parame.adb index 930c92d35e2..6bd9f03f63f 100644 --- a/gcc/ada/libgnat/s-parame.adb +++ b/gcc/ada/libgnat/s-parame.adb @@ -58,6 +58,8 @@ package body System.Parameters is begin if Default_Stack_Size = -1 then return 2 * 1024 * 1024; + elsif Size_Type (Default_Stack_Size) < Minimum_Stack_Size then + return Minimum_Stack_Size; else return Size_Type (Default_Stack_Size); end if; diff --git a/gcc/ada/libgnat/s-parame__rtems.adb b/gcc/ada/libgnat/s-parame__rtems.adb index 2f2e70b1796..1d51ae9ec04 100644 --- a/gcc/ada/libgnat/s-parame__rtems.adb +++ b/gcc/ada/libgnat/s-parame__rtems.adb @@ -63,6 +63,8 @@ package body System.Parameters is begin if Default_Stack_Size = -1 then return 32 * 1024; + elsif Size_Type (Default_Stack_Size) < Minimum_Stack_Size then + return Minimum_Stack_Size; else return Size_Type (Default_Stack_Size); end if; diff --git a/gcc/ada/libgnat/s-parame__vxworks.adb b/gcc/ada/libgnat/s-parame__vxworks.adb index 8e0768e1e29..38fe0222622 100644 --- a/gcc/ada/libgnat/s-parame__vxworks.adb +++ b/gcc/ada/libgnat/s-parame__vxworks.adb @@ -58,11 +58,13 @@ package body System.Parameters is begin if Default_Stack_Size = -1 then if Stack_Check_Limits then -return 32 * 1024; -- Extra stack to allow for 12K exception area. +return 32 * 1024; else return 20 * 1024; end if; + elsif Size_Type (Default_Stack_Size) < Minimum_Stack_Size then + return Minimum_Stack_Size; else return Size_Type (Default_Stack_Size); end if; @@ -74,7 +76,12 @@ package body System.Parameters is function Minimum_Stack_Size return Size_Type is begin - return 8 * 1024; + if Stack_Check_Limits then + -- Extra stack to allow for 12K exception area. + return 20 * 1024; + else + return 8 * 1024; + end if; end Minimum_Stack_Size; end System.Parameters; -- 2.40.0
[COMMITTED] ada: Fix regression of secondary stack management in return statements
From: Eric Botcazou This happens when the expression of the return statement is a call that does not return on the same stack as the enclosing function. gcc/ada/ * sem_res.adb (Resolve_Call): Restrict previous change to calls that return on the same stack as the enclosing function. Tidy up. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_res.adb | 69 - 1 file changed, 31 insertions(+), 38 deletions(-) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index b16e48917f2..c2a4bcb58cd 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6923,69 +6923,62 @@ package body Sem_Res is return; end if; - -- Create a transient scope if the resulting type requires it + -- Create a transient scope if the expander is active and the resulting + -- type requires it. -- There are several notable exceptions: - -- a) In init procs, the transient scope overhead is not needed, and is - -- even incorrect when the call is a nested initialization call for a - -- component whose expansion may generate adjust calls. However, if the - -- call is some other procedure call within an initialization procedure - -- (for example a call to Create_Task in the init_proc of the task - -- run-time record) a transient scope must be created around this call. - - -- b) Enumeration literal pseudo-calls need no transient scope - - -- c) Intrinsic subprograms (Unchecked_Conversion and source info + -- a) Intrinsic subprograms (Unchecked_Conversion and source info -- functions) do not use the secondary stack even though the return -- type may be unconstrained. - -- d) Calls to a build-in-place function, since such functions may + -- b) Subprograms that are ignored ghost entities do not return anything + + -- c) Calls to a build-in-place function, since such functions may -- allocate their result directly in a target object, and cases where -- the result does get allocated in the secondary stack are checked for -- within the specialized Exp_Ch6 procedures for expanding those -- build-in-place calls. - -- e) Calls to inlinable expression functions do not use the secondary + -- d) Calls to inlinable expression functions do not use the secondary -- stack (since the call will be replaced by its returned object). - -- f) If the subprogram is marked Inline_Always, then even if it returns + -- e) If the subprogram is marked Inline, then even if it returns -- an unconstrained type the call does not require use of the secondary -- stack. However, inlining will only take place if the body to inline -- is already present. It may not be available if e.g. the subprogram is -- declared in a child instance. - -- g) If the subprogram is a static expression function and the call is + -- f) If the subprogram is a static expression function and the call is -- a static call (the actuals are all static expressions), then we never -- want to create a transient scope (this could occur in the case of a -- static string-returning call). - -- h) If the subprogram is an ignored ghost entity, because it does not - -- return anything. - - -- i) If the call is the expression of a simple return statement, since - -- it will be handled as a tail call by Expand_Simple_Function_Return. - - if Is_Inlined (Nam) -and then Has_Pragma_Inline (Nam) -and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration -and then Present (Body_To_Inline (Unit_Declaration_Node (Nam))) - then - null; + -- g) If the call is the expression of a simple return statement that + -- returns on the same stack, since it will be handled as a tail call + -- by Expand_Simple_Function_Return. - elsif Ekind (Nam) = E_Enumeration_Literal -or else Is_Build_In_Place_Function (Nam) -or else Is_Intrinsic_Subprogram (Nam) -or else Is_Inlinable_Expression_Function (Nam) -or else Is_Static_Function_Call (N) -or else Is_Ignored_Ghost_Entity (Nam) -or else Nkind (Parent (N)) = N_Simple_Return_Statement - then - null; - - elsif Expander_Active + if Expander_Active and then Ekind (Nam) in E_Function | E_Subprogram_Type and then Requires_Transient_Scope (Etype (Nam)) +and then not Is_Intrinsic_Subprogram (Nam) +and then not Is_Ignored_Ghost_Entity (Nam) +and then not Is_Build_In_Place_Function (Nam) +and then not Is_Inlinable_Expression_Function (Nam) +and then not (Is_Inlined (Nam) + and then Has_Pragma_Inline (Nam) + and then Nkind (Unit_Declaration_Node (Nam)) = +
[COMMITTED] ada: Make use of Cannot_Be_Superflat flag on N_Range nodes
From: Eric Botcazou gcc/ada/ * gcc-interface/decl.cc (range_cannot_be_superflat): Return true immediately if Cannot_Be_Superflat is set. * gcc-interface/misc.cc (gnat_post_options): Do not override the -Wstringop-overflow setting. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/gcc-interface/decl.cc | 4 gcc/ada/gcc-interface/misc.cc | 3 --- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc index ec61593a65b..53a11243590 100644 --- a/gcc/ada/gcc-interface/decl.cc +++ b/gcc/ada/gcc-interface/decl.cc @@ -6673,6 +6673,10 @@ range_cannot_be_superflat (Node_Id gnat_range) Node_Id gnat_scalar_range; tree gnu_lb, gnu_hb, gnu_lb_minus_one; + /* This is the easy case. */ + if (Cannot_Be_Superflat (gnat_range)) +return true; + /* If the low bound is not constant, take the worst case by finding an upper bound for its type, repeatedly if need be. */ while (Nkind (gnat_lb) != N_Integer_Literal diff --git a/gcc/ada/gcc-interface/misc.cc b/gcc/ada/gcc-interface/misc.cc index b18ca8c7d88..56c7bb9b533 100644 --- a/gcc/ada/gcc-interface/misc.cc +++ b/gcc/ada/gcc-interface/misc.cc @@ -267,9 +267,6 @@ gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED) /* No return type warnings for Ada. */ warn_return_type = 0; - /* No string overflow warnings for Ada. */ - warn_stringop_overflow = 0; - /* No caret by default for Ada. */ if (!OPTION_SET_P (flag_diagnostics_show_caret)) global_dc->show_caret = false; -- 2.40.0
[COMMITTED] ada: Fix fallout of recent fix for missing finalization
From: Eric Botcazou The original fix makes it possible to create transient scopes around return statements in more cases, but it overlooks that transient scopes are reused and, in particular, that they can be promoted to secondary stack management. gcc/ada/ * exp_ch7.adb (Find_Enclosing_Transient_Scope): Return the index in the scope table instead of the scope's entity. (Establish_Transient_Scope): If an enclosing scope already exists, do not set the Uses_Sec_Stack flag on it if the node to be wrapped is a return statement which requires secondary stack management. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch7.adb | 36 ++-- 1 file changed, 26 insertions(+), 10 deletions(-) diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 520bb099d33..42b41e5cf6b 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -4476,10 +4476,10 @@ package body Exp_Ch7 is 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; + function Find_Enclosing_Transient_Scope return Int; -- 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. + -- its index in the table or else -1 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 @@ -4605,7 +4605,7 @@ package body Exp_Ch7 is -- Find_Enclosing_Transient_Scope -- - function Find_Enclosing_Transient_Scope return Entity_Id is + function Find_Enclosing_Transient_Scope return Int is begin for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop declare @@ -4620,12 +4620,12 @@ package body Exp_Ch7 is exit; elsif Scope.Is_Transient then - return Scope.Entity; + return Index; end if; end; end loop; - return Empty; + return -1; end Find_Enclosing_Transient_Scope; @@ -4822,8 +4822,8 @@ package body Exp_Ch7 is -- Local variables - Trans_Id : constant Entity_Id := Find_Enclosing_Transient_Scope; - Context : Node_Id; + Trans_Idx : constant Int := Find_Enclosing_Transient_Scope; + Context : Node_Id; -- Start of processing for Establish_Transient_Scope @@ -4831,13 +4831,29 @@ package body Exp_Ch7 is -- 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 + if Trans_Idx >= 0 then -- If the transient scope was requested for purposes of managing the - -- secondary stack, then the existing scope must perform this task. + -- secondary stack, then the existing scope must perform this task, + -- unless the node to be wrapped is a return statement of a function + -- that requires secondary stack management, because the function's + -- result would be reclaimed too early (see Find_Transient_Context). if Manage_Sec_Stack then -Set_Uses_Sec_Stack (Trans_Id); +declare + SE : Scope_Stack_Entry renames Scope_Stack.Table (Trans_Idx); + +begin + if Nkind (SE.Node_To_Be_Wrapped) /= N_Simple_Return_Statement + or else not + Needs_Secondary_Stack + (Etype + (Return_Applies_To + (Return_Statement_Entity (SE.Node_To_Be_Wrapped + then + Set_Uses_Sec_Stack (SE.Entity); + end if; +end; end if; return; -- 2.40.0
[COMMITTED] ada: Fix minor issues in user's guide
From: Ronan Desplanques
gcc/ada/
* doc/gnat_ugn/building_executable_programs_with_gnat.rst: Fix minor
issues.
* doc/gnat_ugn/the_gnat_compilation_model.rst: Fix minor issues.
* gnat_ugn.texi: Regenerate.
Tested on x86_64-pc-linux-gnu, committed on master.
---
...building_executable_programs_with_gnat.rst | 32 -
.../gnat_ugn/the_gnat_compilation_model.rst | 2 +-
gcc/ada/gnat_ugn.texi | 34 +--
3 files changed, 32 insertions(+), 36 deletions(-)
diff --git a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
index 2838a302f2e..20e003d4ac7 100644
--- a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
+++ b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
@@ -895,12 +895,12 @@ by ``gnatmake``. It may be necessary to use the switch
Examples of ``gnatmake`` Usage
--
-*gnatmake hello.adb*
+``gnatmake hello.adb``
Compile all files necessary to bind and link the main program
:file:`hello.adb` (containing unit ``Hello``) and bind and link the
resulting object files to generate an executable file :file:`hello`.
-*gnatmake main1 main2 main3*
+``gnatmake main1 main2 main3``
Compile all files necessary to bind and link the main programs
:file:`main1.adb` (containing unit ``Main1``), :file:`main2.adb`
(containing unit ``Main2``) and :file:`main3.adb`
@@ -908,7 +908,7 @@ Examples of ``gnatmake`` Usage
to generate three executable files :file:`main1`,
:file:`main2` and :file:`main3`.
-*gnatmake -q Main_Unit -cargs -O2 -bargs -l*
+``gnatmake -q Main_Unit -cargs -O2 -bargs -l``
Compile all files necessary to bind and link the main program unit
``Main_Unit`` (from file :file:`main_unit.adb`). All compilations will
be done with optimization level 2 and the order of elaboration will be
@@ -949,7 +949,7 @@ You need *not* compile the following files
* subunits
-because they are compiled as part of compiling related units. GNAT
+because they are compiled as part of compiling related units. GNAT compiles
package specs
when the corresponding body is compiled, and subunits when the parent is
compiled.
@@ -997,8 +997,6 @@ two output files in the current directory, but you may
specify a source
file in any directory using an absolute or relative path specification
containing the directory information.
-TESTING: the :switch:`--foobar{NN}` switch
-
.. index:: gnat1
``gcc`` is actually a driver program that looks at the extensions of
@@ -1068,7 +1066,7 @@ directories, in the following order:
* The content of the :file:`ada_source_path` file which is part of the GNAT
installation tree and is used to store standard libraries such as the
GNAT Run Time Library (RTL) source files.
- :ref:`Installing_a_library`
+ See also :ref:`Installing_a_library`.
Specifying the switch :switch:`-I-`
inhibits the use of the directory
@@ -1159,7 +1157,7 @@ Compile body in file :file:`xyz.adb` with all default
options.
$ gcc -c -O2 -gnata xyz-def.adb
Compile the child unit package in file :file:`xyz-def.adb` with extensive
-optimizations, and pragma ``Assert``/`Debug` statements
+optimizations, and pragma ``Assert``/``Debug`` statements
enabled.
.. code-block:: sh
@@ -1274,7 +1272,7 @@ Alphabetical List of All Switches
size of the executable, compared with a traditional per-unit compilation
with inlining across units enabled by the :switch:`-gnatn` switch.
The drawback of this approach is that it may require more memory and that
- the debugging information generated by -g with it might be hardly usable.
+ the debugging information generated by ``-g`` with it might be hardly usable.
The switch, as well as the accompanying :switch:`-Ox` switches, must be
specified both for the compilation and the link phases.
If the ``n`` parameter is specified, the optimization and final code
@@ -1472,7 +1470,7 @@ Alphabetical List of All Switches
This switch will generate an intermediate representation suitable for
use by CodePeer (:file:`.scil` files). This switch is not compatible with
code generation (it will, among other things, disable some switches such
- as -gnatn, and enable others such as -gnata).
+ as ``-gnatn``, and enable others such as ``-gnata``).
.. index:: -gnatd (gcc)
@@ -1482,9 +1480,9 @@ Alphabetical List of All Switches
the :switch:`-gnatd` specifies the specific debug options. The possible
characters are 0-9, a-z, A-Z, optionally preceded by a dot or underscore.
See compiler source file :file:`debug.adb` for details of the implemented
- debug options. Certain debug options are relevant to applications
+ debug options. Certain debug options are relevant to application
programmers, and these are documented at appropriate points in this
- users guide.
+ user's guide.
.. index:: -gnatD[nn] (gcc
[COMMITTED] ada: Fix storage model handling for dereference as lvalue and renamings
Don't require storage access for explicit dereferences used as
lvalue (e.g. Some_Access.all'Address) or for renamings.
gcc/ada/
* gcc-interface/trans.cc (get_storage_model_access): Don't require
storage model access for dereference used as lvalue or renamings.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gcc-interface/trans.cc | 24 +---
1 file changed, 21 insertions(+), 3 deletions(-)
diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc
index 13f438c424b..f4a5db002f4 100644
--- a/gcc/ada/gcc-interface/trans.cc
+++ b/gcc/ada/gcc-interface/trans.cc
@@ -4398,14 +4398,32 @@ static void
get_storage_model_access (Node_Id gnat_node, Entity_Id *gnat_smo)
{
const Node_Id gnat_parent = Parent (gnat_node);
+ *gnat_smo = Empty;
- /* If we are the prefix of the parent, then the access is above us. */
- if (node_is_component (gnat_parent) && Prefix (gnat_parent) == gnat_node)
+ switch (Nkind (gnat_parent))
{
- *gnat_smo = Empty;
+case N_Attribute_Reference:
+ /* If the parent is an attribute reference that requires an lvalue and
+ gnat_node is the Prefix (i.e. not a parameter), we do not need to
+ actually access any storage. */
+ if (lvalue_required_for_attribute_p (gnat_parent)
+ && Prefix (gnat_parent) == gnat_node)
+return;
+ break;
+
+case N_Object_Renaming_Declaration:
+ /* Nothing to do for the identifier in an object renaming declaration,
+ the renaming itself does not need storage model access. */
return;
+
+default:
+ break;
}
+ /* If we are the prefix of the parent, then the access is above us. */
+ if (node_is_component (gnat_parent) && Prefix (gnat_parent) == gnat_node)
+return;
+
/* Now strip any type conversion from GNAT_NODE. */
if (Nkind (gnat_node) == N_Type_Conversion
|| Nkind (gnat_node) == N_Unchecked_Type_Conversion)
--
2.40.0
[COMMITTED] ada: Fix wrong access for qualified aggregate with storage model
From: Eric Botcazou
The previous fix to get_storage_model_access was incomplete and needs to be
extended to the node itself.
gcc/ada/
* gcc-interface/trans.cc (get_storage_model_access): Also strip any
type conversion in the node when unwinding the components.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gcc-interface/trans.cc | 9 ++---
1 file changed, 6 insertions(+), 3 deletions(-)
diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc
index 2e8d979831f..ddc7b6dde1e 100644
--- a/gcc/ada/gcc-interface/trans.cc
+++ b/gcc/ada/gcc-interface/trans.cc
@@ -4438,12 +4438,15 @@ get_storage_model_access (Node_Id gnat_node, Entity_Id
*gnat_smo)
&& Prefix (Parent (gnat_parent)) == gnat_parent))
return;
- /* Now strip any type conversion from GNAT_NODE. */
+ /* Find the innermost prefix in GNAT_NODE, stripping any type conversion. */
if (node_is_type_conversion (gnat_node))
gnat_node = Expression (gnat_node);
-
while (node_is_component (gnat_node))
-gnat_node = Prefix (gnat_node);
+{
+ gnat_node = Prefix (gnat_node);
+ if (node_is_type_conversion (gnat_node))
+ gnat_node = Expression (gnat_node);
+}
*gnat_smo = get_storage_model (gnat_node);
}
--
2.40.0
[COMMITTED] ada: Fix internal error on array constant in expression function
From: Eric Botcazou This happens when the peculiar check emitted by Check_Large_Modular_Array is applied to an object whose actual subtype is an itype with dynamic size, because the first reference to the itype in the expanded code may turn out to be within the raise statement, which is problematic for the eloboration of this itype by the code generator at library level. gcc/ada/ * freeze.adb (Check_Large_Modular_Array): Fix head comment, use Standard_Long_Long_Integer_Size directly and generate a reference just before the raise statement if the Etype of the object is an itype declared in an open scope. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/freeze.adb | 25 + 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 8ebf10bd576..83ce0300871 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -4110,9 +4110,10 @@ package body Freeze is procedure Check_Large_Modular_Array (Typ : Entity_Id); -- Check that the size of array type Typ can be computed without -- overflow, and generates a Storage_Error otherwise. This is only - -- relevant for array types whose index has System_Max_Integer_Size - -- bits, where wrap-around arithmetic might yield a meaningless value - -- for the length of the array, or its corresponding attribute. + -- relevant for array types whose index is a modular type with + -- Standard_Long_Long_Integer_Size bits: wrap-around arithmetic + -- might yield a meaningless value for the length of the array, + -- or its corresponding attribute. procedure Check_Pragma_Thread_Local_Storage (Var_Id : Entity_Id); -- Ensure that the initialization state of variable Var_Id subject @@ -4170,8 +4171,24 @@ package body Freeze is -- Storage_Error. if Is_Modular_Integer_Type (Idx_Typ) - and then RM_Size (Idx_Typ) = RM_Size (Standard_Long_Long_Integer) + and then RM_Size (Idx_Typ) = Standard_Long_Long_Integer_Size then + -- Ensure that the type of the object is elaborated before + -- the check itself is emitted to avoid elaboration issues + -- in the code generator at the library level. + + if Is_Itype (Etype (E)) + and then In_Open_Scopes (Scope (Etype (E))) + then + declare + Ref_Node : constant Node_Id := + Make_Itype_Reference (Obj_Loc); + begin + Set_Itype (Ref_Node, Etype (E)); + Insert_Action (Declaration_Node (E), Ref_Node); + end; + end if; + Insert_Action (Declaration_Node (E), Make_Raise_Storage_Error (Obj_Loc, Condition => -- 2.40.0
[COMMITTED] ada: Add System.Traceback.Symbolic.Module_Name support on AArch64 Linux
From: Joel Brobecker This commit changes the runtime on aarch64-linux to use the Linux version of s-tsmona.adb, so as to add support for this functionality on aarch64-linux. gcc/ada/ * Makefile.rtl: Use libgnat/s-tsmona__linux.adb on aarch64-linux. Link libgnat with -ldl, as the use of s-tsmona__linux.adb requires it. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/Makefile.rtl | 2 ++ 1 file changed, 2 insertions(+) diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index e2f437ff6e5..ca4c528a7e0 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -2250,6 +2250,7 @@ ifeq ($(strip $(filter-out aarch64% linux%,$(target_cpu) $(target_os))),) s-intman.adb
[COMMITTED] ada: Minor generic tweaks left and and right
From: Eric Botcazou No functional changes. gcc/ada/ * gcc-interface/decl.cc (gnat_to_gnu_entity) : Replace integer_zero_node with null_pointer_node for pointer types. * gcc-interface/trans.cc (gnat_gimplify_expr) : Likewise. * gcc-interface/utils.cc (maybe_pad_type): Do not attempt to make a packable type from a fat pointer type. * gcc-interface/utils2.cc (build_atomic_load): Use a local variable. (build_atomic_store): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/gcc-interface/decl.cc | 2 +- gcc/ada/gcc-interface/trans.cc | 2 +- gcc/ada/gcc-interface/utils.cc | 1 + gcc/ada/gcc-interface/utils2.cc | 21 +++-- 4 files changed, 14 insertions(+), 12 deletions(-) diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc index 53a11243590..456fe53737d 100644 --- a/gcc/ada/gcc-interface/decl.cc +++ b/gcc/ada/gcc-interface/decl.cc @@ -1212,7 +1212,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type)) && !gnu_expr && !Is_Imported (gnat_entity)) - gnu_expr = integer_zero_node; + gnu_expr = null_pointer_node; /* If we are defining the object and it has an Address clause, we must either get the address expression from the saved GCC tree for the diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc index 4e5f26305f5..8c8a78f5d2d 100644 --- a/gcc/ada/gcc-interface/trans.cc +++ b/gcc/ada/gcc-interface/trans.cc @@ -8987,7 +8987,7 @@ gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p, || TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) *expr_p = build_unary_op (INDIRECT_REF, NULL_TREE, convert (build_pointer_type (type), - integer_zero_node)); + null_pointer_node)); /* Otherwise, just make a VAR_DECL. */ else diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc index 337b552619e..8f1861b848e 100644 --- a/gcc/ada/gcc-interface/utils.cc +++ b/gcc/ada/gcc-interface/utils.cc @@ -1562,6 +1562,7 @@ maybe_pad_type (tree type, tree size, unsigned int align, at the RTL level when the stand-alone object is accessed as a whole. */ if (align > 0 && RECORD_OR_UNION_TYPE_P (type) + && !TYPE_IS_FAT_POINTER_P (type) && TYPE_MODE (type) == BLKmode && !TYPE_BY_REFERENCE_P (type) && TREE_CODE (orig_size) == INTEGER_CST diff --git a/gcc/ada/gcc-interface/utils2.cc b/gcc/ada/gcc-interface/utils2.cc index c56fccb4a98..e1737724b65 100644 --- a/gcc/ada/gcc-interface/utils2.cc +++ b/gcc/ada/gcc-interface/utils2.cc @@ -692,13 +692,14 @@ build_atomic_load (tree src, bool sync) = build_int_cst (integer_type_node, sync ? MEMMODEL_SEQ_CST : MEMMODEL_RELAXED); tree orig_src = src; - tree t, addr, val; + tree type, t, addr, val; unsigned int size; int fncode; /* Remove conversions to get the address of the underlying object. */ src = remove_conversions (src, false); - size = resolve_atomic_size (TREE_TYPE (src)); + type = TREE_TYPE (src); + size = resolve_atomic_size (type); if (size == 0) return orig_src; @@ -710,7 +711,7 @@ build_atomic_load (tree src, bool sync) /* First reinterpret the loaded bits in the original type of the load, then convert to the expected result type. */ - t = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (src), val); + t = fold_build1 (VIEW_CONVERT_EXPR, type, val); return convert (TREE_TYPE (orig_src), t); } @@ -728,13 +729,14 @@ build_atomic_store (tree dest, tree src, bool sync) = build_int_cst (integer_type_node, sync ? MEMMODEL_SEQ_CST : MEMMODEL_RELAXED); tree orig_dest = dest; - tree t, int_type, addr; + tree type, t, int_type, addr; unsigned int size; int fncode; /* Remove conversions to get the address of the underlying object. */ dest = remove_conversions (dest, false); - size = resolve_atomic_size (TREE_TYPE (dest)); + type = TREE_TYPE (dest); + size = resolve_atomic_size (type); if (size == 0) return build_binary_op (MODIFY_EXPR, NULL_TREE, orig_dest, src); @@ -746,12 +748,11 @@ build_atomic_store (tree dest, tree src, bool sync) then reinterpret them in the effective type. But if the original type is a padded type with the same size, convert to the inner type instead, as we don't want to artificially introduce a CONSTRUCTOR here. */ - if (TYPE_IS_PADDING_P (TREE_TYPE (dest)) - && TYPE_SIZE (TREE_TYPE (dest)) -== TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (dest) -src = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (dest))), src); + if (TYPE_IS_PADDING_P (type) + && TYPE_SIZE (type) == TYPE_SIZE (TREE_TYPE (T
[COMMITTED] ada: Fix wrong expansion of array aggregate with noncontiguous choices
From: Eric Botcazou This extends an earlier fix done for the others choice of an array aggregate to all the choices of the aggregate, since the same sharing issue may happen when the choices are not contiguous. gcc/ada/ * exp_aggr.adb (Build_Array_Aggr_Code.Get_Assoc_Expr): Duplicate the expression here instead of... (Build_Array_Aggr_Code): ...here. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 38 ++ 1 file changed, 18 insertions(+), 20 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 93fcac5439e..da31d2480f2 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -2215,21 +2215,32 @@ package body Exp_Aggr is -- Get_Assoc_Expr -- + -- Duplicate the expression in case we will be generating several loops. + -- As a result the expression is no longer shared between the loops and + -- is reevaluated for each such loop. + function Get_Assoc_Expr (Assoc : Node_Id) return Node_Id is Typ : constant Entity_Id := Base_Type (Etype (N)); begin if Box_Present (Assoc) then if Present (Default_Aspect_Component_Value (Typ)) then - return Default_Aspect_Component_Value (Typ); + return New_Copy_Tree (Default_Aspect_Component_Value (Typ)); elsif Needs_Simple_Initialization (Ctype) then - return Get_Simple_Init_Val (Ctype, N); + return New_Copy_Tree (Get_Simple_Init_Val (Ctype, N)); else return Empty; end if; else -return Expression (Assoc); +-- The expression will be passed to Gen_Loop, which immediately +-- calls Parent_Kind on it, so we set Parent when it matters. + +return + Expr : constant Node_Id := New_Copy_Tree (Expression (Assoc)) +do + Copy_Parent (To => Expr, From => Expression (Assoc)); +end return; end if; end Get_Assoc_Expr; @@ -2394,8 +2405,7 @@ package body Exp_Aggr is if Present (Others_Assoc) then declare - First: Boolean := True; - Dup_Expr : Node_Id; + First : Boolean := True; begin for J in 0 .. Nb_Choices loop @@ -2429,23 +2439,11 @@ package body Exp_Aggr is end if; end if; - if First -or else not Empty_Range (Low, High) - then + if First or else not Empty_Range (Low, High) then First := False; - - -- Duplicate the expression in case we will be generating - -- several loops. As a result the expression is no longer - -- shared between the loops and is reevaluated for each - -- such loop. - - Expr := Get_Assoc_Expr (Others_Assoc); - Dup_Expr := New_Copy_Tree (Expr); - Copy_Parent (To => Dup_Expr, From => Expr); - Set_Loop_Actions (Others_Assoc, New_List); - Append_List - (Gen_Loop (Low, High, Dup_Expr), To => New_Code); + Expr := Get_Assoc_Expr (Others_Assoc); + Append_List (Gen_Loop (Low, High, Expr), To => New_Code); end if; end loop; end; -- 2.40.0
[COMMITTED] ada: Small cleanups and fixes in expansion of aggregates
From: Eric Botcazou This streamlines the handling of qualified expressions in the expansion of aggregates and plugs a couple of loopholes that may cause memory leaks. gcc/ada/ * exp_aggr.adb (Build_Array_Aggr_Code): Move the declaration of Typ to the beginning. (Initialize_Array_Component): Test the unqualified version of the expression for the nested array case. (Initialize_Ctrl_Array_Component): Do not duplicate the expression here. Do the pattern matching of the unqualified version of it. (Gen_Assign): Call Unqualify to compute Expr_Q and use Expr_Q in subsequent pattern matching. (Initialize_Ctrl_Record_Component): Do the pattern matching of the unqualified version of the aggregate. (Build_Record_Aggr_Code): Call Unqualify. (Convert_Aggr_In_Assignment): Likewise. (Convert_Aggr_In_Object_Decl): Likewise. (Component_OK_For_Backend): Likewise. (Is_Delayed_Aggregate): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 90 ++-- 1 file changed, 28 insertions(+), 62 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index da31d2480f2..270d3bb8d66 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -1060,6 +1060,7 @@ package body Exp_Aggr is Indexes : List_Id := No_List) return List_Id is Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); Index_Base : constant Entity_Id := Base_Type (Etype (Index)); Index_Base_L : constant Node_Id := Type_Low_Bound (Index_Base); Index_Base_H : constant Node_Id := Type_High_Bound (Index_Base); @@ -1460,7 +1461,7 @@ package body Exp_Aggr is and then not (Is_Array_Type (Comp_Typ) and then Needs_Finalization (Component_Type (Comp_Typ)) - and then Nkind (Expr) = N_Aggregate) + and then Nkind (Unqualify (Init_Expr)) = N_Aggregate) then Adj_Call := Make_Adjust_Call @@ -1522,9 +1523,10 @@ package body Exp_Aggr is Init_Expr : Node_Id; Stmts : List_Id) is +Init_Expr_Q : constant Node_Id := Unqualify (Init_Expr); + Act_Aggr : Node_Id; Act_Stmts : List_Id; -Expr : Node_Id; Fin_Call : Node_Id; Hook_Clear : Node_Id; @@ -1533,29 +1535,20 @@ package body Exp_Aggr is -- in-place expansion. begin --- Duplicate the initialization expression in case the context is --- a multi choice list or an "others" choice which plugs various --- holes in the aggregate. As a result the expression is no longer --- shared between the various components and is reevaluated for --- each such component. - -Expr := New_Copy_Tree (Init_Expr); -Set_Parent (Expr, Parent (Init_Expr)); - -- Perform a preliminary analysis and resolution to determine what -- the initialization expression denotes. An unanalyzed function -- call may appear as an identifier or an indexed component. -if Nkind (Expr) in N_Function_Call - | N_Identifier - | N_Indexed_Component - and then not Analyzed (Expr) +if Nkind (Init_Expr_Q) in N_Function_Call +| N_Identifier +| N_Indexed_Component + and then not Analyzed (Init_Expr) then - Preanalyze_And_Resolve (Expr, Comp_Typ); + Preanalyze_And_Resolve (Init_Expr, Comp_Typ); end if; In_Place_Expansion := - Nkind (Expr) = N_Function_Call + Nkind (Init_Expr_Q) = N_Function_Call and then not Is_Build_In_Place_Result_Type (Comp_Typ); -- The initialization expression is a controlled function call. @@ -1572,7 +1565,7 @@ package body Exp_Aggr is -- generation of a transient scope, which leads to out-of-order -- adjustment and finalization. - Set_No_Side_Effect_Removal (Expr); + Set_No_Side_Effect_Removal (Init_Expr); -- When the transient component initialization is related to a -- range or an "others", keep all generated statements within @@ -1598,7 +1591,7 @@ package body Exp_Aggr is Process_Transient_Component (Loc=> Loc, Comp_Typ => Comp_Typ, - Init_Expr => Expr, + Init_Expr => Init_Expr, Fin_Call => Fin_Call, Hook_Clear => Hook_C
[COMMITTED] ada: Fix internal error on qualified aggregate with storage model
From: Eric Botcazou
It comes from a small oversight in get_storage_model_access.
gcc/ada/
* gcc-interface/trans.cc (node_is_component): Remove parentheses.
(node_is_type_conversion): New predicate.
(get_atomic_access): Use it.
(get_storage_model_access): Likewise and look into the parent to
find a component if it returns true.
(present_in_lhs_or_actual_p): Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gcc-interface/trans.cc | 36 ++
1 file changed, 19 insertions(+), 17 deletions(-)
diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc
index 18f7e73d45d..2e8d979831f 100644
--- a/gcc/ada/gcc-interface/trans.cc
+++ b/gcc/ada/gcc-interface/trans.cc
@@ -4264,8 +4264,16 @@ static inline bool
node_is_component (Node_Id gnat_node)
{
const Node_Kind k = Nkind (gnat_node);
- return
-(k == N_Indexed_Component || k == N_Selected_Component || k == N_Slice);
+ return k == N_Indexed_Component || k == N_Selected_Component || k == N_Slice;
+}
+
+/* Return true if GNAT_NODE is a type conversion. */
+
+static inline bool
+node_is_type_conversion (Node_Id gnat_node)
+{
+ const Node_Kind k = Nkind (gnat_node);
+ return k == N_Type_Conversion || k == N_Unchecked_Type_Conversion;
}
/* Compute whether GNAT_NODE requires atomic access and set TYPE to the type
@@ -4316,8 +4324,7 @@ get_atomic_access (Node_Id gnat_node, atomic_acces_t
*type, bool *sync)
}
/* Now strip any type conversion from GNAT_NODE. */
- if (Nkind (gnat_node) == N_Type_Conversion
- || Nkind (gnat_node) == N_Unchecked_Type_Conversion)
+ if (node_is_type_conversion (gnat_node))
gnat_node = Expression (gnat_node);
/* Up to Ada 2012, for Atomic itself, only reads and updates of the object as
@@ -4425,12 +4432,14 @@ get_storage_model_access (Node_Id gnat_node, Entity_Id
*gnat_smo)
}
/* If we are the prefix of the parent, then the access is above us. */
- if (node_is_component (gnat_parent) && Prefix (gnat_parent) == gnat_node)
+ if ((node_is_component (gnat_parent) && Prefix (gnat_parent) == gnat_node)
+ || (node_is_type_conversion (gnat_parent)
+ && node_is_component (Parent (gnat_parent))
+ && Prefix (Parent (gnat_parent)) == gnat_parent))
return;
/* Now strip any type conversion from GNAT_NODE. */
- if (Nkind (gnat_node) == N_Type_Conversion
- || Nkind (gnat_node) == N_Unchecked_Type_Conversion)
+ if (node_is_type_conversion (gnat_node))
gnat_node = Expression (gnat_node);
while (node_is_component (gnat_node))
@@ -6115,16 +6124,9 @@ lhs_or_actual_p (Node_Id gnat_node)
static bool
present_in_lhs_or_actual_p (Node_Id gnat_node)
{
- if (lhs_or_actual_p (gnat_node))
-return true;
-
- const Node_Kind kind = Nkind (Parent (gnat_node));
-
- if ((kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
- && lhs_or_actual_p (Parent (gnat_node)))
-return true;
-
- return false;
+ return lhs_or_actual_p (gnat_node)
+|| (node_is_type_conversion (Parent (gnat_node))
+&& lhs_or_actual_p (Parent (gnat_node)));
}
/* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
--
2.40.0
[COMMITTED] ada: Simplify the implementation of storage models
From: Eric Botcazou
As the additional temporaries required by the semantics of nonnative storage
models are now created by the front-end, in particular for actual parameters
and assignment statements, the corresponding code in gigi can be removed.
gcc/ada/
* gcc-interface/trans.cc (Call_to_gnu): Remove code implementing the
by-copy semantics for actuals with nonnative storage models.
(gnat_to_gnu) : Remove code instantiating a
temporary for assignments between nonnative storage models.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gcc-interface/trans.cc | 130 +++--
1 file changed, 27 insertions(+), 103 deletions(-)
diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc
index f4a5db002f4..92c8dc33af8 100644
--- a/gcc/ada/gcc-interface/trans.cc
+++ b/gcc/ada/gcc-interface/trans.cc
@@ -4560,14 +4560,13 @@ elaborate_profile (Entity_Id first_formal, Entity_Id
result_type)
N_Assignment_Statement and the result is to be placed into that object.
ATOMIC_ACCESS is the type of atomic access to be used for the assignment
to GNU_TARGET. If, in addition, ATOMIC_SYNC is true, then the assignment
- to GNU_TARGET requires atomic synchronization. GNAT_STORAGE_MODEL is the
- storage model object to be used for the assignment to GNU_TARGET or Empty
- if there is none. */
+ to GNU_TARGET requires atomic synchronization. GNAT_SMO is the storage
+ model object to be used for the assignment to GNU_TARGET or Empty if there
+ is none. */
static tree
Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
-atomic_acces_t atomic_access, bool atomic_sync,
-Entity_Id gnat_storage_model)
+atomic_acces_t atomic_access, bool atomic_sync, Entity_Id gnat_smo)
{
const bool function_call = (Nkind (gnat_node) == N_Function_Call);
const bool returning_value = (function_call && !gnu_target);
@@ -4599,7 +4598,6 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p,
tree gnu_target,
Node_Id gnat_actual;
atomic_acces_t aa_type;
bool aa_sync;
- Entity_Id gnat_smo;
/* The only way we can make a call via an access type is if GNAT_NAME is an
explicit dereference. In that case, get the list of formal args from the
@@ -4751,8 +4749,8 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p,
tree gnu_target,
!= TYPE_SIZE (TREE_TYPE (gnu_target))
&& type_is_padding_self_referential (gnu_result_type))
|| (gnu_target
- && Present (gnat_storage_model)
- && Present (Storage_Model_Copy_To (gnat_storage_model)
+ && Present (gnat_smo)
+ && Present (Storage_Model_Copy_To (gnat_smo)
{
gnu_retval = create_temporary ("R", gnu_result_type);
DECL_RETURN_VALUE_P (gnu_retval) = 1;
@@ -4823,19 +4821,12 @@ Call_to_gnu (Node_Id gnat_node, tree
*gnu_result_type_p, tree gnu_target,
= build_compound_expr (TREE_TYPE (gnu_name), init, gnu_name);
}
- get_storage_model_access (gnat_actual, &gnat_smo);
-
- /* If we are passing a non-addressable actual parameter by reference,
-pass the address of a copy. Likewise if it needs to be accessed with
-a storage model. In the In Out or Out case, set up to copy back out
-after the call. */
+ /* If we are passing a non-addressable parameter by reference, pass the
+address of a copy. In the In Out or Out case, set up to copy back
+out after the call. */
if (is_by_ref_formal_parm
&& (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
- && (!addressable_p (gnu_name, gnu_name_type)
- || (Present (gnat_smo)
- && (Present (Storage_Model_Copy_From (gnat_smo))
- || (!in_param
- && Present (Storage_Model_Copy_To (gnat_smo)))
+ && !addressable_p (gnu_name, gnu_name_type))
{
tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
@@ -4906,40 +4897,21 @@ Call_to_gnu (Node_Id gnat_node, tree
*gnu_result_type_p, tree gnu_target,
}
/* Create an explicit temporary holding the copy. */
- tree gnu_temp_type;
- if (Nkind (gnat_actual) == N_Explicit_Dereference
- && Present (Actual_Designated_Subtype (gnat_actual)))
- gnu_temp_type
- = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_actual));
- else
- gnu_temp_type = TREE_TYPE (gnu_name);
/* Do not initialize it for the _Init parameter of an initialization
procedure since no data is meant to be passed in. */
if (Ekind (gnat_formal) == E_Out_Parameter
&& Is_Entity_Name (gnat_subprog)
&& Is_Init_Proc (Entity (gnat_subprog)))
- gnu_name = gnu_temp = create_temporary ("A", gnu_temp_type);
+
[COMMITTED] ada: Disable PIE mode during the build of the Ada front-end
From: Eric Botcazou This also removes some obsolete stuff. gcc/ada/ * gcc-interface/Make-lang.in (ADA_CFLAGS): Move up. (ALL_ADAFLAGS): Add $(NO_PIE_CFLAGS). (ada/mdll.o): Remove. (ada/mdll-fil.o): Likewise. (ada/mdll-utl.o): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/gcc-interface/Make-lang.in | 16 +++- 1 file changed, 3 insertions(+), 13 deletions(-) diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 7b826f2366f..d7bab7d3ce8 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -71,10 +71,11 @@ else ADAFLAGS=$(COMMON_ADAFLAGS) endif +ADA_CFLAGS = ALL_ADAFLAGS = \ - $(CFLAGS) $(ADA_CFLAGS) $(ADAFLAGS) $(CHECKING_ADAFLAGS) $(WARN_ADAFLAGS) + $(CFLAGS) $(NO_PIE_CFLAGS) $(ADA_CFLAGS) \ + $(ADAFLAGS) $(CHECKING_ADAFLAGS) $(WARN_ADAFLAGS) FORCE_DEBUG_ADAFLAGS = -g -ADA_CFLAGS = COMMON_ADA_INCLUDES = -I- -I. -Iada/generated -Iada -I$(srcdir)/ada STAGE1_LIBS= @@ -1174,17 +1175,6 @@ ada/gnatvsn.o : ada/gnatvsn.adb ada/generated/gnatvsn.ads $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) @$(ADA_DEPS) -# Dependencies for windows specific tool (mdll) - -ada/mdll.o : ada/mdll.adb ada/mdll.ads ada/mdll-fil.ads ada/mdll-utl.ads - $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) - -ada/mdll-fil.o : ada/mdll-fil.adb ada/mdll.ads ada/mdll-fil.ads - $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) - -ada/mdll-utl.o : ada/mdll-utl.adb ada/mdll.ads ada/mdll-utl.ads ada/sdefault.ads ada/types.ads - $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) - # All generated files. Perhaps we should build all of these in the same # subdirectory, and get rid of ada/bldtools. # Warning: the files starting with ada/gnat.ads are not really generated, -- 2.40.0
[COMMITTED] ada: Adjust again the implementation of storage models
From: Eric Botcazou
The code generator must now be prepared to translate assignment statements
to objects allocated with a storage model and that are not initialized yet.
gcc/ada/
* gcc-interface/trans.cc (Attribute_to_gnu) : Tweak.
(gnat_to_gnu) : Declare a local variable.
For a target with a storage model, use the Actual_Designated_Subtype
to compute the size if it is present.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gcc-interface/trans.cc | 51 +++---
1 file changed, 29 insertions(+), 22 deletions(-)
diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc
index 92c8dc33af8..4e5f26305f5 100644
--- a/gcc/ada/gcc-interface/trans.cc
+++ b/gcc/ada/gcc-interface/trans.cc
@@ -1945,24 +1945,20 @@ Attribute_to_gnu (Node_Id gnat_node, tree
*gnu_result_type_p, int attribute)
/* If this is a dereference and we have a special dynamic constrained
subtype on the prefix, use it to compute the size; otherwise, use
the designated subtype. */
- if (Nkind (gnat_prefix) == N_Explicit_Dereference)
+ if (Nkind (gnat_prefix) == N_Explicit_Dereference
+ && Present (Actual_Designated_Subtype (gnat_prefix)))
{
- Node_Id gnat_actual_subtype
- = Actual_Designated_Subtype (gnat_prefix);
+ tree gnu_actual_obj_type
+ = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_prefix));
tree gnu_ptr_type
= TREE_TYPE (gnat_to_gnu (Prefix (gnat_prefix)));
- if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
- && Present (gnat_actual_subtype))
- {
- tree gnu_actual_obj_type
- = gnat_to_gnu_type (gnat_actual_subtype);
- gnu_type
- = build_unc_object_type_from_ptr (gnu_ptr_type,
- gnu_actual_obj_type,
- get_identifier ("SIZE"),
- false);
- }
+ if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
+ gnu_type
+ = build_unc_object_type_from_ptr (gnu_ptr_type,
+ gnu_actual_obj_type,
+ get_identifier ("SIZE"),
+ false);
}
gnu_result = TYPE_SIZE (gnu_type);
@@ -7378,13 +7374,13 @@ gnat_to_gnu (Node_Id gnat_node)
/* Otherwise we need to build the assignment statement manually. */
else
{
+ const Node_Id gnat_name = Name (gnat_node);
const Node_Id gnat_expr = Expression (gnat_node);
const Node_Id gnat_inner
= Nkind (gnat_expr) == N_Qualified_Expression
? Expression (gnat_expr)
: gnat_expr;
- const Entity_Id gnat_type
- = Underlying_Type (Etype (Name (gnat_node)));
+ const Entity_Id gnat_type = Underlying_Type (Etype (gnat_name));
const bool use_memset_p
= Is_Array_Type (gnat_type)
&& Nkind (gnat_inner) == N_Aggregate
@@ -7409,8 +7405,8 @@ gnat_to_gnu (Node_Id gnat_node)
gigi_checking_assert (!Do_Range_Check (gnat_expr));
- get_atomic_access (Name (gnat_node), &aa_type, &aa_sync);
- get_storage_model_access (Name (gnat_node), &gnat_smo);
+ get_atomic_access (gnat_name, &aa_type, &aa_sync);
+ get_storage_model_access (gnat_name, &gnat_smo);
/* If an outer atomic access is required on the LHS, build the load-
modify-store sequence. */
@@ -7427,15 +7423,26 @@ gnat_to_gnu (Node_Id gnat_node)
else if (Present (gnat_smo)
&& Present (Storage_Model_Copy_To (gnat_smo)))
{
+ tree gnu_size;
+
/* We obviously cannot use memset in this case. */
gcc_assert (!use_memset_p);
- /* We cannot directly move between nonnative storage models. */
- tree t = remove_conversions (gnu_rhs, false);
- gcc_assert (TREE_CODE (t) != LOAD_EXPR);
+ /* If this is a dereference with a special dynamic constrained
+subtype on the node, use it to compute the size. */
+ if (Nkind (gnat_name) == N_Explicit_Dereference
+ && Present (Actual_Designated_Subtype (gnat_name)))
+ {
+ tree gnu_actual_obj_type
+ = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_name));
+ gnu_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
+ }
+ else
+ gnu_size = NULL_TREE;
gnu_result
- = build_storage_model_store (gnat_smo, gnu_lhs, gnu_rhs);
+
[COMMITTED] ada: Make internal_error_function more robust
From: Eric Botcazou
gcc/ada/
* gcc-interface/misc.cc (internal_error_function): Be prepared for
an input_location set to UNKNOWN_LOCATION.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gcc-interface/misc.cc | 22 --
1 file changed, 16 insertions(+), 6 deletions(-)
diff --git a/gcc/ada/gcc-interface/misc.cc b/gcc/ada/gcc-interface/misc.cc
index 56c7bb9b533..30319ae58b1 100644
--- a/gcc/ada/gcc-interface/misc.cc
+++ b/gcc/ada/gcc-interface/misc.cc
@@ -330,13 +330,23 @@ internal_error_function (diagnostic_context *context,
const char *msgid,
sp.Bounds = &temp;
sp.Array = buffer;
- xloc = expand_location (input_location);
- if (context->show_column && xloc.column != 0)
-loc = xasprintf ("%s:%d:%d", xloc.file, xloc.line, xloc.column);
+ if (input_location == UNKNOWN_LOCATION)
+{
+ loc = NULL;
+ temp_loc.Low_Bound = 1;
+ temp_loc.High_Bound = 0;
+}
else
-loc = xasprintf ("%s:%d", xloc.file, xloc.line);
- temp_loc.Low_Bound = 1;
- temp_loc.High_Bound = strlen (loc);
+{
+ xloc = expand_location (input_location);
+ if (context->show_column && xloc.column != 0)
+ loc = xasprintf ("%s:%d:%d", xloc.file, xloc.line, xloc.column);
+ else
+ loc = xasprintf ("%s:%d", xloc.file, xloc.line);
+ temp_loc.Low_Bound = 1;
+ temp_loc.High_Bound = strlen (loc);
+}
+
sp_loc.Bounds = &temp_loc;
sp_loc.Array = loc;
--
2.40.0
[COMMITTED] ada: Fix minor issue with Mod operator
From: Eric Botcazou gcc/ada/ * gcc-interface/trans.cc (gnat_to_gnu) : Test the precision of the operation rather than that of the result type. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/gcc-interface/trans.cc | 8 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc index 8c8a78f5d2d..1c3c6c0618e 100644 --- a/gcc/ada/gcc-interface/trans.cc +++ b/gcc/ada/gcc-interface/trans.cc @@ -7095,9 +7095,9 @@ gnat_to_gnu (Node_Id gnat_node) gnu_rhs = convert (gnu_count_type, gnu_rhs); gnu_max_shift = convert (TREE_TYPE (gnu_rhs), TYPE_SIZE (gnu_type)); - /* If the result type is larger than a word, then declare the dependence - on the libgcc routine. */ - if (TYPE_PRECISION (gnu_result_type) > BITS_PER_WORD) + /* If the result type is larger than a word, then declare the + dependence on the libgcc routine. */ + if (TYPE_PRECISION (gnu_type) > BITS_PER_WORD) Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node); } @@ -7114,7 +7114,7 @@ gnat_to_gnu (Node_Id gnat_node) /* If this is a modulo/remainder and the result type is larger than a word, then declare the dependence on the libgcc routine. */ else if ((kind == N_Op_Mod ||kind == N_Op_Rem) -&& TYPE_PRECISION (gnu_result_type) > BITS_PER_WORD) +&& TYPE_PRECISION (gnu_type) > BITS_PER_WORD) Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node); /* Pending generic support for efficient vector logical operations in -- 2.40.0
[COMMITTED] ada: Fix incorrect copies being used with 'Address
When using 'Address on an object with a size clause, gigi would end up creating a copy and using its address instead of the one of the original object, leading to incorrect behavior. Remove the conversion (that triggers the copy) when 'Address is applied to a declaration. gcc/ada/ * gcc-interface/trans.cc (Attribute_to_gnu): Also strip conversion in case of DECL. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/gcc-interface/trans.cc | 13 + 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc index 1c3c6c0618e..57933ceb8a3 100644 --- a/gcc/ada/gcc-interface/trans.cc +++ b/gcc/ada/gcc-interface/trans.cc @@ -1714,12 +1714,17 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) case Attr_Address: case Attr_Unrestricted_Access: /* Conversions don't change the address of references but can cause -build_unary_op to miss the references below, so strip them off. +build_unary_op to miss the references below so strip them off. + + Also remove the conversions applied to declarations as the intent is + to take the decls' address, not that of the copies that the + conversions may create. + On the contrary, if the address-of operation causes a temporary to be created, then it must be created with the proper type. */ gnu_expr = remove_conversions (gnu_prefix, !Must_Be_Byte_Aligned (gnat_node)); - if (REFERENCE_CLASS_P (gnu_expr)) + if (REFERENCE_CLASS_P (gnu_expr) || DECL_P (gnu_expr)) gnu_prefix = gnu_expr; /* If we are taking 'Address of an unconstrained object, this is the @@ -4575,7 +4580,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */ tree gnu_subprog_type = TREE_TYPE (gnu_subprog); /* The return type of the FUNCTION_TYPE. */ - tree gnu_result_type;; + tree gnu_result_type; const bool frontend_builtin = (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_BUILT_IN_CLASS (gnu_subprog) == BUILT_IN_FRONTEND); @@ -4657,7 +4662,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, } /* We must elaborate the entire profile now because, if it references types - that were initially incomplete,, their elaboration changes the contents + that were initially incomplete, their elaboration changes the contents of GNU_SUBPROG_TYPE and, in particular, may change the result type. */ elaborate_profile (gnat_formal, gnat_result_type); -- 2.40.0
[COMMITTED] ada: Fix bogus Storage_Error on dynamic array with static zero length
From: Eric Botcazou
This works around the limitations present for the support of arrays in the
middle-end by clearing the TREE_OVERFLOW flag for arrays with zero length.
gcc/ada/
* gcc-interface/decl.cc (gnat_to_gnu_entity) : Use a
local variable for the GNAT index type.
: Likewise. Call Is_Null_Range on the bounds and
force the zero on TYPE_SIZE and TYPE_SIZE_UNIT if it returns true.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gcc-interface/decl.cc | 25 +
1 file changed, 21 insertions(+), 4 deletions(-)
diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc
index 456fe53737d..e5e04ddad93 100644
--- a/gcc/ada/gcc-interface/decl.cc
+++ b/gcc/ada/gcc-interface/decl.cc
@@ -2241,9 +2241,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree
gnu_expr, bool definition)
index += (convention_fortran_p ? - 1 : 1),
gnat_index = Next_Index (gnat_index))
{
+ const Entity_Id gnat_index_type = Etype (gnat_index);
const bool is_flb
- = Is_Fixed_Lower_Bound_Index_Subtype (Etype (gnat_index));
- tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
+ = Is_Fixed_Lower_Bound_Index_Subtype (gnat_index_type);
+ tree gnu_index_type = get_unpadded_type (gnat_index_type);
tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type);
tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type);
tree gnu_index_base_type = get_base_type (gnu_index_type);
@@ -2479,6 +2480,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr,
bool definition)
const int ndim = Number_Dimensions (gnat_entity);
tree gnu_base_type = gnu_type;
tree *gnu_index_types = XALLOCAVEC (tree, ndim);
+ bool *gnu_null_ranges = XALLOCAVEC (bool, ndim);
tree gnu_max_size = size_one_node;
bool need_index_type_struct = false;
int index;
@@ -2494,7 +2496,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr,
bool definition)
gnat_index = Next_Index (gnat_index),
gnat_base_index = Next_Index (gnat_base_index))
{
- tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
+ const Entity_Id gnat_index_type = Etype (gnat_index);
+ tree gnu_index_type = get_unpadded_type (gnat_index_type);
tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type);
tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type);
tree gnu_index_base_type = get_base_type (gnu_index_type);
@@ -2671,6 +2674,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree
gnu_expr, bool definition)
= create_index_type (gnu_min, gnu_high, gnu_index_type,
gnat_entity);
+ /* Record whether the range is known to be null at compile time
+to disambiguate it from too large ranges. */
+ const Entity_Id gnat_ui_type = Underlying_Type (gnat_index_type);
+ gnu_null_ranges[index]
+ = Is_Null_Range (Type_Low_Bound (gnat_ui_type),
+Type_High_Bound (gnat_ui_type));
+
/* We need special types for debugging information to point to
the index types if they have variable bounds, are not integer
types, are biased or are wider than sizetype. These are GNAT
@@ -2737,7 +2747,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree
gnu_expr, bool definition)
if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
set_nonaliased_component_on_array_type (gnu_type);
- /* Kludge to remove the TREE_OVERFLOW flag for the sake of LTO
+ /* Clear the TREE_OVERFLOW flag, if any, for null arrays. */
+ if (gnu_null_ranges[index])
+ {
+ TYPE_SIZE (gnu_type) = bitsize_zero_node;
+ TYPE_SIZE_UNIT (gnu_type) = size_zero_node;
+ }
+
+ /* Kludge to clear the TREE_OVERFLOW flag for the sake of LTO
on maximally-sized array types designed by access types. */
if (integer_zerop (TYPE_SIZE (gnu_type))
&& TREE_OVERFLOW (TYPE_SIZE (gnu_type))
--
2.40.0
[COMMITTED] ada: Add missing guards for degenerate storage models
From: Eric Botcazou
gcc/ada/
* gcc-interface/trans.cc (Attribute_to_gnu) : Check that
the storage model has Copy_From before instantiating loads for it.
: Likewise.
: Likewise.
(gnat_to_gnu) : Likewise.
: Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gcc-interface/trans.cc | 15 ++-
1 file changed, 10 insertions(+), 5 deletions(-)
diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc
index 57933ceb8a3..18f7e73d45d 100644
--- a/gcc/ada/gcc-interface/trans.cc
+++ b/gcc/ada/gcc-interface/trans.cc
@@ -1978,7 +1978,8 @@ Attribute_to_gnu (Node_Id gnat_node, tree
*gnu_result_type_p, int attribute)
if (TREE_CODE (gnu_prefix) != TYPE_DECL)
{
gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
- if (Present (gnat_smo))
+ if (Present (gnat_smo)
+ && Present (Storage_Model_Copy_From (gnat_smo)))
gnu_result = INSTANTIATE_LOAD_IN_EXPR (gnu_result, gnat_smo);
}
else if (CONTAINS_PLACEHOLDER_P (gnu_result))
@@ -2211,7 +2212,8 @@ Attribute_to_gnu (Node_Id gnat_node, tree
*gnu_result_type_p, int attribute)
handling. Note that these attributes could not have been used on
an unconstrained array type. */
gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
- if (Present (gnat_smo))
+ if (Present (gnat_smo)
+ && Present (Storage_Model_Copy_From (gnat_smo)))
gnu_result = INSTANTIATE_LOAD_IN_EXPR (gnu_result, gnat_smo);
/* Cache the expression we have just computed. Since we want to do it
@@ -2373,7 +2375,8 @@ Attribute_to_gnu (Node_Id gnat_node, tree
*gnu_result_type_p, int attribute)
/* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
handling. */
gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
- if (Present (gnat_smo))
+ if (Present (gnat_smo)
+ && Present (Storage_Model_Copy_From (gnat_smo)))
gnu_result = INSTANTIATE_LOAD_IN_EXPR (gnu_result, gnat_smo);
break;
}
@@ -6701,7 +6704,8 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_result
= build_binary_op (ARRAY_REF, NULL_TREE, gnu_result, gnu_expr);
- if (Present (gnat_smo))
+ if (Present (gnat_smo)
+ && Present (Storage_Model_Copy_From (gnat_smo)))
instantiate_load_in_array_ref (gnu_result, gnat_smo);
}
@@ -6746,7 +6750,8 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
gnu_array_object, gnu_expr);
- if (Present (gnat_smo))
+ if (Present (gnat_smo)
+ && Present (Storage_Model_Copy_From (gnat_smo)))
instantiate_load_in_array_ref (gnu_result, gnat_smo);
/* If storage model access is required on the RHS, build the load. */
--
2.40.0
[COMMITTED] ada: Remove explicit decoration of wrapper created in freezing
From: Piotr Trojanek We create wrapper functions associated with inherited functions with controlling results which are not overridden during freezing. We partly decorated them explicitly, even though they would be fully decorated later anyway. This early decoration didn't work as expected, because flag In_Private_Part that is read by Override_Dispatching_Operation it not set reliably while freezing (as explained in the comment of Is_Private_Declaration). In effect, we were getting a circularity between Alias and Overridden_Operation, which was causing GNATprove to loop infinitely. Apparently the cleanest fix is to not decorate the wrapper with an early call to Override_Dispatching_Operation. gcc/ada/ * exp_ch3.adb (Make_Controlling_Function_Wrappers): Remove early decoration. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch3.adb | 2 -- 1 file changed, 2 deletions(-) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index f8c99470dd7..91dcfa0f643 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -11140,8 +11140,6 @@ package body Exp_Ch3 is -- is a wrapper's body in order to get check suppression right. Set_Corresponding_Spec (Func_Body, Func_Id); - -Override_Dispatching_Operation (Tag_Typ, Subp, New_Op => Func_Id); end if; <> -- 2.40.0
[COMMITTED] ada: Simplify appending to a newly created list
From: Piotr Trojanek Code cleanup; semantics is unaffected. gcc/ada/ * exp_disp.adb (Make_Disp_Asynchronous_Select_Spec): Use a single call to New_List. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_disp.adb | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 494ead7c144..9381ceee60c 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -2755,7 +2755,7 @@ package body Exp_Disp is Def_Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uDisp_Asynchronous_Select); - Params : constant List_Id:= New_List; + Params : List_Id; begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); @@ -2770,7 +2770,7 @@ package body Exp_Disp is Set_Warnings_Off (B_Id); - Append_List_To (Params, New_List ( + Params := New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT), @@ -2795,7 +2795,7 @@ package body Exp_Disp is Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF), Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), - Out_Present => True))); + Out_Present => True)); return Make_Procedure_Specification (Loc, -- 2.40.0
[COMMITTED] ada: Fix expansion of aggregates with controlled components
From: Eric Botcazou The expansion is incorrect in the case where the initialization expression of a component is a conditional expression that has a function call as one of its dependent expressions, leading to a wrong order of initialization, adjustment and finalization. gcc/ada/ * exp_aggr.adb (Initialize_Component): Perform immediate expansion of the initialization expression if it is a conditional expression and the component type is controlled. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 102 +-- 1 file changed, 99 insertions(+), 3 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index e5b2cedb954..8c6c9f97429 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -8444,8 +8444,104 @@ package body Exp_Aggr is Comp : Node_Id; Comp_Typ : Entity_Id; Init_Expr : Node_Id; - Stmts : List_Id) is + Stmts : List_Id) + is + Init_Expr_Q : constant Node_Id:= Unqualify (Init_Expr); + Loc : constant Source_Ptr := Sloc (N); + begin + -- If the initialization expression of a component with controlled type + -- is a conditional expression that has a function call as one of its + -- dependent expressions, then we need to expand it immediately, so as + -- to trigger the special processing for function calls with controlled + -- type below and avoid a wrong order of initialization, adjustment and + -- finalization in the context of aggregates. For the sake of uniformity + -- we perform this expansion for all conditional expressions. + + if Nkind (Init_Expr_Q) = N_If_Expression +and then Present (Comp_Typ) +and then Needs_Finalization (Comp_Typ) + then + declare +Cond : constant Node_Id := First (Expressions (Init_Expr_Q)); +Thenx : constant Node_Id := Next (Cond); +Elsex : constant Node_Id := Next (Thenx); +Then_Stmts : constant List_Id := New_List; +Else_Stmts : constant List_Id := New_List; + +If_Stmt : Node_Id; + + begin +Initialize_Component + (N => N, + Comp => Comp, + Comp_Typ => Comp_Typ, + Init_Expr => Thenx, + Stmts => Then_Stmts); + +Initialize_Component + (N => N, + Comp => Comp, + Comp_Typ => Comp_Typ, + Init_Expr => Elsex, + Stmts => Else_Stmts); + +If_Stmt := + Make_Implicit_If_Statement (N, +Condition => Relocate_Node (Cond), +Then_Statements => Then_Stmts, +Else_Statements => Else_Stmts); + +Set_From_Conditional_Expression (If_Stmt); +Append_To (Stmts, If_Stmt); + end; + + elsif Nkind (Init_Expr_Q) = N_Case_Expression +and then Present (Comp_Typ) +and then Needs_Finalization (Comp_Typ) + then + declare +Alt : Node_Id; +Alt_Stmts : List_Id; +Case_Stmt : Node_Id; + + begin +Case_Stmt := + Make_Case_Statement (Loc, + Expression => + Relocate_Node (Expression (Init_Expr_Q)), + Alternatives => New_List); + +Alt := First (Alternatives (Init_Expr_Q)); +while Present (Alt) loop + declare + Alt_Expr : constant Node_Id:= Expression (Alt); + Alt_Loc : constant Source_Ptr := Sloc (Alt_Expr); + + begin + Alt_Stmts := New_List; + + Initialize_Component +(N => N, + Comp => Comp, + Comp_Typ => Comp_Typ, + Init_Expr => Alt_Expr, + Stmts => Alt_Stmts); + + Append_To +(Alternatives (Case_Stmt), + Make_Case_Statement_Alternative (Alt_Loc, + Discrete_Choices => Discrete_Choices (Alt), + Statements => Alt_Stmts)); + end; + + Next (Alt); +end loop; + +Set_From_Conditional_Expression (Case_Stmt); +Append_To (Stmts, Case_Stmt); + end; + -- Handle an initialization expression of a controlled type in -- case it denotes a function call. In general such a scenario -- will produce a transient scope, but this will lead to wrong @@ -8477,9 +8573,9 @@ package body Exp_Aggr is --Adjust (Comp); --Finalize (Res); - if Present (Comp_Typ) + elsif Nkind (Init_Expr_Q) /= N_Aggregate +and then Present (Comp_Typ) and then Need
[COMMITTED] ada: Factor out tag assignments from type in expander
From: Eric Botcazou They are performed in a few different places during expansion. gcc/ada/ * exp_util.ads (Make_Tag_Assignment_From_Type): Declare. * exp_util.adb (Make_Tag_Assignment_From_Type): New function. * exp_aggr.adb (Build_Record_Aggr_Code): Call the above function. (Initialize_Simple_Component): Likewise. * exp_ch3.adb (Build_Record_Init_Proc.Build_Assignment): Likewise. (Build_Record_Init_Proc.Build_Init_Procedure ): Likewise. (Make_Tag_Assignment): Likewise. Rename local variable and call Unqualify to go through qualified expressions. * exp_ch4.adb (Expand_Allocator_Expression): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 47 - gcc/ada/exp_ch3.adb | 72 +--- gcc/ada/exp_ch4.adb | 28 ++--- gcc/ada/exp_util.adb | 27 + gcc/ada/exp_util.ads | 7 + 5 files changed, 57 insertions(+), 124 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 8c6c9f97429..c145d79f482 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -3095,22 +3095,9 @@ package body Exp_Aggr is if Tagged_Type_Expansion then Instr := -Make_OK_Assignment_Statement (Loc, - Name => -Make_Selected_Component (Loc, - Prefix=> New_Copy_Tree (Target), - Selector_Name => -New_Occurrence_Of - (First_Tag_Component (Base_Type (Typ)), Loc)), - - Expression => -Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of -(Node (First_Elmt - (Access_Disp_Table (Base_Type (Typ, - Loc))); +Make_Tag_Assignment_From_Type + (Loc, New_Copy_Tree (Target), Base_Type (Typ)); - Set_Assignment_OK (Name (Instr)); Append_To (Assign, Instr); -- Ada 2005 (AI-251): If tagged type has progenitors we must @@ -3629,19 +3616,8 @@ package body Exp_Aggr is elsif Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then Instr := - Make_OK_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Base_Type (Typ)), Loc)), - - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of - (Node (First_Elmt (Access_Disp_Table (Base_Type (Typ, -Loc))); + Make_Tag_Assignment_From_Type + (Loc, New_Copy_Tree (Target), Base_Type (Typ)); Append_To (L, Instr); @@ -8761,19 +8737,8 @@ package body Exp_Aggr is and then Is_Tagged_Type (Comp_Typ) then Append_To (Blk_Stmts, - Make_OK_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix=> New_Copy_Tree (Comp), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Full_Typ), Loc)), - - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of - (Node (First_Elmt (Access_Disp_Table (Full_Typ))), -Loc; + Make_Tag_Assignment_From_Type + (Loc, New_Copy_Tree (Comp), Full_Typ)); end if; -- Adjust the component. In the case of an array aggregate, controlled diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 91dcfa0f643..fbedc16ddd0 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2150,21 +2150,10 @@ package body Exp_Ch3 is and then Nkind (Exp_Q) /= N_Raise_Expression then Append_To (Res, - Make_Assignment_Statement (Default_Loc, -Name => - Make_Selected_Component (Default_Loc, -Prefix=> - New_Copy_Tree (Lhs, New_Scope => Proc_Id), -Selector_Name => - New_Occurrence_Of -(First_Tag_Component (Typ), Default_Loc)), - -Expression => - Unchecked_Convert_To (RTE (RE_Tag), -New_Occurrence_Of - (Node (First_Elmt (Access_Disp_Table (Underlying_Type - (Typ, - Default_Loc; + Make_Tag_Assignment_From_T
[COMMITTED] ada: Tune style in detection of writable function actuals
From: Piotr Trojanek
Cleanup; semantics is unaffected.
gcc/ada/
* sem_util.adb (Check_Function_Writable_Actuals): Tune style; use
subtype name to detect membership test nodes.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_util.adb | 10 ++
1 file changed, 6 insertions(+), 4 deletions(-)
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index a75ebf5d7b1..237bbd3987c 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -2899,6 +2899,10 @@ package body Sem_Util is
function Get_Record_Part (N : Node_Id) return Node_Id;
-- Return the record part of this record type definition
+ -
+ -- Get_Record_Part --
+ -
+
function Get_Record_Part (N : Node_Id) return Node_Id is
Type_Def : constant Node_Id := Type_Definition (N);
begin
@@ -3293,9 +3297,7 @@ package body Sem_Util is
& "in unspecified order",
Node (Elmt_2));
-when N_In
- | N_Not_In
-=>
+when N_Membership_Test =>
Error_Msg_N
("value may be affected by call in other "
& "alternative because they are evaluated "
@@ -3307,7 +3309,7 @@ package body Sem_Util is
("value of actual may be affected by call in "
& "other actual because they are evaluated "
& "in unspecified order",
- Node (Elmt_2));
+ Node (Elmt_2));
end case;
end if;
--
2.40.0
[COMMITTED] ada: Factor common processing in expansion of aggregates
From: Eric Botcazou The final processing at the component level of array aggregates and record aggregates is very similar, so this factors out the common processing into three new library-level subprograms. There should be no functional changes, but the expanded code may be changed in the case of controlled components of array aggregates not covered by a multiple choice: the previous expansion used to place new declarations prior to the aggregate in this case and that is no longer the case, i.e. they are always placed right before the initialization of the component (as was done for all controlled components of record aggregates and controlled components of array aggregates covered by a multiple choice). gcc/ada/ * exp_aggr.adb (Initialize_Component): New procedure factored out from the processing of array and record aggregates. (Initialize_Controlled_Component): Likewise. (Initialize_Simple_Component): Likewise. (Build_Array_Aggr_Code.Gen_Assign): Remove In_Loop parameter. Call Initialize_Component to initialize the component. (Initialize_Array_Component): Delete. (Initialize_Ctrl_Array_Component): Likewise. (Build_Array_Aggr_Code): Adjust calls to Gen_Assign. (Build_Record_Aggr_Code): Call Initialize_Simple_Component or Initialize_Component to initialize the component. (Initialize_Ctrl_Record_Component): Delete. (Initialize_Record_Component): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 1000 +++--- 1 file changed, 360 insertions(+), 640 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 270d3bb8d66..e5b2cedb954 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -105,6 +105,36 @@ package body Exp_Aggr is -- N is an aggregate (record or array). Checks the presence of default -- initialization (<>) in any component (Ada 2005: AI-287). + procedure Initialize_Component + (N : Node_Id; + Comp : Node_Id; + Comp_Typ : Entity_Id; + Init_Expr : Node_Id; + Stmts : List_Id); + -- Perform the initialization of component Comp with expected type Comp_Typ + -- of aggregate N. Init_Expr denotes the initialization expression of the + -- component. All generated code is added to Stmts. + + procedure Initialize_Controlled_Component + (N : Node_Id; + Comp : Node_Id; + Comp_Typ : Entity_Id; + Init_Expr : Node_Id; + Stmts : List_Id); + -- Perform the initialization of controlled component Comp with expected + -- type Comp_Typ of aggregate N. Init_Expr denotes the initialization + -- expression of the component. All generated code is added to Stmts. + + procedure Initialize_Simple_Component + (N : Node_Id; + Comp : Node_Id; + Comp_Typ : Node_Id; + Init_Expr : Node_Id; + Stmts : List_Id); +-- Perform the initialization of simple component Comp with expected +-- type Comp_Typ of aggregate N. Init_Expr denotes the initialization +-- expression of the component. All generated code is added to Stmts. + function Is_CCG_Supported_Aggregate (N : Node_Id) return Boolean; -- Return True if aggregate N is located in a context supported by the -- CCG backend; False otherwise. @@ -1081,16 +,14 @@ package body Exp_Aggr is function Gen_Assign (Ind : Node_Id; - Expr: Node_Id; - In_Loop : Boolean := False) return List_Id; + Expr: Node_Id) return List_Id; -- Ind must be a side-effect-free expression. If the input aggregate N -- to Build_Loop contains no subaggregates, then this function returns -- the assignment statement: -- -- Into (Indexes, Ind) := Expr; -- - -- Otherwise we call Build_Code recursively. Flag In_Loop should be set - -- when the assignment appears within a generated loop. + -- Otherwise we call Build_Code recursively. -- -- Ada 2005 (AI-287): In case of default initialized component, Expr -- is empty and we generate a call to the corresponding IP subprogram. @@ -1310,35 +1338,13 @@ package body Exp_Aggr is function Gen_Assign (Ind : Node_Id; - Expr: Node_Id; - In_Loop : Boolean := False) return List_Id + Expr: Node_Id) return List_Id is function Add_Loop_Actions (Lis : List_Id) return List_Id; -- Collect insert_actions generated in the construction of a loop, -- and prepend them to the sequence of assignments to complete the -- eventual body of the loop. - procedure Initialize_Array_Component - (Arr_Comp : Node_Id; -Comp_Typ : Node_Id; -Init_Expr : Node_Id; -Stmts : List_Id); - -- Perform the in
[COMMITTED] ada: Add No_Elaboration_Code_All pragma to System.Storage_Elements
From: Daniel King Allows System.Storage_Elements to be used in units that have the No_Elaboration_Code_All restriction. gcc/ada/ * libgnat/s-stoele.ads: Add No_Elaboration_Code_All pragma. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/s-stoele.ads | 3 +++ 1 file changed, 3 insertions(+) diff --git a/gcc/ada/libgnat/s-stoele.ads b/gcc/ada/libgnat/s-stoele.ads index 3262d0329c3..7de150dab59 100644 --- a/gcc/ada/libgnat/s-stoele.ads +++ b/gcc/ada/libgnat/s-stoele.ads @@ -43,6 +43,9 @@ package System.Storage_Elements is -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada 2005, -- this is Pure in any case (AI-362). + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + pragma Annotate (GNATprove, Always_Return, Storage_Elements); type Storage_Offset is range -Memory_Size / 2 .. Memory_Size / 2 - 1; -- 2.40.0
[COMMITTED] ada: Cleanup expansion of locally handled exception handlers
From: Piotr Trojanek Code cleanup related to handling exceptions in GNATprove; semantics is unaffected. gcc/ada/ * exp_ch11.ads (Find_Local_Handler): Fix typo in comment. * exp_ch11.adb (Find_Local_Handler): Remove redundant check for the Exception_Handler list being present; use membership test to eliminate local object LCN; fold nested IF statements. Remove useless ELSIF condition. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch11.adb | 124 +++ gcc/ada/exp_ch11.ads | 2 +- 2 files changed, 55 insertions(+), 71 deletions(-) diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 753412eab16..da02eb9bfb2 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1803,95 +1803,79 @@ package body Exp_Ch11 is -- Test for handled sequence of statements with at least one -- exception handler which might be the one we are looking for. - elsif Nkind (P) = N_Handled_Sequence_Of_Statements - and then Present (Exception_Handlers (P)) - then --- Before we proceed we need to check if the node N is covered --- by the statement part of P rather than one of its exception --- handlers (an exception handler obviously does not cover its --- own statements). - --- This test is more delicate than might be thought. It is not --- just a matter of checking the Statements (P), because the node --- might be waiting to be wrapped in a transient scope, in which --- case it will end up in the block statements, even though it --- is not there now. - -if Is_List_Member (N) then - declare - LCN : constant List_Id := List_Containing (N); + -- We need to check if the node N is covered by the statement part of + -- P rather than one of its exception handlers (an exception handler + -- obviously does not cover its own statements). - begin - if LCN = Statements (P) - or else - LCN = SSE.Actions_To_Be_Wrapped (Before) - or else - LCN = SSE.Actions_To_Be_Wrapped (After) - or else - LCN = SSE.Actions_To_Be_Wrapped (Cleanup) - then - -- Loop through exception handlers + -- This test is more delicate than might be thought. It is not just + -- a matter of checking the Statements (P), because the node might be + -- waiting to be wrapped in a transient scope, in which case it will + -- end up in the block statements, even though it is not there now. - H := First (Exception_Handlers (P)); - while Present (H) loop + elsif Nkind (P) = N_Handled_Sequence_Of_Statements + and then Is_List_Member (N) + and then List_Containing (N) in Statements (P) + | SSE.Actions_To_Be_Wrapped (Before) + | SSE.Actions_To_Be_Wrapped (After) + | SSE.Actions_To_Be_Wrapped (Cleanup) + then +-- Loop through exception handlers --- Guard against other constructs appearing in the --- list of exception handlers. +H := First (Exception_Handlers (P)); +while Present (H) loop -if Nkind (H) = N_Exception_Handler then + -- Guard against other constructs appearing in the list of + -- exception handlers. - -- Loop through choices in one handler + if Nkind (H) = N_Exception_Handler then - C := First (Exception_Choices (H)); - while Present (C) loop + -- Loop through choices in one handler - -- Deal with others case + C := First (Exception_Choices (H)); + while Present (C) loop - if Nkind (C) = N_Others_Choice then + -- Deal with others case - -- Matching others handler, but we need - -- to ensure there is no choice parameter. - -- If there is, then we don't have a local - -- handler after all (since we do not allow - -- choice parameters for local handlers). + if Nkind (C) = N_Others_Choice then - if No (Choice_Parameter (H)) then -return H; - else -
[COMMITTED] ada: Small housekeeping work in expansion of extension aggregates
From: Eric Botcazou This avoids repeatedly calling Unqualify on the same node, removes a dead call to Generate_Finalization_Actions, a redundant setting of Assignment_OK and reuses a local variable more consistently. No functional changes. gcc/ada/ * exp_aggr.adb (Build_Record_Aggr_Code): Add new variable Ancestor_Q to store the result of Unqualify on Ancestor. Remove the dead call to Generate_Finalization_Actions in the case of another aggregate as ancestor part. Remove the redundant setting of Assignment_OK. Use Init_Typ in lieu of Etype (Ancestor) more consistently. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 36 +++- 1 file changed, 15 insertions(+), 21 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 15230571123..dcbf2c4981d 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -2907,12 +2907,14 @@ package body Exp_Aggr is if Nkind (N) = N_Extension_Aggregate then declare -Ancestor : constant Node_Id := Ancestor_Part (N); +Ancestor : constant Node_Id := Ancestor_Part (N); +Ancestor_Q : constant Node_Id := Unqualify (Ancestor); + Adj_Call : Node_Id; Assign : List_Id; begin --- If the ancestor part is a subtype mark "T", we generate +-- If the ancestor part is a subtype mark T, we generate -- init-proc (T (tmp)); if T is constrained and -- init-proc (S (tmp)); where S applies an appropriate @@ -3036,28 +3038,22 @@ package body Exp_Aggr is -- qualified). elsif Is_Limited_Type (Etype (Ancestor)) - and then Nkind (Unqualify (Ancestor)) in - N_Aggregate | N_Extension_Aggregate + and then Nkind (Ancestor_Q) in N_Aggregate + | N_Extension_Aggregate then - -- Set up finalization data for enclosing record, because - -- controlled subcomponents of the ancestor part will be - -- attached to it. - - Generate_Finalization_Actions; - Append_List_To (L, Build_Record_Aggr_Code -(N => Unqualify (Ancestor), - Typ => Etype (Unqualify (Ancestor)), +(N => Ancestor_Q, + Typ => Etype (Ancestor_Q), Lhs => Target)); --- If the ancestor part is an expression "E", we generate +-- If the ancestor part is an expression E of type T, we generate -- T (tmp) := E; -- In Ada 2005, this includes the case of a (possibly qualified) --- limited function call. The assignment will turn into a --- build-in-place function call (for further details, see +-- limited function call. The assignment will later be turned into +-- a build-in-place function call (for further details, see -- Make_Build_In_Place_Call_In_Assignment). else @@ -3067,15 +3063,13 @@ package body Exp_Aggr is -- If the ancestor part is an aggregate, force its full -- expansion, which was delayed. - if Nkind (Unqualify (Ancestor)) in -N_Aggregate | N_Extension_Aggregate + if Nkind (Ancestor_Q) in N_Aggregate | N_Extension_Aggregate then Set_Analyzed (Ancestor, False); Set_Analyzed (Expression (Ancestor), False); end if; Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); - Set_Assignment_OK (Ref); -- Make the assignment without usual controlled actions, since -- we only want to Adjust afterwards, but not to Finalize @@ -3112,14 +3106,14 @@ package body Exp_Aggr is -- Call Adjust manually - if Needs_Finalization (Etype (Ancestor)) - and then not Is_Limited_Type (Etype (Ancestor)) + if Needs_Finalization (Init_Typ) + and then not Is_Limited_Type (Init_Typ) and then not Is_Build_In_Place_Function_Call (Ancestor) then Adj_Call := Make_Adjust_Call (Obj_Ref => New_Copy_Tree (Ref), - Typ => Etype (Ancestor)); + Typ => Init_Typ); -- Guard against a missing [Deep_]Adjust when the ancestor -- type was not properly frozen. -- 2.40.0
[COMMITTED] ada: Fix wrong expansion of limited extension aggregate
From: Eric Botcazou This happens when the ancestor part is itself an aggregate: in this case, the tag of the extension aggregate is wrongly set to that of the ancestor. gcc/ada/ * exp_aggr.adb (Build_Record_Aggr_Code): In the case of an extension aggregate of a limited type whose ancestor part is an aggregate, do not skip the final code assigning the tag of the extension. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 2 -- 1 file changed, 2 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index c145d79f482..15230571123 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -3039,8 +3039,6 @@ package body Exp_Aggr is and then Nkind (Unqualify (Ancestor)) in N_Aggregate | N_Extension_Aggregate then - Ancestor_Is_Expression := True; - -- Set up finalization data for enclosing record, because -- controlled subcomponents of the ancestor part will be -- attached to it. -- 2.40.0
[COMMITTED] ada: Cleanup finding of locally handled exception handlers
From: Piotr Trojanek Code cleanup related to handling exceptions in GNATprove; semantics is unaffected. gcc/ada/ * exp_ch11.adb (Find_Local_Handler): Replace guard against other constructs appearing in the list of exception handlers with iteration using First_Non_Pragma/Next_Non_Pragma. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch11.adb | 68 +--- 1 file changed, 33 insertions(+), 35 deletions(-) diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index da02eb9bfb2..db85c7efa6e 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1819,62 +1819,60 @@ package body Exp_Ch11 is | SSE.Actions_To_Be_Wrapped (After) | SSE.Actions_To_Be_Wrapped (Cleanup) then --- Loop through exception handlers +-- Loop through exception handlers and guard against pragmas +-- appearing among them. -H := First (Exception_Handlers (P)); +H := First_Non_Pragma (Exception_Handlers (P)); while Present (H) loop -- Guard against other constructs appearing in the list of -- exception handlers. - if Nkind (H) = N_Exception_Handler then + -- Loop through choices in one handler - -- Loop through choices in one handler + C := First (Exception_Choices (H)); + while Present (C) loop - C := First (Exception_Choices (H)); - while Present (C) loop + -- Deal with others case - -- Deal with others case + if Nkind (C) = N_Others_Choice then - if Nkind (C) = N_Others_Choice then + -- Matching others handler, but we need to ensure there + -- is no choice parameter. If there is, then we don't + -- have a local handler after all (since we do not allow + -- choice parameters for local handlers). --- Matching others handler, but we need to ensure --- there is no choice parameter. If there is, then we --- don't have a local handler after all (since we do --- not allow choice parameters for local handlers). - -if No (Choice_Parameter (H)) then - return H; -else - return Empty; -end if; + if No (Choice_Parameter (H)) then +return H; + else +return Empty; + end if; - -- If not others must be entity name + -- If not others must be entity name - else -pragma Assert (Is_Entity_Name (C)); -pragma Assert (Present (Entity (C))); + else + pragma Assert (Is_Entity_Name (C)); + pragma Assert (Present (Entity (C))); --- Get exception being handled, dealing with renaming + -- Get exception being handled, dealing with renaming -EHandle := Get_Renamed_Entity (Entity (C)); + EHandle := Get_Renamed_Entity (Entity (C)); --- If match, then check choice parameter + -- If match, then check choice parameter -if ERaise = EHandle then - if No (Choice_Parameter (H)) then - return H; - else - return Empty; - end if; + if ERaise = EHandle then +if No (Choice_Parameter (H)) then + return H; +else + return Empty; end if; end if; + end if; - Next (C); - end loop; - end if; + Next (C); + end loop; - Next (H); + Next_Non_Pragma (H); end loop; end if; -- 2.40.0
[COMMITTED] ada: Remove obsolete code in Analyze_Assignment
From: Eric Botcazou This code was dealing with build-in-place calls for nonlimited types, but they no longer exist since Is_Build_In_Place_Result_Type => Is_Limited_View. gcc/ada/ * sem_ch5.adb (Analyze_Assignment): Turn Rhs into a constant and remove calls to the following subprograms. (Transform_BIP_Assignment): Delete. (Should_Transform_BIP_Assignment): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_ch5.adb | 156 +--- 1 file changed, 1 insertion(+), 155 deletions(-) diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 99a57573a87..f9174869a26 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -113,7 +113,7 @@ package body Sem_Ch5 is procedure Analyze_Assignment (N : Node_Id) is Lhs : constant Node_Id := Name (N); - Rhs : Node_Id := Expression (N); + Rhs : constant Node_Id := Expression (N); procedure Diagnose_Non_Variable_Lhs (N : Node_Id); -- N is the node for the left hand side of an assignment, and it is not @@ -137,27 +137,6 @@ package body Sem_Ch5 is -- nominal subtype. This procedure is used to deal with cases where the -- nominal subtype must be replaced by the actual subtype. - procedure Transform_BIP_Assignment (Typ : Entity_Id); - function Should_Transform_BIP_Assignment -(Typ : Entity_Id) return Boolean; - -- If the right-hand side of an assignment statement is a build-in-place - -- call we cannot build in place, so we insert a temp initialized with - -- the call, and transform the assignment statement to copy the temp. - -- Transform_BIP_Assignment does the transformation, and - -- Should_Transform_BIP_Assignment determines whether we should. - -- The same goes for qualified expressions and conversions whose - -- operand is such a call. - -- - -- This is only for nonlimited types; assignment statements are illegal - -- for limited types, but are generated internally for aggregates and - -- init procs. These limited-type are not really assignment statements - -- -- conceptually, they are initializations, so should not be - -- transformed. - -- - -- Similarly, for nonlimited types, aggregates and init procs generate - -- assignment statements that are really initializations. These are - -- marked No_Ctrl_Actions. - function Within_Function return Boolean; -- Determine whether the current scope is a function or appears within -- one. @@ -354,87 +333,6 @@ package body Sem_Ch5 is end if; end Set_Assignment_Type; - - - -- Should_Transform_BIP_Assignment -- - - - - function Should_Transform_BIP_Assignment -(Typ : Entity_Id) return Boolean - is - begin - if Expander_Active - and then not Is_Limited_View (Typ) - and then Is_Build_In_Place_Result_Type (Typ) - and then not No_Ctrl_Actions (N) - then --- This function is called early, before name resolution is --- complete, so we have to deal with things that might turn into --- function calls later. N_Function_Call and N_Op nodes are the --- obvious case. An N_Identifier or N_Expanded_Name is a --- parameterless function call if it denotes a function. --- Finally, an attribute reference can be a function call. - -declare - Unqual_Rhs : constant Node_Id := Unqual_Conv (Rhs); -begin - case Nkind (Unqual_Rhs) is - when N_Function_Call - | N_Op - => - return True; - - when N_Expanded_Name - | N_Identifier - => - return - Ekind (Entity (Unqual_Rhs)) in E_Function | E_Operator; - - -- T'Input will turn into a call whose result type is T - - when N_Attribute_Reference => - return Attribute_Name (Unqual_Rhs) = Name_Input; - - when others => - return False; - end case; -end; - else -return False; - end if; - end Should_Transform_BIP_Assignment; - - -- - -- Transform_BIP_Assignment -- - -- - - procedure Transform_BIP_Assignment (Typ : Entity_Id) is - - -- Tranform "X : [constant] T := F (...);" into: - -- - -- Temp : constant T := F (...); - -- X := Temp; - - Loc : constant Source_Ptr := Sloc (N); - Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', Rhs); - Obj_De
[COMMITTED] ada: Fix internal error on imported function with post-condition
From: Eric Botcazou The problem, which is also present for an expression function, is that the function is invoked in the initializing expression of a variable declared in the same declarative part as the function, which causes the freezing of its artificial body before the post-condition is analyzed on its spec. gcc/ada/ * contracts.adb (Analyze_Entry_Or_Subprogram_Body_Contract): For a subprogram body that has no contracts and does not come from source, make sure that contracts on its corresponding spec are analyzed, if any, before expanding them. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/contracts.adb | 16 1 file changed, 16 insertions(+) diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 7625abf9554..ae9e07ffc16 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -598,6 +598,22 @@ package body Contracts is else Set_Analyzed (Items); end if; + + -- When this is a subprogram body not coming from source, for example an + -- expression function, it does not cause freezing of previous contracts + -- (see Analyze_Subprogram_Body_Helper), in particular not of those on + -- its spec if it exists. In this case make sure they have been properly + -- analyzed before being expanded below, as we may be invoked during the + -- freezing of the subprogram in the middle of its enclosing declarative + -- part because the declarative part contains e.g. the declaration of a + -- variable initialized by means of a call to the subprogram. + + elsif Nkind (Body_Decl) = N_Subprogram_Body +and then not Comes_From_Source (Original_Node (Body_Decl)) +and then Present (Corresponding_Spec (Body_Decl)) +and then Present (Contract (Corresponding_Spec (Body_Decl))) + then + Analyze_Entry_Or_Subprogram_Contract (Corresponding_Spec (Body_Decl)); end if; -- Due to the timing of contract analysis, delayed pragmas may be -- 2.40.0
[COMMITTED] ada: Remove wrong comment about expansion of exceptions for GNATprove
From: Piotr Trojanek Code cleanup related to handling exceptions in GNATprove. gcc/ada/ * exp_ch11.adb (Expand_N_Raise_Statement): Expansion of raise statements never happens in GNATprove mode. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch11.adb | 8 +++- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index db85c7efa6e..53f0753cdce 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1592,10 +1592,8 @@ package body Exp_Ch11 is else -- Bypass expansion to a run-time call when back-end exception - -- handling is active, unless the target is CodePeer or GNATprove. - -- In CodePeer, raising an exception is treated as an error, while in - -- GNATprove all code with exceptions falls outside the subset of - -- code which can be formally analyzed. + -- handling is active, unless the target is CodePeer, where + -- raising an exception is treated as an error. if not CodePeer_Mode then return; @@ -1604,7 +1602,7 @@ package body Exp_Ch11 is -- Find innermost enclosing exception handler (there must be one, -- since the semantics has already verified that this raise statement -- is valid, and a raise with no arguments is only permitted in the - -- context of an exception handler. + -- context of an exception handler). Ehand := Parent (N); while Nkind (Ehand) /= N_Exception_Handler loop -- 2.40.0
[COMMITTED] ada: Remove unreferenced routine Is_Inherited_Operation_For_Type
From: Piotr Trojanek Remove routine that is no referenced after deconstructing of restriction SPARK_05. gcc/ada/ * sem_util.ads (Is_Inherited_Operation_For_Type): Remove spec. * sem_util.adb (Is_Inherited_Operation_For_Type): Remove body. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_util.adb | 15 --- gcc/ada/sem_util.ads | 6 -- 2 files changed, 21 deletions(-) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 237bbd3987c..c736bc34bb1 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -17582,21 +17582,6 @@ package body Sem_Util is and then Is_Derived_Type (Etype (E))); end Is_Inherited_Operation; - - - -- Is_Inherited_Operation_For_Type -- - - - - function Is_Inherited_Operation_For_Type - (E : Entity_Id; - Typ : Entity_Id) return Boolean - is - begin - -- Check that the operation has been created by the type declaration - - return Is_Inherited_Operation (E) -and then Defining_Identifier (Parent (E)) = Typ; - end Is_Inherited_Operation_For_Type; - -- -- Is_Inlinable_Expression_Function -- -- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 2a2dbdc2bdd..539ebebafcb 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2088,12 +2088,6 @@ package Sem_Util is -- E is a subprogram. Return True is E is an implicit operation inherited -- by a derived type declaration. - function Is_Inherited_Operation_For_Type - (E : Entity_Id; - Typ : Entity_Id) return Boolean; - -- E is a subprogram. Return True is E is an implicit operation inherited - -- by the derived type declaration for type Typ. - function Is_Inlinable_Expression_Function (Subp : Entity_Id) return Boolean; -- Return True if Subp is an expression function that fulfills all the -- following requirements for inlining: -- 2.40.0
[COMMITTED] ada: Fix exception raised on invalid contract in generic package
From: Eric Botcazou This lets the compiler give a proper error message instead. gcc/ada/ * contracts.adb (Contract_Error): New exception. (Add_Contract_Item): Raise Contract_Error instead of Program_Error. (Add_Generic_Contract_Pragma): Deal with Contract_Error. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/contracts.adb | 31 +-- 1 file changed, 21 insertions(+), 10 deletions(-) diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index ae9e07ffc16..19073d1e4d8 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -62,6 +62,11 @@ with Warnsw; use Warnsw; package body Contracts is + Contract_Error : exception; + -- This exception is raised by Add_Contract_Item when it is invoked on an + -- invalid pragma. Note that clients of the package must filter them out + -- before invoking Add_Contract_Item, so it should not escape the package. + procedure Analyze_Package_Instantiation_Contract (Inst_Id : Entity_Id); -- Analyze all delayed pragmas chained on the contract of package -- instantiation Inst_Id as if they appear at the end of a declarative @@ -198,7 +203,7 @@ package body Contracts is -- The pragma is not a proper contract item else -raise Program_Error; +raise Contract_Error; end if; -- Entry bodies, the applicable pragmas are: @@ -216,7 +221,7 @@ package body Contracts is -- The pragma is not a proper contract item else -raise Program_Error; +raise Contract_Error; end if; -- Entry or subprogram declarations, the applicable pragmas are: @@ -268,7 +273,7 @@ package body Contracts is -- The pragma is not a proper contract item else -raise Program_Error; +raise Contract_Error; end if; -- Packages or instantiations, the applicable pragmas are: @@ -292,7 +297,7 @@ package body Contracts is -- The pragma is not a proper contract item else -raise Program_Error; +raise Contract_Error; end if; -- Package bodies, the applicable pragmas are: @@ -305,7 +310,7 @@ package body Contracts is -- The pragma is not a proper contract item else -raise Program_Error; +raise Contract_Error; end if; -- The four volatility refinement pragmas are ok for all types. @@ -343,7 +348,7 @@ package body Contracts is -- The pragma is not a proper contract item - raise Program_Error; + raise Contract_Error; end if; end; @@ -367,7 +372,7 @@ package body Contracts is -- The pragma is not a proper contract item else -raise Program_Error; +raise Contract_Error; end if; -- Task bodies, the applicable pragmas are: @@ -381,7 +386,7 @@ package body Contracts is -- The pragma is not a proper contract item else -raise Program_Error; +raise Contract_Error; end if; -- Task units, the applicable pragmas are: @@ -416,11 +421,11 @@ package body Contracts is -- The pragma is not a proper contract item else -raise Program_Error; +raise Contract_Error; end if; else - raise Program_Error; + raise Contract_Error; end if; end Add_Contract_Item; @@ -2225,6 +2230,12 @@ package body Contracts is else Add_Contract_Item (Prag, Templ_Id); end if; + + exception + -- We do not stop the compilation at this point in the case of an + -- invalid pragma because it will be properly diagnosed afterward. + + when Contract_Error => null; end Add_Generic_Contract_Pragma; -- Local variables -- 2.40.0
[COMMITTED] ada: Add missing ss_mark/ss_release in quantified expressions
From: Bob Duff If a quantified expression says "for all ... of F(...)" where F(...) is a function call that returns on the secondary stack, we need to clean up the secondary stack. This patch adds the required ss_mark/ss_release in that case. gcc/ada/ * exp_ch4.adb (Expand_N_Quantified_Expression): Detect the secondary-stack case, and find the innermost scope where we should mark/release, and Set_Uses_Sec_Stack on that. Skip intermediate blocks and loops that are part of expansion. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch4.adb | 26 ++ 1 file changed, 26 insertions(+) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index fdaeb50512f..7b6e997e3e7 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -6,6 +6,32 @@ package body Exp_Ch4 is Freeze_Before (P, Etype (Var)); end; + -- For an expression of the form "for all/some X of F(...) => ...", + -- where F(...) is a function call that returns on the secondary stack, + -- we need to mark an enclosing scope as Uses_Sec_Stack. We must do + -- this before expansion, which can obscure the tree. Note that we + -- might be inside another quantified expression. Skip blocks and + -- loops that were generated by expansion. + + if Present (Iterator_Specification (N)) +and then Nkind (Name (Iterator_Specification (N))) = N_Function_Call +and then Needs_Secondary_Stack + (Etype (Name (Iterator_Specification (N + then + declare +Source_Scope : Entity_Id := Current_Scope; + begin +while Ekind (Source_Scope) in E_Block | E_Loop + and then not Comes_From_Source (Source_Scope) +loop + Source_Scope := Scope (Source_Scope); +end loop; + +Set_Uses_Sec_Stack (Source_Scope); +Check_Restriction (No_Secondary_Stack, N); + end; + end if; + -- Create the declaration of the flag which tracks the status of the -- quantified expression. Generate: -- 2.40.0
[COMMITTED] ada: Use ghost predicate in standard library
From: Yannick Moy In preparation for attribute Initialized to become ghost, use aspect Ghost_Predicate instead of Predicate in unit Ada.Strings.Superbounded of the standard library. gcc/ada/ * libgnat/a-strsup.ads: Change predicate aspect. * sem_ch13.adb (Add_Predicate): Fix for first predicate. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/libgnat/a-strsup.ads | 2 +- gcc/ada/sem_ch13.adb | 6 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/gcc/ada/libgnat/a-strsup.ads b/gcc/ada/libgnat/a-strsup.ads index 7a8a2bac996..2e0cd98f8d4 100644 --- a/gcc/ada/libgnat/a-strsup.ads +++ b/gcc/ada/libgnat/a-strsup.ads @@ -69,7 +69,7 @@ package Ada.Strings.Superbounded with SPARK_Mode is -- Leaving it out is more efficient. end record with - Predicate => + Ghost_Predicate => Current_Length <= Max_Length and then Data (1 .. Current_Length)'Initialized, Put_Image => Put_Image; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 32771f06d76..2b8b64aa392 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -10101,9 +10101,13 @@ package body Sem_Ch13 is -- Start of processing for Add_Predicate begin --- A ghost predicate is checked only when Ghost mode is enabled +-- A ghost predicate is checked only when Ghost mode is enabled. +-- Add a condition for the presence of a predicate to be recorded, +-- which is needed to generate the corresponding predicate +-- function. if Is_Ignored_Ghost_Pragma (Prag) then + Add_Condition (New_Occurrence_Of (Standard_True, Sloc (Prag))); return; end if; -- 2.40.0
[COMMITTED] ada: Streamline expansion of controlled actions for aggregates
From: Eric Botcazou This changes the strategy used to expand controlled actions for array and record aggregates so as to make it simpler and more robust. The current strategy is to set the No_Ctrl_Actions flag on the assignments generated during the expansion of aggregate, as done during the expansion of initialization procedures, and to generate the adjustments of the LHS manually in the same list of actions, before sending the entire list for analysis and expansion. The problem is that, when the RHS also requires controlled actions, the No_Ctrl_Actions flag prevents transient scopes from being created around the assignments, with the end result that the actions are "naturally" generated between the assignments and adjustments of the LHS, causing premature finalization of the RHS. In order to counter that, the controlled actions of the RHS must also be generated manually during the expansion of the aggregates, after blocking normal processing e.g. by means of the No_Side_Effect_Removal flag. This means that, for a more complex RHS, this strategy generates a wrong order of controlled actions by default, until specifically adjusted. The new strategy is to reuse the standard machinery as much as possible, disabling only the part that is not needed for the assignments generated during the expansion of aggregates, namely the finalization of the LHS; in other words, the adjustment of the LHS is left entirely to the standard machinery and the creation of transient scopes is no longer blocked, which gives a correct order of controlled actions by default. It is implemented by means of a No_Finalize_Actions flag present on the assignments generated during the expansion. It is mostly straightforward, modulo the following hitch: the assignments are now analyzed and expanded by the common expander, which in the case of controlled assignments analyzes the final rewriting with all checks off, which in particular disables elaboration checks for the calls to the Adjust primitives; now these checks are necessary in the case where an aggregate is the initialization expression of an object declared before the body of the Adjust primitive is seen. Hence the use of an existing trick, namely Suppress/Unsuppress blocks, around the assignments. gcc/ada/ * gen_il-fields.ads (Opt_Field_Enum): Add No_Finalize_Actions and remove No_Side_Effect_Removal. * gen_il-gen-gen_nodes.adb (N_Function_Call): Remove semantic flag No_Side_Effect_Removal (N_Assignment_Statement): Add semantic flag No_Finalize_Actions. * sinfo.ads (No_Ctrl_Actions): Adjust comment. (No_Finalize_Actions): New flag on assignment statements. (No_Side_Effect_Removal): Delete. * exp_aggr.adb (Build_Record_Aggr_Code): Remove obsolete comment and Ancestor_Is_Expression variable. In the case of an extension, do not generate a call to Adjust manually, call Set_No_Finalize_Actions instead. Do not set the tags, replace call to Make_Unsuppress_Block by Make_Suppress_Block and remove useless assertions. In the general case, call Initialize_Component. (Initialize_Controlled_Component): Delete. (Initialize_Simple_Component): Delete. (Initialize_Component): Do the low-level processing, but do not generate a call to Adjust manually, call Set_No_Finalize_Actions. (Process_Transient_Component): Delete. (Process_Transient_Component_Completion): Likewise. * exp_ch5.adb (Expand_Assign_Array): Deal with No_Finalize_Actions. (Expand_Assign_Array_Loop): Likewise. (Expand_N_Assignment_Statement): Likewise. (Make_Tag_Ctrl_Assignment): Likewise. * exp_util.adb (Remove_Side_Effects): Do not test the No_Side_Effect_Removal flag. * sem_prag.adb (Process_Suppress_Unsuppress): Give the warning in SPARK mode only for pragma Suppress. * tbuild.ads (Make_Suppress_Block): New declaration. (Make_Unsuppress_Block): Adjust comment. * tbuild.adb (Make_Suppress_Block): New procedure. (Make_Unsuppress_Block): Unsuppress instead of suppressing. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 740 ++- gcc/ada/exp_ch5.adb | 55 ++- gcc/ada/exp_util.adb | 8 - gcc/ada/gen_il-fields.ads| 2 +- gcc/ada/gen_il-gen-gen_nodes.adb | 4 +- gcc/ada/sem_prag.adb | 5 +- gcc/ada/sinfo.ads| 31 +- gcc/ada/tbuild.adb | 36 +- gcc/ada/tbuild.ads | 11 +- 9 files changed, 142 insertions(+), 750 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index dcbf2c4981d..fb5f404922f 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -106,33 +106,13 @@ package body Exp_Aggr is -- initialization (<>) in any component (Ada 2005: AI-287). procedure Initiali
[COMMITTED] ada: Skip elaboration checks for abstract subprograms on derived types
From: Piotr Trojanek Elaboration checks skip abstract subprogram declarations, which have no body that could be examined. Now these checks also skip abstract subprograms of a derived type, which have no body either. gcc/ada/ * sem_elab.adb (Check_Overriding_Primitive): Prevent Corresponding_Body to be called with entity of an abstract subprogram. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_elab.adb | 5 - 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 1e18b987863..dc81e47da9e 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -15263,10 +15263,13 @@ package body Sem_Elab is -- Nothing to do for predefined primitives because they are -- artifacts of tagged type expansion and cannot override source -- primitives. Nothing to do as well for inherited primitives, as --- the check concerns overriding ones. +-- the check concerns overriding ones. Finally, nothing to do for +-- abstract subprograms, because they have no body that could be +-- examined. if Is_Predefined_Dispatching_Operation (Prim) or else not Is_Overriding_Subprogram (Prim) + or else Is_Abstract_Subprogram (Prim) then return; end if; -- 2.40.0
[COMMITTED] ada: Mark attribute Initialized as ghost code
From: Yannick Moy
Implement the SPARK RM change that defines attribute Initialized
as being ghost, i.e. only allowed where a ghost entity would be allowed.
gcc/ada/
* ghost.adb (Check_Ghost_Context): Allow absence of Ghost_Id
for attribute. Update error message to mention Ghost_Predicate.
(Is_Ghost_Attribute_Reference): New query.
* ghost.ads (Is_Ghost_Attribute_Reference): New query.
* sem_attr.adb (Resolve_Attribute): Check ghost context for ghost
attributes.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/ghost.adb| 15 ++-
gcc/ada/ghost.ads| 4
gcc/ada/sem_attr.adb | 7 +++
3 files changed, 25 insertions(+), 1 deletion(-)
diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb
index ee98126de81..6cf87ce29b1 100644
--- a/gcc/ada/ghost.adb
+++ b/gcc/ada/ghost.adb
@@ -655,7 +655,9 @@ package body Ghost is
-- declaration and at the point of use match.
if Is_OK_Ghost_Context (Ghost_Ref) then
- Check_Ghost_Policy (Ghost_Id, Ghost_Ref);
+ if Present (Ghost_Id) then
+Check_Ghost_Policy (Ghost_Id, Ghost_Ref);
+ end if;
-- Otherwise the Ghost entity appears in a non-Ghost context and affects
-- its behavior or value (SPARK RM 6.9(10,11)).
@@ -673,6 +675,7 @@ package body Ghost is
Ghost_Ref);
Error_Msg_N
("\either make the type ghost "
+ & "or use a Ghost_Predicate "
& "or use a type invariant on a private type", Ghost_Ref);
end if;
end if;
@@ -1194,6 +1197,16 @@ package body Ghost is
return False;
end Is_Ghost_Assignment;
+ --
+ -- Is_Ghost_Attribute_Reference --
+ --
+
+ function Is_Ghost_Attribute_Reference (N : Node_Id) return Boolean is
+ begin
+ return Nkind (N) = N_Attribute_Reference
+and then Attribute_Name (N) = Name_Initialized;
+ end Is_Ghost_Attribute_Reference;
+
--
-- Is_Ghost_Declaration --
--
diff --git a/gcc/ada/ghost.ads b/gcc/ada/ghost.ads
index 1532117955e..663e70cffe2 100644
--- a/gcc/ada/ghost.ads
+++ b/gcc/ada/ghost.ads
@@ -111,6 +111,10 @@ package Ghost is
-- Determine whether arbitrary node N denotes an assignment statement whose
-- target is a Ghost entity.
+ function Is_Ghost_Attribute_Reference (N : Node_Id) return Boolean;
+ -- Determine whether arbitrary node N denotes an attribute reference which
+ -- denotes a Ghost attribute.
+
function Is_Ghost_Declaration (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N denotes a declaration which defines
-- a Ghost entity.
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index f5ee275e23f..24f57ac43ff 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -41,6 +41,7 @@ with Exp_Dist; use Exp_Dist;
with Exp_Util; use Exp_Util;
with Expander; use Expander;
with Freeze; use Freeze;
+with Ghost; use Ghost;
with Gnatvsn;use Gnatvsn;
with Itypes; use Itypes;
with Lib;use Lib;
@@ -11068,6 +11069,12 @@ package body Sem_Attr is
Set_Etype (N, Typ);
end if;
+ -- A Ghost attribute must appear in a specific context
+
+ if Is_Ghost_Attribute_Reference (N) then
+ Check_Ghost_Context (Empty, N);
+ end if;
+
-- Remaining processing depends on attribute
case Attr_Id is
--
2.40.0
[COMMITTED] ada: Implement new aspect Always_Terminates for SPARK
From: Piotr Trojanek This patch allows subprograms to be annotated with aspect Always_Terminates that requires a boolean expression. When this expression evaluates to True, the subprogram is required to terminate or raise an exception, but not loop infinitely. This aspect is only meant to be used by GNATprove and it has no meaningful run-time semantics: either the annotated subprogram terminates and then the aspect expression doesn't matter, or the subprogram loops infinitely and there is nothing we can do. (We could also evaluate the aspect expression just to detect run-time errors in the expression itself, but this can be implemented later, after a backend support for the aspect is added to GNATprove.) Implementation of this aspect is heavily based on the implementation of Subprogram_Variant, which in turn is heavily based on the implementation of Contract_Cases. Since the new aspect is not yet expanded, there is no corresponding assertion kind that would control the expansion. gcc/ada/ * aspects.ads (Aspect_Id): Add new aspect. (Implementation_Defined_Aspect): New aspect is implementation-defined. (Aspect_Argument): New aspect has an expression argument. (Is_Representation_Aspect): New aspect is not a representation aspect. (Aspect_Names): Link new aspect identifier with a name. (Aspect_Delay): New aspect is never delayed. * contracts.adb (Expand_Subprogram_Contract): Mention new aspect in comment. (Add_Contract_Item): Attach pragma corresponding to the new aspect to contract items. (Analyze_Entry_Or_Subprogram_Contract): Analyze pragma corresponding to the new aspect that appears with subprogram spec. (Analyze_Subprogram_Body_Stub_Contract): Expand pragma corresponding to the new aspect. * contracts.ads (Add_Contract_Item, Analyze_Entry_Or_Subprogram_Contract) (Analyze_Entry_Or_Subprogram_Body_Contract) (Analyze_Subprogram_Body_Stub_Contract): Mention new aspect in comment. * einfo-utils.adb (Get_Pragma): Return pragma attached to contract. * einfo-utils.ads (Get_Pragma): Mention new contract in comment. * exp_prag.adb (Expand_Pragma_Always_Terminates): Placeholder for possibly expanding new aspect. * exp_prag.ads (Expand_Pragma_Always_Terminates): Dedicated routine for expansion of the new aspect. * inline.adb (Remove_Aspects_And_Pragmas): Remove aspect from inlined bodies. * par-prag.adb (Prag): Postpone checking of the pragma until analysis. * sem_ch12.adb: Mention new aspect in explanation of handling contracts on generic units. * sem_ch13.adb (Analyze_Aspect_Specifications): Convert new aspect into a corresponding pragma. (Check_Aspect_At_Freeze_Point): Don't expect new aspect. * sem_prag.adb (Analyze_Always_Terminates_In_Decl_Part): Analyze pragma corresponding to the new aspect. (Analyze_Pragma): Handle pragma corresponding to the new aspect. (Is_Non_Significant_Pragma_Reference): Handle references appearing within new aspect. * sem_prag.ads (Aspect_Specifying_Pragma): New aspect can be emulated with a pragma. (Assertion_Expression_Pragma): New aspect has an assertion expression. (Pragma_Significant_To_Subprograms): New aspect is significant to subprograms. (Analyze_Always_Terminates_In_Decl_Part): Add spec for routine that analyses new aspect. (Find_Related_Declaration_Or_Body): Mention new aspect in comment. * sem_util.adb (Is_Subprogram_Contract_Annotation): New aspect is a subprogram contract annotation. * sem_util.ads (Is_Subprogram_Contract_Annotation): Mention new aspect in comment. * sinfo.ads (Is_Generic_Contract_Pragma): New pragma is a generic contract. (Contract): Explain attaching new pragma to subprogram contract. * snames.ads-tmpl (Name_Always_Terminates): New name for the new contract. (Pragma_Always_Terminates): New pragma identifier. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/aspects.ads | 6 ++ gcc/ada/contracts.adb | 29 -- gcc/ada/contracts.ads | 4 + gcc/ada/einfo-utils.adb | 1 + gcc/ada/einfo-utils.ads | 1 + gcc/ada/exp_prag.adb| 10 ++ gcc/ada/exp_prag.ads| 4 + gcc/ada/inline.adb | 4 +- gcc/ada/par-prag.adb| 1 + gcc/ada/sem_ch12.adb| 7 +- gcc/ada/sem_ch13.adb| 30 -- gcc/ada/sem_prag.adb| 199 gcc/ada/sem_prag.ads| 15 ++- gcc/ada/sem_util.adb| 3 +- gcc/ada/sem_util.ads| 1 + gcc/ada/sinfo.ads | 2 + gcc/ada/snames.ads-tmpl | 2 + 17 files changed, 295 insertions(+), 24 deletions(-) diff --git a/gcc/ada/aspects.ads b/gcc/ada/a
[COMMITTED] ada: Fix spurious error on call to function returning private in generic
From: Eric Botcazou The spurious error is given on a call to a parameterless function returning a private type, present in the body of a generic construct both declared and instantiated in the presence of the full view of the type, because this full view is not properly restored for the instantiation. This is supposed to be handled by the Has_Private_View mechanism, but it is bypassed here because the call to the parameterless function is first parsed as a simple identifier before being later analyzed as a function call. Fixing this first issue uncovered another one, whereby the Has_Private_View flag was not properly set on an operator returning a private type that ends up being later resolved as a function call. Finally a small loophole in Eval_Attribute exposed by the change also needs to be plugged. gcc/ada/ * sem_attr.adb (Eval_Attribute): Add more exceptions to the early return for a prefix which is a nonfrozen generic actual type. * sem_ch12.adb (Copy_Generic_Node): Also check private views in the case of an entity name or operator analyzed as a function call. (Set_Global_Type): Make it a child of Save_Global_References. (Save_References_In_Operator): In the case where the operator has been turned into a function call, call Set_Global_Type on the entity if it is global. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_attr.adb | 8 ++- gcc/ada/sem_ch12.adb | 113 ++- 2 files changed, 63 insertions(+), 58 deletions(-) diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 24f57ac43ff..dc06435e7b0 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -8437,9 +8437,13 @@ package body Sem_Attr is -- However, the attribute Unconstrained_Array must be evaluated, -- since it is documented to be a static attribute (and can for -- example appear in a Compile_Time_Warning pragma). The frozen --- status of the type does not affect its evaluation. +-- status of the type does not affect its evaluation. Likewise +-- for attributes intended to be used with generic definitions. -and then Id /= Attribute_Unconstrained_Array +and then Id not in Attribute_Unconstrained_Array +| Attribute_Has_Access_Values +| Attribute_Has_Discriminants +| Attribute_Has_Tagged_Values then return; end if; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 2562d1a0812..0ef894e153b 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -8178,6 +8178,7 @@ package body Sem_Ch12 is and then Is_Entity_Name (Name (Assoc)) then Set_Entity (New_N, Entity (Name (Assoc))); + Check_Private_View (N); elsif Nkind (Assoc) in N_Entity and then (Expander_Active @@ -15716,6 +15717,13 @@ package body Sem_Ch12 is -- This is the recursive procedure that does the work, once the -- enclosing generic scope has been established. + procedure Set_Global_Type (N : Node_Id; N2 : Node_Id); + -- If the type of N2 is global to the generic unit, save the type in + -- the generic node. Just as we perform name capture for explicit + -- references within the generic, we must capture the global types + -- of local entities because they may participate in resolution in + -- the instance. + --- -- Is_Global -- --- @@ -15909,67 +15917,12 @@ package body Sem_Ch12 is -- procedure Reset_Entity (N : Node_Id) is - procedure Set_Global_Type (N : Node_Id; N2 : Node_Id); - -- If the type of N2 is global to the generic unit, save the type in - -- the generic node. Just as we perform name capture for explicit - -- references within the generic, we must capture the global types - -- of local entities because they may participate in resolution in - -- the instance. - function Top_Ancestor (E : Entity_Id) return Entity_Id; -- Find the ultimate ancestor of the current unit. If it is not a -- generic unit, then the name of the current unit in the prefix of -- an expanded name must be replaced with its generic homonym to -- ensure that it will be properly resolved in an instance. - - - -- Set_Global_Type -- - - - - procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is -Typ : constant Entity_Id := Etype (N2); - - begin -Set_Etype (N, Typ); - --- If the entity of N is not the associated node, this is a --- nested generic and it has an associated node as well, whose
[COMMITTED] ada: Disable inlining in potentially unevaluated contexts
From: Piotr Trojanek
Instead of explicitly disabling inlining in quantified expressions,
(which happen to be only preanalysed) and then disabling inlining in
potentially unevaluated contexts that are fully analysed (which happen
to include quantified expressions), we now simply disable inlining in
all potentially unevaluated contexts, regardless of the full analysis
mode.
This also disables inlining in iterated component associations, which
can be both preanalysed or fully analysed depending on their expression,
but nevertheless are potentially unevaluated.
gcc/ada/
* sem_res.adb (Resolve_Call): Replace early call to
In_Quantified_Expression with a call to Is_Potentially_Unevaluated that
was only done when Full_Analysis is true.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_res.adb | 21 ++---
1 file changed, 6 insertions(+), 15 deletions(-)
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index c2a4bcb58cd..41787f3d2bc 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -7290,14 +7290,14 @@ package body Sem_Res is
Cannot_Inline
("cannot inline & (in default expression)?", N, Nam_UA);
--- Calls cannot be inlined inside quantified expressions, which
--- are left in expression form for GNATprove. Since these
--- expressions are only preanalyzed, we need to detect the failure
--- to inline outside of the case for Full_Analysis below.
+-- Calls cannot be inlined inside potentially unevaluated
+-- expressions, as this would create complex actions inside
+-- expressions, that are not handled by GNATprove.
-elsif In_Quantified_Expression (N) then
+elsif Is_Potentially_Unevaluated (N) then
Cannot_Inline
- ("cannot inline & (in quantified expression)?", N, Nam_UA);
+ ("cannot inline & (in potentially unevaluated context)?",
+ N, Nam_UA);
-- Inlining should not be performed during preanalysis
@@ -7365,15 +7365,6 @@ package body Sem_Res is
elsif No (Body_To_Inline (Nam_Decl)) then
null;
- -- Calls cannot be inlined inside potentially unevaluated
- -- expressions, as this would create complex actions inside
- -- expressions, that are not handled by GNATprove.
-
- elsif Is_Potentially_Unevaluated (N) then
- Cannot_Inline
-("cannot inline & (in potentially unevaluated context)?",
- N, Nam_UA);
-
-- Calls cannot be inlined inside the conditions of while
-- loops, as this would create complex actions inside
-- the condition, that are not handled by GNATprove.
--
2.40.0
[COMMITTED] ada: Fix iterated component initialization
The call to Resolve_Aggr_Expr may leave references to temporary entities used to check for the construct legality and meant to be removed. Using Preanalyze_And_Resolve correctly guarantees that there is no visible occurrence of such entities. gcc/ada/ * sem_aggr.adb (Resolve_Iterated_Component_Association): Call Preanalyze_And_Resolve instead of Resolve_Aggr_Expr except for aggregate. Co-authored-by: Ed Schonberg Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_aggr.adb | 11 --- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 3b2d0347b41..843606ab4a1 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1862,9 +1862,14 @@ package body Sem_Aggr is Expr := Expression (N); - Expander_Mode_Save_And_Set (False); - Dummy := Resolve_Aggr_Expr (Expr, Single_Elmt => False); - Expander_Mode_Restore; + if Nkind (Expr) = N_Aggregate then +-- If the expression is an aggregate, this is a multidimensional +-- aggregate where the component type must be propagated downward. + +Dummy := Resolve_Aggr_Expr (Expr, Single_Elmt => False); + else +Preanalyze_And_Resolve (Expr, Component_Typ); + end if; if Operating_Mode /= Check_Semantics then Remove_References (Expr); -- 2.40.0
[COMMITTED] ada: Recognize iterated_component_association as potentially unevaluated
From: Piotr Trojanek Routine Is_Potentially_Unevaluated was written for Ada 2012, but now we use it for Ada 2022 as well, so it must recognize iterated component associations (which were added by Ada 2022) as an array component association. gcc/ada/ * sem_util.adb (Is_Potentially_Unevaluated): Recognize iterated component association as potentially unevaluated. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_util.adb | 14 ++ 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index b82978ba99e..23668f1bec5 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -19566,7 +19566,8 @@ package body Sem_Util is elsif Nkind (Par) = N_Quantified_Expression then return Expr = Condition (Par); - elsif Nkind (Par) = N_Component_Association + elsif Nkind (Par) in N_Component_Association +| N_Iterated_Component_Association and then Expr = Expression (Par) and then Nkind (Parent (Par)) in N_Aggregate | N_Delta_Aggregate | N_Extension_Aggregate @@ -19708,10 +19709,15 @@ package body Sem_Util is then return True; - -- For component associations continue climbing; it may be part of - -- an array aggregate. + -- For component associations continue climbing; it may be part of an + -- array aggregate. For iterated component association we know that + -- it belongs to an array aggreate, but only its expression is + -- potentially unevaluated, not discrete choice list or iterator + -- specification. - elsif Nkind (Par) = N_Component_Association then + elsif Nkind (Par) in N_Component_Association +| N_Iterated_Component_Association + then null; -- If the context is not an expression, or if is the result of -- 2.40.0
[COMMITTED] ada: Recognize iterated_component_association as repeatedly evaluated
From: Piotr Trojanek As iterated_component_association is an array_component_association (because of a grammar rule Ada 2022 RM 4.3.3(5/5)), its expression is repeatedly evaluated (because of Ada 2022 RM 6.1.1(22.14/5)). With this patch we will now get errors for both conjuncts in this code, which have semantically equivalent array aggregates that use an ordinary component association and iterated component association. procedure Iter (S : String) with Post => String'(for J in 1 .. 3 => S (S'First)'Old) = String'( 1 .. 3 => S (S'First)'Old); gcc/ada/ * sem_util.adb (Is_Repeatedly_Evaluated): Recognize iterated component association as repeatedly evaluated. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_util.adb | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 23668f1bec5..3fd3eb45f33 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -30768,7 +30768,8 @@ package body Sem_Util is --array_component_association or of --a container_element_associatiation. - if Nkind (Par) = N_Component_Association + if Nkind (Par) in N_Component_Association + | N_Iterated_Component_Association and then Trailer = Expression (Par) then -- determine whether Par is part of an array aggregate -- 2.40.0
[COMMITTED] ada: Fix another case of missing Has_Private_View flag
From: Eric Botcazou It occurs for the case of a function call first parsed as an identifier. gcc/ada/ * sem_ch12.adb (Save_References_In_Identifier): In the case where the identifier has been turned into a function call by analysis, call Set_Global_Type on the entity if it is global. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_ch12.adb | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 0ef894e153b..a38ab284ce7 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -16526,7 +16526,7 @@ package body Sem_Ch12 is E := Entity (Name (N2)); if Present (E) and then Is_Global (E) then - Set_Etype (N, Etype (N2)); + Set_Global_Type (N, N2); else Set_Associated_Node (N, Empty); Set_Etype (N, Empty); -- 2.40.0
[COMMITTED] ada: Fix decoration of iterated component association for GNATprove
From: Piotr Trojanek This patch is an alternative solution for a recent fix in analysis of iterated component association. To recap, if the iterated expression is an aggregate, we want to propagate the component type downward with a call to Resolve_Aggr_Expr; otherwise we want this expression to be only preanalysed (since the association might need to be repeatedly evaluated), but also we need to apply predicate and range checks to the expression itself (these are required for GNATprove). It turns out that Resolve_Aggr_Expr already knows how to deal with a nested aggregate and also works for GNATprove, where it both preanalyzes the expression and applies necessary checks. In other words, expression of the iterated component association is now resolved just like expression of an ordinary array aggregate. gcc/ada/ * sem_aggr.adb (Resolve_Iterated_Component_Association): Simply resolve the expression. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_aggr.adb | 9 + 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 843606ab4a1..c6063c78bf6 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1862,14 +1862,7 @@ package body Sem_Aggr is Expr := Expression (N); - if Nkind (Expr) = N_Aggregate then --- If the expression is an aggregate, this is a multidimensional --- aggregate where the component type must be propagated downward. - -Dummy := Resolve_Aggr_Expr (Expr, Single_Elmt => False); - else -Preanalyze_And_Resolve (Expr, Component_Typ); - end if; + Dummy := Resolve_Aggr_Expr (Expr, Single_Elmt => False); if Operating_Mode /= Check_Semantics then Remove_References (Expr); -- 2.40.0
[COMMITTED] ada: Cleanup analysis of iterated component association
From: Piotr Trojanek Cleanups related to analysis of iterated component association for GNATprove. gcc/ada/ * sem_aggr.adb (Resolve_Array_Aggregate): Simplify comment. (Resolve_Iterated_Component_Association): Tune comment; change variable to constant. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_aggr.adb | 12 +--- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index c6063c78bf6..39189463871 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1331,9 +1331,9 @@ package body Sem_Aggr is -- In this event we do not resolve Expr unless expansion is disabled. -- To know why, see the DELAYED COMPONENT RESOLUTION note above. -- - -- NOTE: In the case of "... => <>", we pass the in the - -- N_Component_Association node as Expr, since there is no Expression in - -- that case, and we need a Sloc for the error message. + -- NOTE: In the case of "... => <>", we pass the N_Component_Association + -- node as Expr, since there is no Expression and we need a Sloc for the + -- error message. procedure Resolve_Iterated_Component_Association (N : Node_Id; @@ -1790,7 +1790,7 @@ package body Sem_Aggr is Choice : Node_Id; Dummy : Boolean; Scop : Entity_Id; - Expr : Node_Id; + Expr : constant Node_Id := Expression (N); -- Start of processing for Resolve_Iterated_Component_Association @@ -1854,14 +1854,12 @@ package body Sem_Aggr is Set_Scope (Id, Scop); end if; - -- Analyze expression without expansion, to verify legality. + -- Analyze expression without expansion, to verify legality. -- When generating code, we then remove references to the index -- variable, because the expression will be analyzed anew after -- rewritting as a loop with a new index variable; when not -- generating code we leave the analyzed expression as it is. - Expr := Expression (N); - Dummy := Resolve_Aggr_Expr (Expr, Single_Elmt => False); if Operating_Mode /= Check_Semantics then -- 2.40.0
[COMMITTED] ada: Remove obsolete references for Build_Transient_Object_Statements
From: Eric Botcazou gcc/ada/ * exp_util.ads (Build_Transient_Object_Statements): Remove obsolete references to array and record aggregates in documentation. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_util.ads | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 06bd4141c27..66c4dc6be4c 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -372,9 +372,9 @@ package Exp_Util is Ptr_Decl : out Node_Id; Finalize_Obj : Boolean := True); -- Subsidiary to the processing of transient objects in transient scopes, - -- if expressions, case expressions, expression_with_action nodes, array - -- aggregates, and record aggregates. Obj_Decl denotes the declaration of - -- the transient object. Generate the following nodes: + -- if expressions, case expressions, and expression_with_action nodes. + -- Obj_Decl denotes the declaration of the transient object. Generate the + -- following nodes: -- --* Fin_Call - the call to [Deep_]Finalize which cleans up the transient --object if flag Finalize_Obj is set to True, or finalizes the hook when -- 2.40.0
[COMMITTED] ada: Crash on C++ constructor of private type
From: Javier Miranda The compiler crashes compiling a function that has pragma CPP_constructor when its return type is a private type. gcc/ada/ * sem_util.adb (Is_CPP_Constructor_Call): Add missing support for calls to functions returning a private type. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_util.adb | 20 ++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 3fd3eb45f33..3a64047d45c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -16153,9 +16153,25 @@ package body Sem_Util is - function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is + Ret_Typ : Entity_Id; + begin - return Nkind (N) = N_Function_Call -and then Is_CPP_Class (Etype (Etype (N))) + if Nkind (N) /= N_Function_Call then + return False; + end if; + + Ret_Typ := Base_Type (Etype (N)); + + if Is_Class_Wide_Type (Ret_Typ) then + Ret_Typ := Root_Type (Ret_Typ); + end if; + + if Is_Private_Type (Ret_Typ) then + Ret_Typ := Underlying_Type (Ret_Typ); + end if; + + return Present (Ret_Typ) +and then Is_CPP_Class (Ret_Typ) and then Is_Constructor (Entity (Name (N))) and then Is_Imported (Entity (Name (N))); end Is_CPP_Constructor_Call; -- 2.40.0
[COMMITTED] ada: Fix inverted implementation of RM 8.4(10) clause for operators
From: Eric Botcazou The comment is correct but the code implements the opposite outcome. gcc/ada/ * sem_type.adb (Disambiguate): Fix pasto in the implementation of the RM 8.4(10) clause for operators. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_type.adb | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index d4006e4270b..8519b97fa41 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -2229,7 +2229,7 @@ package body Sem_Type is Is_Immediately_Visible (Base_Type (Etype (Right_Opnd (N and then Is_Potentially_Use_Visible (User_Subp) then - if It2.Nam = Predef_Subp then + if It1.Nam = Predef_Subp then return It1; else return It2; -- 2.40.0
[COMMITTED] ada: Fix aspect Linker_Section ignored on subprogram body
From: Eric Botcazou The compiler is waiting for the freeze node of the body, but it is never generated since the freezing of the body is not delayed. The change also removes an obsolete piece of code. gcc/ada/ * sem_ch13.adb (Analyze_Aspect_Specifications): Add missing items in the list of aspects handled by means of Insert_Pragma. : Remove obsolete code. Do not delay the processing of the aspect if the entity is already frozen. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_ch13.adb | 34 ++ 1 file changed, 22 insertions(+), 12 deletions(-) diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index e771c0d2020..65627321ffe 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1409,20 +1409,37 @@ package body Sem_Ch13 is --Abstract_State --Always_Terminates --Attach_Handler + --Async_Readers + --Async_Writers + --Constant_After_Elaboration --Contract_Cases + --Convention + --Default_Initial_Condition + --Default_Storage_Pool --Depends + --Effective_Reads + --Effective_Writes --Exceptional_Cases + --Extensions_Visible --Ghost --Global --Initial_Condition --Initializes + --Max_Entry_Queue_Depth + --Max_Entry_Queue_Length + --Max_Queue_Length + --No_Caching + --Part_Of --Post --Pre --Refined_Depends --Refined_Global + --Refined_Post --Refined_State --SPARK_Mode + --Secondary_Stack_Size --Subprogram_Variant + --Volatile_Function --Warnings -- Insert pragma Prag such that it mimics the placement of a source -- pragma of the same kind. Flag Is_Generic should be set when the @@ -3064,16 +3081,11 @@ package body Sem_Ch13 is Expression => Relocate_Node (Expr))), Pragma_Name => Name_Linker_Section); - -- Linker_Section does not need delaying, as its argument - -- must be a static string. Furthermore, if applied to - -- an object with an explicit initialization, the object - -- must be frozen in order to elaborate the initialization - -- code. (This is already done for types with implicit - -- initialization, such as protected types.) + -- No need to delay the processing if the entity is already + -- frozen. This should only happen for subprogram bodies. - if Nkind (N) = N_Object_Declaration -and then Has_Init_Expression (N) - then + if Is_Frozen (E) then + pragma Assert (Nkind (N) = N_Subprogram_Body); Delay_Required := False; end if; @@ -4763,9 +4775,7 @@ package body Sem_Ch13 is -- For an aspect that applies to a type, indicate whether it -- appears on a partial view of the type. -if Is_Type (E) - and then Is_Private_Type (E) -then +if Is_Type (E) and then Is_Private_Type (E) then Set_Aspect_On_Partial_View (Aspect); end if; -- 2.40.0
